home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 8 Other / 08-Other.zip / HPTDEM.ZIP / HAPLIST.RXC next >
Text File  |  1992-03-17  |  4KB  |  107 lines
  1. /* HAPLIST demo version (c) Copyright HeteroGenius Systems Ltd 1992 */
  2.         /* DEMOCMD -*- DEMOCMD -*- DEMOCMD -*- DEMOCMD */
  3. PARSE UPPER ARG luname,outfile,pattern
  4. IF VALUE('HAPLOGON_'luname,'Y','OS2ENVIRONMENT') <> 'Y' THEN
  5.    CALL HAPLOGON luname
  6. SAY "HDP205I List request sent to" luname "*** SIMULATION ONLY ***"
  7.  
  8. /* Prepare to write the output file */
  9. CALL STREAM outfile,'C','OPEN'
  10. CALL STREAM outfile,'C','SEEK 0'
  11.  
  12. /* Set up table of file names and member names */
  13. d. = ''
  14. d.1="HETERO.ASM";       a.1="PO"
  15. d.2="HETERO.CLIST";     a.2="PO"
  16. d.3="HETERO.H";         a.3="PO"
  17. d.4="HETERO.MACLIB";    a.4="PO"
  18. d.5="HETERO.MODS";      a.5="PO"
  19. d.6="HETERO.MSGS";      a.6="PO"
  20. d.7="HETERO.PANELS";    a.7="MIGRAT"
  21. d.8="SEQDS";            a.8="PS"
  22. m. = ''
  23. m.1="APPCCTL";          s.1="91/12/23 11:57"
  24. m.2="APPCSVC";          s.2="92/01/31 15:32"
  25. m.3="APPCTPI";          s.3="91/07/15 09:14"
  26. m.4="HAPDEF";           s.4="91/12/28 20:39"
  27. m.5="HAPPC";            s.5="92/02/18 11:18"
  28.  
  29. /* Try to make sense of the pattern */
  30. alnum = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ$#@0123456789'
  31. PARSE VAR pattern dspatt '(' mempat ')' residue
  32. IF residue ¬= '' THEN SIGNAL invpatt
  33. IF mempat ¬= '' THEN DO
  34.    IF LENGTH(mempat) > 8 THEN SIGNAL invpatt
  35.    IF VERIFY(mempat,alnum'?*') > 0 THEN SIGNAL invpatt
  36.    IF VERIFY(dspatt,'?*','M') > 0 THEN SIGNAL invpatt
  37. END
  38. IF VERIFY(dspatt,alnum'.?*') > 0 THEN SIGNAL invpatt
  39. PARSE VAR dspatt hiqual '.' loqual
  40. PARSE VAR hiqual hiqual '*' residue
  41. IF ABBREV('GATSBYG',hiqual) THEN hiqual = 'GATSBYG'
  42. hiqual = TRANSLATE(hiqual,'X','?')
  43. IF LENGTH(hiqual) > 8 THEN SIGNAL invpatt
  44. IF DATATYPE(hiqual,'A') = 0 THEN SIGNAL invpatt
  45.  
  46. /* Produce list of matching files */
  47. DO 2500; n = 0; END /* Delay loop */
  48. IF mempat = '' THEN DO k = 1 WHILE d.k ¬= ''
  49.    dsn = hiqual'.'d.k
  50.    IF test_match(dsn,pattern) THEN DO
  51.       CALL LINEOUT outfile,dsn || '00'x || LEFT(a.k,28)
  52.       n = n + 1; END
  53. END
  54. /* Produce list of matching members */
  55. ELSE DO k = 1 WHILE m.k ¬= ''
  56.    IF test_match(m.k,mempat) THEN DO
  57.       CALL LINEOUT outfile,m.k || '00'x || RIGHT(s.k,28)
  58.       n = n + 1; END
  59. END
  60.  
  61. /* Close the output file */
  62. CALL CHAROUT outfile,'1A'X
  63. CALL STREAM outfile,'C','CLOSE'
  64. IF n = 0 THEN SIGNAL nomatch
  65. EXIT 0
  66.  
  67. /* Error exits */
  68. invpatt:
  69. nomatch:
  70. SAY "No matches for dataset name" pattern
  71. SAY "For demonstration, specify GATSBYG.*"
  72. CALL STREAM outfile,'C','CLOSE'
  73. EXIT 'HAPFAIL'
  74.  
  75. /* Procedure to test whether file name matches pattern */
  76. test_match: PROCEDURE
  77. ARG name,pattern
  78. DO WHILE pattern ¬= ''                  /* for each pattern char     */
  79.     IF LEFT(pattern,1) = '?' THEN DO
  80.         pattern = SUBSTR(pattern,2)     /* to next pattern char      */
  81.         IF name ¬= '' & LEFT(name,1) ¬= '.' THEN
  82.             name = SUBSTR(name,2)       /* to next name character    */
  83.         ITERATE                         /* and check next pair       */
  84.     END
  85.     IF LEFT(pattern,1) = '*' THEN DO
  86.         IF name = '' THEN DO            /* if name is exhausted      */
  87.             pattern = SUBSTR(pattern,2) /* point past '*'            */
  88.             ITERATE                     /* and check next pair       */
  89.         END
  90.         name = SUBSTR(name,2)           /* to next name character    */
  91.         IF SUBSTR(pattern,2,1) = LEFT(name,1) THEN
  92.                                         /* if next character matches */
  93.             pattern = SUBSTR(pattern,2) /* point past '*'            */
  94.         ITERATE                         /* and check next pair       */
  95.     END
  96.     IF name = '' THEN                   /* If name is exhausted      */
  97.         RETURN 0                        /* exit with 'no-match' code */
  98.     IF LEFT(name,1) ¬= LEFT(pattern,1) THEN
  99.         RETURN 0                        /* exit with 'no-match' code */
  100.     name = SUBSTR(name,2)               /* to next name character    */
  101.     pattern = SUBSTR(pattern,2)         /* to next pattern character */
  102. END
  103. IF name ¬= '' THEN                      /* If name has more chars    */
  104.     RETURN 0                            /* exit with 'no-match' code */
  105. RETURN 1                                /* Exit with 'matched' code  */
  106.         /* DEMOCMD -*- DEMOCMD -*- DEMOCMD -*- DEMOCMD */
  107.