$CONTROL MAP, USLINIT, CODE                                             00012000
<<RECOVR2>>                                                             00014000
<< HP32002B MPE SOURCE B.01.00 >>                                       00016000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1976. ",            & 00018000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00020000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00022000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00024000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00026000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00028000
$CONTROL PRIVILEGED,MAIN=RECOVER                                        00030000
   BEGIN                                                                00032000
                                                                        00034000
LOGICAL ARRAY                                                           00036000
   OUTPUTBUFFER (0:65);                                                 00038000
                                                                        00040000
BYTE ARRAY                                                              00042000
   OUTPUTBUFFER' (*) = OUTPUTBUFFER (0);                                00044000
                                                                        00046000
BYTE POINTER                                                            00048000
   POUT;                                                                00050000
                                                                        00052000
DEFINE                                                                  00054000
   ENDSAY =                                                             00056000
      ,2;                                                               00058000
      @POUT:=TOS;                                                       00060000
      END #,                                                            00062000
   SAY =                                                                00064000
      BEGIN                                                             00066000
      MOVE POUT:=  #;                                                   00068000
DEFINE                                                                  00070000
PTITLE=("RECOVER2 V.UU.FF (C) HEWLETT-PACKARD CO., 1982")#;             00072000
EQUATE VUUFF'COL = 9;                                                   00074000
$INCLUDE INCLVUF                                                        00076000
<<    **** DEFINES, EQUATES FOR PATTERN ROUTINES ****    >>             00078000
<< PATTERN...a pattern matcher that implements a fairly simple          00080000
   pattern matching scheme.  It matches a pattern versus a string       00082000
   of up to 8 characters.  Wildcards, and their meanings, are:          00084000
         @        Match from 0 to 8 characters.                         00086000
         ?        Match any single character.                           00088000
         #        Match any single digit (0..9).                        00090000
                                                                        00092000
   Written by:  Stan Sieler   June, 1980                                00094000
>>                                                                      00096000
DEFINE                                                                  00098000
                                                                        00100000
   PAT'MAX'FIRM      = 8 #,    <<max number of firm chars>>             00102000
   PAT'MAX'PART      = 8 #,    <<max number of pattern parts>>          00104000
                                                                        00106000
   PATCHARf          = (8:8) #,                                         00108000
   PATLENf           = (2:6) #,                                         00110000
   PATTYPEf          = (0:2) #;                                         00112000
                                                                        00114000
EQUATE                                                                  00116000
                                                                        00118000
      <<values found in the PATTYPEf field...>>                         00120000
                                                                        00122000
   ANYONECHARACTERp  = 0,     <<a CASE statement in SUB'MATCH >>        00124000
   ANYCHARACTERSp    = 1,     <<depends                       >>        00126000
   DIGITONLYp        = 2,     <<        on this               >>        00128000
   EXACTp            = 3,     <<                ordering!     >>        00130000
                                                                        00132000
      <<PATTERN'BUILD errors...>>                                       00134000
                                                                        00136000
   PB'ERR'MANY'FIRM  = 1,     <<more than 8 'firm' chars were found>>   00138000
   PB'ERR'MANY'PARTS = 2;     <<more than 8 parts were found>>          00140000
                                                                        00142000
<<***************************************************************>>     00144000
      BYTE ARRAY CLASS(0:7);                                            00146000
                                                                        00148000
      INTEGER ARRAY TBLOCK(0:4095);  <<TAPE READ BUFFER>>               00150000
      INTEGER ARRAY FLAB(0:127);                                        00152000
      DOUBLE ARRAY DFLAB(*)=FLAB;                                       00154000
      BYTE ARRAY TFLAB(*)=FLAB;                                         00156000
                                                                        00158000
      INTEGER POINTER TANK;                                             00160000
      BYTE ARRAY LIST(0:4):="LIST ";                                    00162000
      BYTE ARRAY SACOUNT(0:7),SGROUP(0:7);                              00164000
      BYTE ARRAY TAPE(0:8):="RECOVTP ";                                 00166000
      BYTE ARRAY DEV(0:5):="TAPE ";                                     00168000
      BYTE ARRAY BUF(0:71);                                             00170000
      BYTE ARRAY FORMDES(0:36);                                         00172000
      BYTE ARRAY A(0:35);                                               00174000
      BYTE ARRAY CNTRLYMSGB(0:53):=                                     00176000
      "CONTROL-Y WILL BE ACKNOWLEDGED AT THE END OF THIS FILE";         00178000
      ARRAY CNTRLYMSG(*)=CNTRLYMSGB;                                    00180000
      BYTE ARRAY CNTRLYMSG2B(0:38):=                                    00182000
      "CONTROL-Y DETECTED:  ABORT OR CONTINUE?";                        00184000
      ARRAY CNTRLYMSG2(*)=CNTRLYMSG2B;                                  00186000
      BYTE ARRAY COMMAND'STRING(0:50);                                  00188000
      INTEGER ARRAY ISACOUNT(*)=SACOUNT;                                00190000
      INTEGER ARRAY ISGROUP(*)=SGROUP;                                  00192000
      INTEGER ARRAY TBUF(*)=BUF;                                        00194000
      INTEGER TNUM,LEN,DNUM,ERRCODE,NUMEXT,LDEV,OLD'FILE;               00196000
      INTEGER EXTSIZE,LASTEXTSIZE;                                      00198000
      LOGICAL CONTROL'Y'DETECTED:=FALSE;                                00200000
      EQUATE EXITN=%31400;                                              00202000
      INTEGER DUMMY,PARM,J;                                             00204000
      DOUBLE NUMSECT,LABADR;                                            00206000
      INTEGER STATUS=Q-1;                                               00208000
      DEFINE CC=STATUS.(6:2)#;                                          00210000
      EQUATE STDLIST=2; <<$STDLIST IS ALWAYS FILE #2>>                  00212000
      <<THIS IS USED FOR CALLS TO DISABLE SYSTEM BREAK>>                00214000
      EQUATE CCE=2,  <<Condition code values>>                          00216000
             CCG=0,                                                     00218000
             CCL=1,                                                     00220000
             CR =%15;                                                   00222000
      INTEGER X=X;                                                      00224000
      LOGICAL NOTKEEP := FALSE;                                         00226000
      EQUATE                                                            00228000
           FLSKIP1 = 28,                                                00230000
           FLSKIP2 = 34,                                                00232000
           FLSKIP3 = 35;                                                00234000
      DEFINE CHECKSUM = TOS:=-1;                                        00236000
                        X:=127;                                         00238000
                        DO BEGIN                                        00240000
                           IF X <> FLSKIP1 AND X <> FLSKIP2 AND         00242000
                           X <> FLSKIP3 THEN                            00244000
                           TOS:=TOS XOR LOGICAL(TANK(X));               00246000
                           X:=X-1;                                      00248000
                           END UNTIL < #;                               00250000
      DEFINE KEEPING'FILES = NOT NOTKEEP#;                              00252000
                                                                        00254000
      INTEGER                                                           00256000
       S0 = S-0,                                                        00258000
       SECTOFF,                                                         00260000
       ULABS,                                                           00262000
       ULABEOF,                                                         00264000
       FILECODE,                                                        00266000
       FILELIST,                                                        00268000
       SPB;                                                             00270000
<<                                                        >>            00272000
      LOGICAL                                                           00274000
       GOT'LIST := FALSE,                                               00276000
       KEEP'SOME:= FALSE,                                               00278000
       GOT'WILD := FALSE;                                               00280000
                                                                        00282000
     INTEGER NUM'STRICT := 0;                                           00284000
                                                                        00286000
                                                                        00288000
      BYTE ARRAY                                                        00290000
       OUT'LIST (0:830),                                                00292000
       FILE'LIST(0:360),                                                00294000
       STND'FORM(0:80);                                                 00296000
                                                                        00298000
      BYTE POINTER                                                      00300000
       LIST'PT         := @FILE'LIST,                                   00302000
       OUT'PT          := @OUT'LIST,                                    00304000
       FORMDES'PTR     := @FORMDES,                                     00306000
       FORMDES'STD'PTR := @STND'FORM,                                   00308000
       END'OF'LIST     := @FILE'LIST,                                   00310000
       START ;                                                          00312000
                                                                        00314000
DEFINE MAX'LIST = 10 #,     << MAX NUMBER OR FILESETS SPECIFIED >>      00316000
                                                                        00318000
       SECT'OFFSET   =    FLAB(%47).(0:8)#; <<Sector offset into>>      00320000
                                            << data             >>      00322000
INTEGER ERROR,CHAR'INX,KOUNT;                                           00324000
<<                                                        >>            00326000
      INTRINSIC FCONTROL,FOPEN,FCLOSE,FCHECK,FGETINFO,FREAD,FWRITE;     00328000
      INTRINSIC PRINT'FILE'INFO,WHO,GETUSERMODE,READ,PRINT,ASCII,DASCII;00330000
   INTRINSIC                                                            00332000
       XCONTRAP,RESETCONTROL,                                           00334000
       FWRITELABEL,GETPRIVMODE,FERRMSG,COMMAND;                         00336000
                                                                        00338000
<<                                                                      00340000
*******************************************************************     00342000
                                                                        00344000
   STANDARD'TO'DISPLAY  and  DISPLAY'TO'STANDARD                        00346000
                                                                        00348000
   Designed and written in 1980 by Stan Sieler.                         00350000
                                                                        00352000
*******************************************************************     00354000
>>                                                                      00356000
                                                                        00358000
EQUATE                                                                  00360000
   MAX'STD'LEN    = ( 10  <<overhead>> <<max len of std-form title>>    00362000
                     + 2 + 8           <<file part>>                    00364000
                     + 1 + 8           <<lock part>>                    00366000
                     + 1 + 8           <<group part>>                   00368000
                     + 1 + 8           <<acct part>>                    00370000
                     + 1 + 8           <<family part>>                  00372000
                     + 1 + 8           <<host part>>                    00374000
                     + 10     ),       <<expansion!>>                   00376000
   MAX'TITLE'LEN  = (  1 + 8           <<"*" & file part length>>       00378000
                     + 1 + 8           <</lockword>>                    00380000
                     + 1 + 8           <<.group>>                       00382000
                     + 1 + 8           <<.account>>                     00384000
                     + 1 ),            <<trailing blank>>               00386000
   MAX'TITLE'LEN2 = (MAX'TITLE'LEN                                      00388000
                     + 1 + 8           <<-file>>                        00390000
                     + 1 + 8           <<.group     ...no lockword!>>   00392000
                     + 1 + 8           <<.account>>                     00394000
                     + 0 );            <<trailing blank added above>>   00396000
                                                                        00398000
DEFINE                                                                  00400000
   FAILED   = FALSE #,                                                  00402000
   GOOD     = TRUE #;                                                   00404000
$PAGE "GLOBAL DEFINES -- STANDARD FORM FILE TITLES"                     00406000
DEFINE                                                                  00408000
         <<standard form title defines...>>                             00410000
                                                                        00412000
   STD'LEN'TOTAL  = ISTD (00) #, <<integer: length in bytes, inclu>>    00414000
   STD'VERSION    = PSTD (02) #,       <<std-form version id (=1) >>    00416000
   STD'INFO       = PSTD (03) #,       <<info bits:               >>    00418000
   STD'BACK       = STD'INFO.(13:1) #, <<  1 = back referenced    >>    00420000
   STD'DOLLAR     = STD'INFO.(14:1) #, <<  1 = dollar sign        >>    00422000
   STD'WILD       = STD'INFO.(15:1) #, <<  1 = wildcards in title >>    00424000
   STD'FILE'INX   = PSTD (04) #,       <<byte index of file part  >>    00426000
   STD'LOCK'INX   = PSTD (05) #,       <<byte index of lock part  >>    00428000
   STD'GROUP'INX  = PSTD (06) #,       <<byte index of group part >>    00430000
   STD'ACCT'INX   = PSTD (07) #,       <<byte index of acct part  >>    00432000
   STD'FAMILY'INX = PSTD (08) #,       <<byte index of family part>>    00434000
   STD'HOST'INX   = PSTD (09) #,       <<byte index of host part  >>    00436000
                                                                        00438000
   STD'FILE'PARTS = PSTD (STD'FILE'INX-1)#,  <<# file parts  (:=1)>>    00440000
   STD'FILE'INFO  = PSTD (STD'FILE'INX) #,   <<file info bits:    >>    00442000
   STD'FILE'WILD  = STD'FILE'INFO.(8:1) #,   << 1 = wildcards     >>    00444000
   STD'FILE'LEN   = STD'FILE'INFO.(9:7) #,   << length (0 to 8)   >>    00446000
   STD'PART'LENf  = (9:7) #,                                            00448000
   STD'FILE'      = PSTD (STD'FILE'INX+1) #, <<pointer to file txt>>    00450000
                                                                        00452000
   STD'LOCK'INFO  = PSTD (STD'LOCK'INX) #,   <<lock info bits:    >>    00454000
   STD'LOCK'WILD  = STD'LOCK'INFO.(8:1) #,   << 1 = wildcards     >>    00456000
   STD'LOCK'LEN   = STD'LOCK'INFO.(9:7) #,   << length (0 to 8)   >>    00458000
   STD'LOCK'      = PSTD (STD'LOCK'INX+1) #, <<pointer to lock txt>>    00460000
                                                                        00462000
   STD'GROUP'INFO = PSTD (STD'GROUP'INX) #,  <<group info bits:    >>   00464000
   STD'GROUP'WILD = STD'GROUP'INFO.(8:1) #,  << 1 = wildcards     >>    00466000
   STD'GROUP'LEN  = STD'GROUP'INFO.(9:7) #,  << length (0 to 8)   >>    00468000
   STD'GROUP'     = PSTD (STD'GROUP'INX+1) #,<<pointer to group txt>>   00470000
                                                                        00472000
   STD'ACCT'INFO  = PSTD (STD'ACCT'INX) #,   <<acct info bits:    >>    00474000
   STD'ACCT'WILD  = STD'ACCT'INFO.(8:1) #,   << 1 = wildcards     >>    00476000
   STD'ACCT'LEN   = STD'ACCT'INFO.(9:7) #,   << length (0 to 8)   >>    00478000
   STD'ACCT'      = PSTD (STD'ACCT'INX+1) #, <<pointer to acct txt>>    00480000
                                                                        00482000
   STD'FAMILY'INFO= PSTD (STD'FAMILY'INX) #, <<family info bits:  >>    00484000
   STD'FAMILY'WILD= STD'FAMILY'INFO.(8:1) #, << 1 = wildcards     >>    00486000
   STD'FAMILY'LEN = STD'FAMILY'INFO.(9:7) #, << length (0 to 8)   >>    00488000
   STD'FAMILY'    = PSTD (STD'FAMILY'INX+1)#,<<pntr to family txt >>    00490000
                                                                        00492000
   STD'HOST'INFO  = PSTD (STD'HOST'INX) #,   <<host info bits:    >>    00494000
   STD'HOST'WILD  = STD'HOST'INFO.(8:1) #,   << 1 = wildcards     >>    00496000
   STD'HOST'LEN   = STD'HOST'INFO.(9:7) #,   << length (0 to 8)   >>    00498000
   STD'HOST'      = PSTD (STD'HOST'INX+1) #; <<pointer to host txt>>    00500000
$PAGE "GLOBAL EQUATES -- STANDARD FORM ERRORS"                          00502000
EQUATE                                                                  00504000
                                                                        00506000
      <<error numbers for standard form conversion...>>                 00508000
                                                                        00510000
         <<from standard to display...>>                                00512000
                                                                        00514000
   DE'STANDARD'TOO'LONG =  1, <<resultant display title too long>>      00516000
   DE'STANDARD'EMPTY    =  2, <<zero length file part in std title>>    00518000
                                                                        00520000
         <<from display to standard...>>                                00522000
                                                                        00524000
   SE'PART'TOO'LONG     =  1, <<part too long>>                         00526000
   SE'ZERO'PART         =  2, <<zero length part>>                      00528000
   SE'WILD'D'OR'B       =  3, <<wild and either $ or *>>                00530000
   SE'FIRST'IS'DIGIT    =  4, <<first char cant be digit>>              00532000
   SE'LOCKWORD'LOC      =  5, <<bad place for lockword>>                00534000
   SE'TOO'MANY'PERIODS  =  6, <<too many periods>>                      00536000
   SE'STAR'NOT'FIRST    =  7, <<"*" must be first character>>           00538000
   SE'STAR'AND'DOLLAR   =  8, <<dollar and backref true>>               00540000
   SE'DOLLAR'NOT'FIRST  =  9, <<"$" must be first character>>           00542000
   SE'ILLEGAL'CHARACTER = 10, <<invalid title character>>               00544000
   SE'MISSING'PARAMETERS= 11; <<needed parameters were omitted>>        00546000
                                                                        00548000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,M,P1,P2,P3,P4,P5,                  00550000
         D,R,O,DST,C);                                                  00552000
   VALUE SETNO,MSGNO,M,P1,P2,P3,P4,P5,D,R,O,DST,C;                      00554000
   INTEGER SETNO,MSGNO,D,DST;                                           00556000
   LOGICAL M,P1,P2,P3,P4,P5,R,O,C;                                      00558000
   OPTION EXTERNAL,VARIABLE;                                            00560000
$PAGE "DISPLAY'TO'STANDARD"                                             00562000
<<************************************************************>>        00564000
LOGICAL PROCEDURE DISPLAY'TO'STANDARD (PDIS, PSTD, ERROR, CHAR'INX,     00566000
                                       DELIMS);                         00568000
            VALUE PDIS, PSTD, DELIMS;                                   00570000
            INTEGER ERROR, CHAR'INX;                                    00572000
            BYTE POINTER PDIS, PSTD, DELIMS;                            00574000
            OPTION VARIABLE;                                            00576000
   <<This routine converts a display form file title into               00578000
     a standard form file title.  If an error occurs, the error         00580000
     number is reported in ERROR.                                       00582000
     Parameters:                                                        00584000
                                                                        00586000
      PDIS:  byte pointer, points to a file title (with or              00588000
         without wildcards or group or account.  Terminated by          00590000
         a blank!                                                       00592000
         May not be omitted.                                            00594000
                                                                        00596000
      PSTD:  byte pointer, will hold standard form title.  As           00598000
         such, must hold at least MAX'STD'LEN characters!               00600000
         This will be filled with zeroes at start of routine.           00602000
         May not be omitted.                                            00604000
                                                                        00606000
      ERROR: integer, call by reference.                                00608000
         This is initialized to zero at entry.                          00610000
         May not be omitted.                                            00612000
                                                                        00614000
      CHAR'INX: integer, call by reference.                             00616000
         In the event of an error, this is the index of the             00618000
         offending character in PDIS.                                   00620000
         In the event of a successful conversion, this is the           00622000
         index of the first character AFTER the file title,             00624000
         presumably the blank that trails it.  It therefore             00626000
         is equivalent to the length of the display form title.         00628000
         May not be omitted.                                            00630000
                                                                        00632000
      DELIMS: byte pointer, call by value.                              00634000
         Contains a sequence of characters that are valid to            00636000
         terminate a file title with.  DELIMS (0) is the count of       00638000
         the number of valid delimiters.  Thus, to allow a file title   00640000
         to be delimited by blank, comma, semicolon, or minus, one      00642000
         would use:  MOVE DELIMS:=(%4, " ,;-");   or                    00644000
         (%4, "-; ,").                                                  00646000
         Note: this cannot be used to prevent letters/digits/wildcards  00648000
         from being part of a title!                                    00650000
         Defaults to:   (%4, "-; ,").                                   00652000
                                                                        00654000
   Result:                                                              00656000
      FAILED if an error occurs,                                        00658000
      GOOD if no error.   (GOOD <==> NOT FAILED)                        00660000
   -----------------------------------------------------------          00662000
                                                                        00664000
   Standard form file title layout:                                     00666000
                                                                        00668000
   Byte array:           #Bytes  Byte index    Define to access:        00670000
                                             (using byte pointer        00672000
      +------------------+                    PSTD)                     00674000
      ! total length     !    2     0             STD'LEN'TOTAL         00676000
      ! (self inclusive) !                                              00678000
      !(NOTE: 2 bytes!)  !                                              00680000
      +------------------+                                              00682000
      ! standard-form    !    1     2             STD'VERSION           00684000
      ! version          !                                              00686000
      ! (usually = 1)    !                                              00688000
      +------------------+                                              00690000
      ! information byte !    1     3             STD'INFO              00692000
      ! bits: (8..15)    !                                              00694000
      ! 8 = r e s e r v e!  \                                           00696000
      ! 9 = r e s e r v e!   \                                          00698000
      !10 = r e s e r v e!    >   set to 0.                             00700000
      !11 = r e s e r v e!   /                                          00702000
      !12 = r e s e r v e!  /                                           00704000
      !13 = backreference!                        STD'BACK              00706000
      !14 = dollar       !                        STD'DOLLAR            00708000
      !15 = wildcards    !                        STD'WILD              00710000
      +------------------+                                              00712000
      !index of file part!    1     4             STD'FILE'INX          00714000
      ! in this array    !                                              00716000
      !(if zero, part was!                                              00718000
      !not found)        !                                              00720000
      +------------------+                                              00722000
      !index of lockword !    1     5             STD'LOCK'INX          00724000
      !part in this array!                                              00726000
      +------------------+                                              00728000
      !index of group    !    1     6             STD'GROUP'INX         00730000
      !part in this array!                                              00732000
      +------------------+                                              00734000
      !index of acct part!    1     7             STD'ACCT'INX          00736000
      !in this array     !                                              00738000
      +------------------+                                              00740000
      !reserved, := 0    !    1     8             STD'HOST'INX          00742000
      !  (host name)     !                                              00744000
      +------------------+                                              00746000
      !reserved, := 0    !    1     9             STD'PV'INX            00748000
      !(private volume   !                                              00750000
      ! (family) name    !                                              00752000
      +------------------+                                              00754000
              ...                                                       00756000
      +------------------+                                              00758000
      ~ dont count on the~                                              00760000
      ~ next part being  ~                                              00762000
      ~ right after the  ~                                              00764000
      ~ above info!!!!   ~                                              00766000
      +------------------+                                              00768000
              ...                                                       00770000
      +------------------+                                              00772000
      ! reserved, := 1   !    1     STD'FILE'INX-1                      00774000
      ! (number of parts !                        STD'FILE'PARTS        00776000
      ! in file name)    !                                              00778000
      +------------------+                                              00780000
      !file part info:   !    1     STD'FILE'INX  STD'FILE'INFO         00782000
      !bit 8 = wildcards !                        STD'FILE'WILD         00784000
      !bit 9..15= length !                        STD'FILE'LEN          00786000
      +------------------+                                              00788000
      !file part text... !    0..8  STD'FILE'INX+1                      00790000
      !up to 8 characters!                        STD'FILE'             00792000
      !in length, no fill!                                              00794000
      !characters at end.!                                              00796000
      +------------------+                                              00798000
              ...                                                       00800000
      +------------------+                                              00802000
      ! (second, third...!    0..???                                    00804000
      ! 'nth' file parts !                                              00806000
      ! will follow this !                                              00808000
      ! someday).        !                                              00810000
      +------------------+                                              00812000
              ...                                                       00814000
      +------------------+                                              00816000
      !lock part info:   !    1     STD'LOCK'INX  STD'LOCK'INFO         00818000
      !bit 8 = wildcards !                        STD'LOCK'WILD         00820000
      !bit 9..15= length !                        STD'LOCK'LEN          00822000
      +------------------+                                              00824000
      !lock part text... !    0..8  STD'LOCK'INX+1                      00826000
      !up to 8 characters!                        STD'LOCK'             00828000
      !in length, no fill!                                              00830000
      !characters at end.!                                              00832000
      +------------------+                                              00834000
              ...                                                       00836000
      +------------------+                                              00838000
      !group part info:  !    1     STD'GROUP'INX STD'GROUP'INFO        00840000
      !bit 8 = wildcards !                        STD'GROUP'WILD        00842000
      !bit 9..15= length !                        STD'GROUP'LEN         00844000
      +------------------+                                              00846000
      !group part text...!    0..8  STD'GROUP'INX+1                     00848000
      !up to 8 characters!                        STD'GROUP'            00850000
      !in length, no fill!                                              00852000
      !characters at end.!                                              00854000
      +------------------+                                              00856000
              ...                                                       00858000
      +------------------+                                              00860000
      !acct part info:   !    1     STD'ACCT'INX  STD'ACCT'INFO         00862000
      !bit 8 = wildcards !                        STD'ACCT'WILD         00864000
      !bit 9..15= length !                        STD'ACCT'LEN          00866000
      +------------------+                                              00868000
      !acct part text... !    0..8  STD'ACCT'INX+1                      00870000
      !up to 8 characters!                        STD'ACCT'             00872000
      !in length, no fill!                                              00874000
      !characters at end.!                                              00876000
      +------------------+                                              00878000
              ...                                                       00880000
      ~~~~~~~~~~~~~~~~~~~~                                              00882000
      ~ The following    ~                                              00884000
      ~ two parts are not~                                              00886000
      ~ yet implemented, ~                                              00888000
      ~ but have been    ~                                              00890000
      ~ defined to allow ~                                              00892000
      ~later enhancements~                                              00894000
      ~~~~~~~~~~~~~~~~~~~~                                              00896000
              ...                                                       00898000
      +------------------+                                              00900000
      !family part info: !    1     STD'FAMILY'INX STD'FAMILY'INFO      00902000
      !bit 8 = wildcards !                        STD'FAMILY'WILD       00904000
      !bit 9..15= length !                        STD'FAMILY'LEN        00906000
      +------------------+                                              00908000
      !family part text..!    0..8  STD'FAMILY'INX+1                    00910000
      !up to 8 characters!                        STD'FAMILY'           00912000
      !in length, no fill!                                              00914000
      !characters at end.!                                              00916000
      +------------------+                                              00918000
              ...                                                       00920000
      +------------------+                                              00922000
      !host part info:   !    1     STD'HOST'INX  STD'HOST'INFO         00924000
      !bit 8 = wildcards !                        STD'HOST'WILD         00926000
      !bit 9..15= length !                        STD'HOST'LEN          00928000
      +------------------+                                              00930000
      !host part text... !    0..8  STD'HOST'INX+1                      00932000
      !up to 8 characters!                        STD'HOST'             00934000
      !in length, no fill!                                              00936000
      !characters at end.!                                              00938000
      +------------------+                                              00940000
                                                                        00942000
   ----------------------------------------------------------->>        00944000
   BEGIN                                                                00946000
                                                                        00948000
   LABEL                                                                00950000
      XIT;                                                              00952000
                                                                        00954000
   BYTE ARRAY                                                           00956000
      DEFAULT'DELIMS (0:4);                                             00958000
                                                                        00960000
   LOGICAL                                                              00962000
      BITMASK     = Q - 4,                                              00964000
      CHAR'TYPE   := FALSE,                                             00966000
      DIGIT       := FALSE,                                             00968000
      DONE        := FALSE,                                             00970000
      LETTER      := FALSE,                                             00972000
      WILD        := FALSE,                                             00974000
      WILD'PART   := FALSE;                                             00976000
                                                                        00978000
   INTEGER                                                              00980000
      DELIM'INX   := 0,   <<used to index through DELIMS>>              00982000
      PART'INX    := 0,   <<index of info for current part>>            00984000
      PART'LEN    := 0,   <<length of current part>>                    00986000
      STATE       := 0,   <<0, 1, 2, 3: file, lock, group, acct>>       00988000
      TOTAL'LEN   := 0;   <<cumulative length of std title thus far>>   00990000
                                                                        00992000
   BYTE                                                                 00994000
      CHAR;                                                             00996000
                                                                        00998000
   DEFINE                                                               01000000
      STATE'FILE  = 0 #,                                                01002000
      STATE'LOCK  = 1 #,                                                01004000
      STATE'GROUP = 2 #,                                                01006000
      STATE'ACCT  = 3 #;                                                01008000
                                                                        01010000
   <<---------------------->>                                           01012000
   SUBROUTINE ERR (N); VALUE N; INTEGER N;                              01014000
      BEGIN                                                             01016000
                                                                        01018000
      ERROR:= N;                                                        01020000
      DISPLAY'TO'STANDARD:=FAILED;                                      01022000
      GO XIT;                                                           01024000
                                                                        01026000
      END <<ERR SUB>>;                                                  01028000
   <<--------------------->>                                            01030000
   SUBROUTINE APPEND'CHAR;                                              01032000
      BEGIN                                                             01034000
                                                                        01036000
      TOTAL'LEN:=TOTAL'LEN+1;                                           01038000
      IF (PART'LEN:=PART'LEN+1) > 8 THEN                                01040000
         ERR (SE'PART'TOO'LONG);       <<part too long>>                01042000
                                                                        01044000
      PSTD(TOTAL'LEN):=CHAR;                                            01046000
                                                                        01048000
      END <<APPEND'CHAR SUB>>;                                          01050000
   <<------------------------->>                                        01052000
   LOGICAL SUBROUTINE CHECK'DELIM (CHAR); VALUE CHAR; BYTE CHAR;        01054000
      BEGIN                                                             01056000
                                                                        01058000
      DELIM'INX:=DELIMS(0)+1;                                           01060000
                                                                        01062000
      WHILE (DELIM'INX:=DELIM'INX-1) > 0 DO                             01064000
         IF DELIMS(DELIM'INX) = CHAR THEN                               01066000
            BEGIN                                                       01068000
            CHECK'DELIM:=GOOD;                                          01070000
            RETURN;                                                     01072000
            END;                                                        01074000
                                                                        01076000
      CHECK'DELIM:=FAILED;                                              01078000
                                                                        01080000
      END <<CHECK'DELIM SUB>>;                                          01082000
   <<------------------------>>                                         01084000
   SUBROUTINE CLASSIFY'CHAR;                                            01086000
      BEGIN                                                             01088000
                                                                        01090000
            <<classify the character...>>                               01092000
                                                                        01094000
      WILD:=DIGIT:=LETTER:=FALSE;                                       01096000
                                                                        01098000
      IF CHAR="@" OR CHAR="?" OR CHAR="#" THEN                          01100000
         WILD:=TRUE                    <<wildcard>>                     01102000
      ELSE IF %60 <= INTEGER(CHAR) <= %71 THEN                          01104000
         DIGIT:=TRUE                   <<digit from 0..9>>              01106000
      ELSE IF %101 <= INTEGER(CHAR) <= %132 THEN                        01108000
         LETTER:=TRUE                  <<uppercase A..Z>>               01110000
      ELSE IF %141 <= INTEGER(CHAR) <= %172 THEN                        01112000
         BEGIN                                                          01114000
         LETTER:=TRUE;                 <<lowercase a..z>>               01116000
            <<upcase it...>>                                            01118000
         CHAR:=(CHAR-"a")+"A";                                          01120000
         END;                                                           01122000
                                                                        01124000
      END <<CLASSIFY'CHAR SUB>>;                                        01126000
   <<--------------------->>                                            01128000
   SUBROUTINE CLOSE'PART;                                               01130000
      BEGIN                                                             01132000
                                                                        01134000
      IF PART'LEN = 0 THEN                                              01136000
         ERR (SE'ZERO'PART);           <<zero length part>>             01138000
                                                                        01140000
      CASE STATE OF                                                     01142000
         BEGIN                                                          01144000
                                                                        01146000
         <<STATE'FILE:>>                                                01148000
            BEGIN                                                       01150000
            STD'FILE'WILD:=WILD'PART;                                   01152000
            STD'FILE'LEN:=PART'LEN;                                     01154000
            END;                                                        01156000
                                                                        01158000
         <<STATE'LOCK:>>                                                01160000
            BEGIN                                                       01162000
            STD'LOCK'WILD:=WILD'PART;                                   01164000
            STD'LOCK'LEN:=PART'LEN;                                     01166000
            END;                                                        01168000
                                                                        01170000
         <<STATE'GROUP:>>                                               01172000
            BEGIN                                                       01174000
            STD'GROUP'WILD:=WILD'PART;                                  01176000
            STD'GROUP'LEN:=PART'LEN;                                    01178000
            END;                                                        01180000
                                                                        01182000
         <<STATE'ACCT:>>                                                01184000
            BEGIN                                                       01186000
            STD'ACCT'WILD:=WILD'PART;                                   01188000
            STD'ACCT'LEN:=PART'LEN;                                     01190000
            END                                                         01192000
         END;                                                           01194000
                                                                        01196000
      END <<CLOSE'PART SUB>>;                                           01198000
   <<--------------------->>                                            01200000
   SUBROUTINE LOOK'AT'CHAR;                                             01202000
      BEGIN                                                             01204000
                                                                        01206000
      IF WILD THEN                                                      01208000
         BEGIN                         <<wildcard found>>               01210000
         WILD'PART:=TRUE;                                               01212000
         STD'WILD:=TRUE;                                                01214000
         IF LOGICAL(STD'DOLLAR) OR LOGICAL(STD'BACK) THEN               01216000
            ERR (SE'WILD'D'OR'B);      <<wild and either $ or *>>       01218000
         IF PART'LEN=0 AND CHAR="#" THEN                                01220000
            ERR (SE'FIRST'IS'DIGIT);   <<first char cant be digit>>     01222000
         END                                                            01224000
                                                                        01226000
      ELSE IF PART'LEN=0 AND DIGIT THEN                                 01228000
         ERR (SE'FIRST'IS'DIGIT);      <<first char cant be digit>>     01230000
                                                                        01232000
      APPEND'CHAR;                                                      01234000
                                                                        01236000
      END <<LOOK'AT'CHAR SUB>>;                                         01238000
   <<--------------------->>                                            01240000
   SUBROUTINE START'PART;                                               01242000
      BEGIN                                                             01244000
                                                                        01246000
      PART'INX:= (TOTAL'LEN:=TOTAL'LEN+1);                              01248000
                                                                        01250000
      CASE STATE OF                                                     01252000
         BEGIN                                                          01254000
                                                                        01256000
         <<STATE'FILE:>>                                                01258000
            BEGIN                                                       01260000
            PSTD(PART'INX):=1;                                          01262000
            PART'INX:= (TOTAL'LEN:=TOTAL'LEN+1);                        01264000
            STD'FILE'INX:=PART'INX;                                     01266000
            END;                                                        01268000
                                                                        01270000
         <<STATE'LOCK:>>                                                01272000
            STD'LOCK'INX:=PART'INX;                                     01274000
                                                                        01276000
         <<STATE'GROUP:>>                                               01278000
            STD'GROUP'INX:=PART'INX;                                    01280000
                                                                        01282000
         <<STATE'ACCT:>>                                                01284000
            STD'ACCT'INX:=PART'INX;                                     01286000
                                                                        01288000
         END;                                                           01290000
                                                                        01292000
      WILD'PART:=FALSE;                                                 01294000
      PART'LEN:=0;                                                      01296000
                                                                        01298000
      END <<START'PART SUB>>;                                           01300000
   <<--------------------->>                                            01302000
                                                                        01304000
   IF BITMASK.(11:4) <> %17 THEN                                        01306000
      ERR (SE'MISSING'PARAMETERS);                                      01308000
                                                                        01310000
   IF NOT BITMASK.(15:1) THEN                                           01312000
      BEGIN                                                             01314000
      @DELIMS:=@DEFAULT'DELIMS;                                         01316000
      MOVE DELIMS:=(%4, " ,;-");                                        01318000
      END;                                                              01320000
                                                                        01322000
   DISPLAY'TO'STANDARD:=GOOD;                                           01324000
                                                                        01326000
   ERROR:=0;                                                            01328000
                                                                        01330000
   PSTD(0):=0;                                                          01332000
   MOVE PSTD(1):=PSTD(0),(MAX'STD'LEN-1);                               01334000
   STD'VERSION:=1;            <<this is version 1 of std form>>         01336000
   TOTAL'LEN:=10-1;           <<first available index-1>>               01338000
                                                                        01340000
   STATE:=STATE'FILE;                                                   01342000
   START'PART;                                                          01344000
                                                                        01346000
   CHAR'INX:=0;                                                         01348000
   DONE:=FALSE;                                                         01350000
                                                                        01352000
   WHILE NOT DONE DO                                                    01354000
      BEGIN                                                             01356000
                                                                        01358000
            <<classify the character...>>                               01360000
                                                                        01362000
      CHAR:=PDIS(CHAR'INX);                                             01364000
      CLASSIFY'CHAR;                                                    01366000
                                                                        01368000
            <<look at the character...>>                                01370000
                                                                        01372000
      IF WILD OR LETTER OR DIGIT THEN                                   01374000
         LOOK'AT'CHAR                                                   01376000
                                                                        01378000
      ELSE IF CHAR = "." OR CHAR = "/" THEN                             01380000
         BEGIN                                                          01382000
         CLOSE'PART;                   <<close off current part>>       01384000
         IF CHAR = "/" THEN                                             01386000
            IF STATE <> STATE'FILE THEN                                 01388000
               ERR (SE'LOCKWORD'LOC)   <<bad place for lockword>>       01390000
            ELSE                                                        01392000
               STATE:=STATE'LOCK                                        01394000
         ELSE IF STATE = STATE'FILE THEN                                01396000
            STATE:=STATE'GROUP         <<dot moves from file->group>>   01398000
         ELSE IF STATE = STATE'LOCK THEN                                01400000
            STATE:=STATE'GROUP         <<dot moves from lock->group>>   01402000
         ELSE IF STATE = STATE'GROUP THEN                               01404000
            STATE:=STATE'ACCT          <<dot moves from group->acct>>   01406000
         ELSE                                                           01408000
            ERR (SE'TOO'MANY'PERIODS); <<too many periods>>             01410000
         START'PART;                   <<setup next part>>              01412000
         END                                                            01414000
                                                                        01416000
      ELSE IF CHAR = "*" THEN                                           01418000
         BEGIN                                                          01420000
         STD'BACK:=TRUE;                                                01422000
         IF STATE <> STATE'FILE OR PART'LEN <> 0 THEN                   01424000
            ERR (SE'STAR'NOT'FIRST);   <<"*" must be first character>>  01426000
         IF LOGICAL(STD'DOLLAR) THEN                                    01428000
            ERR (SE'STAR'AND'DOLLAR);  <<dollar and backref true>>      01430000
         END                                                            01432000
                                                                        01434000
      ELSE IF CHAR = "$" THEN                                           01436000
         BEGIN                                                          01438000
         STD'DOLLAR:=TRUE;                                              01440000
         IF STATE <> STATE'FILE OR PART'LEN <> 0 THEN                   01442000
            ERR (SE'DOLLAR'NOT'FIRST); <<"$" must be first character>>  01444000
         IF LOGICAL(STD'BACK) THEN                                      01446000
            ERR (SE'STAR'AND'DOLLAR);  <<dollar and backref bad>>       01448000
         END                                                            01450000
                                                                        01452000
      ELSE IF CHECK'DELIM (CHAR) = GOOD THEN                            01454000
         DONE:=TRUE                                                     01456000
                                                                        01458000
      ELSE                                                              01460000
         ERR (SE'ILLEGAL'CHARACTER);   <<invalid title character>>      01462000
                                                                        01464000
      IF NOT DONE THEN                                                  01466000
         CHAR'INX:=CHAR'INX+1;                                          01468000
                                                                        01470000
      END;                                                              01472000
                                                                        01474000
   CLOSE'PART;                                                          01476000
                                                                        01478000
   TOTAL'LEN:=TOTAL'LEN+1;                                              01480000
   PSTD(0):=TOTAL'LEN.(0:8);                                            01482000
   PSTD(1):=TOTAL'LEN.(8:8);                                            01484000
                                                                        01486000
XIT:                                                                    01488000
                                                                        01490000
   END <<DISPLAY'TO'STANDARD PROC>>;                                    01492000
$PAGE "STANDARD'TO'DISPLAY"                                             01494000
<<************************************************************>>        01496000
LOGICAL PROCEDURE STANDARD'TO'DISPLAY (PSTD, PDIS, ERROR, LEN);         01498000
            VALUE PSTD, PDIS;                                           01500000
            INTEGER ERROR, LEN;                                         01502000
            BYTE POINTER PSTD, PDIS;                                    01504000
   BEGIN                                                                01506000
   INTEGER                                                              01508000
      PART'LEN;                                                         01510000
   LABEL                                                                01512000
      XIT;                                                              01514000
   <<------------------>>                                               01516000
   SUBROUTINE ERR (N); VALUE N; INTEGER N;                              01518000
      BEGIN                                                             01520000
                                                                        01522000
      ERROR:=N;                                                         01524000
      STANDARD'TO'DISPLAY:=FAILED;                                      01526000
      GO XIT;                                                           01528000
                                                                        01530000
      END <<ERR SUB>>;                                                  01532000
   <<------------------->>                                              01534000
   SUBROUTINE APPEND'CHAR (CHAR); VALUE CHAR; BYTE CHAR;                01536000
      BEGIN                                                             01538000
                                                                        01540000
      PDIS(LEN):=CHAR;                                                  01542000
      LEN:=LEN+1;                                                       01544000
      IF LEN > MAX'TITLE'LEN THEN                                       01546000
         ERR (DE'STANDARD'TOO'LONG);                                    01548000
                                                                        01550000
      END <<APPEND'CHAR SUB>>;                                          01552000
   <<------------------>>                                               01554000
   SUBROUTINE APPEND'PART (CHAR, INX); VALUE CHAR, INX;                 01556000
            BYTE CHAR;                                                  01558000
            INTEGER INX;                                                01560000
      BEGIN                                                             01562000
                                                                        01564000
      IF CHAR <> " " THEN                                               01566000
         APPEND'CHAR (CHAR);                                            01568000
                                                                        01570000
      PART'LEN:=PSTD(INX).STD'PART'LENf;                                01572000
      WHILE PART'LEN > 0 DO                                             01574000
         BEGIN                                                          01576000
         INX:=INX+1;                                                    01578000
         PART'LEN:=PART'LEN-1;                                          01580000
         APPEND'CHAR (PSTD(INX));                                       01582000
         END;                                                           01584000
                                                                        01586000
      END <<APPEND'PART SUB>>;                                          01588000
   <<---------------------->>                                           01590000
                                                                        01592000
   ERROR:=0;                                                            01594000
                                                                        01596000
   LEN:=0;                                                              01598000
                                                                        01600000
   IF LOGICAL(STD'BACK) THEN                                            01602000
      APPEND'CHAR ("*")                                                 01604000
   ELSE IF LOGICAL(STD'DOLLAR) THEN                                     01606000
      APPEND'CHAR ("$");                                                01608000
                                                                        01610000
   IF STD'FILE'INX = 0 THEN                                             01612000
      ERR (DE'STANDARD'EMPTY)                                           01614000
   ELSE                                                                 01616000
      APPEND'PART (" ", STD'FILE'INX);                                  01618000
                                                                        01620000
   IF STD'LOCK'INX > 0 THEN                                             01622000
      APPEND'PART ("/", STD'LOCK'INX);                                  01624000
                                                                        01626000
   IF STD'GROUP'INX > 0 THEN                                            01628000
      APPEND'PART (".", STD'GROUP'INX);                                 01630000
                                                                        01632000
   IF STD'ACCT'INX > 0 THEN                                             01634000
      APPEND'PART (".", STD'ACCT'INX);                                  01636000
                                                                        01638000
   APPEND'CHAR (" ");                                                   01640000
   LEN:=LEN-1;                <<dont count trailing blank>>             01642000
                                                                        01644000
   STANDARD'TO'DISPLAY := GOOD;                                         01646000
                                                                        01648000
XIT:                                                                    01650000
                                                                        01652000
   END <<STANDARD'TO'DISPLAY PROC>>;                                    01654000
<<***************************************************************>>     01656000
LOGICAL PROCEDURE SUB'MATCH (PTEXT, ACTUALLEN, PATTERN, STARTPART);     01658000
         VALUE PTEXT, ACTUALLEN, STARTPART;                             01660000
         INTEGER ACTUALLEN, STARTPART;                                  01662000
         BYTE POINTER PTEXT;                                            01664000
         INTEGER ARRAY PATTERN;                                         01666000
         OPTION FORWARD;                                                01668000
$PAGE"PATTERN'BUILD"                                                    01670000
<<***************************************************************>>     01672000
LOGICAL PROCEDURE PATTERN'BUILD (PTEXT, PATTERN, ERROR'CODE);           01674000
         VALUE PTEXT;                                                   01676000
         INTEGER ERROR'CODE;                                            01678000
         BYTE POINTER PTEXT;                                            01680000
         INTEGER ARRAY PATTERN;                                         01682000
      << This routine encodes a "pattern" into a special format for     01684000
        use by the procedure PATTERN'MATCH.  (See the comment in        01686000
        that procedure for the layout of an encoded "pattern".)         01688000
                                                                        01690000
        This assumes PTEXT points to a string of 1 to PAT'MAX'FIRM      01692000
        characters composed of (usually) A..Z, a..z, 0..9, and          01694000
        "#?@".  This string is a "pattern".  PAT'MAX'FIRM is usually    01696000
        8.  The first byte of the text is the length of the text,       01698000
        not self-inclusive.  Thus the text "CAT#" would be represented  01700000
        as:  %4, "C", "A", "T", "#".                                    01702000
                                                                        01704000
        Note: for compatibility with standard-form titles,              01706000
        only the bottom 7 bits of the length are used...thus,           01708000
        a pointer like:   %(2)10000011, "C", "?", "#"                   01710000
        can be passed into PATTERN'BUILD without having to              01712000
        zap the wildcard bit.                                           01714000
                                                                        01716000
        If more than PAT'MAX'PART parts are found in the pattern text,  01718000
        the routine result will be FAILED and ERROR'CODE will be set    01720000
        to PB'ERR'MANY'PARTS.  PAT'MAX'PART is usually 8.               01722000
                                                                        01724000
        If the pattern text contains more than PAT'MAX'FIRM "firm"      01726000
        characters, a FAILED will be returned and ERROR'CODE will be    01728000
        set to PB'ERR'MANY'FIRM.  PAT'MAX'FIRM is usually 8.            01730000
        A "firm" character is any character that matches at least       01732000
        1 character (i.e: any character other than "@" is a "firm"      01734000
        character).                                                     01736000
                                                                        01738000
        If no error is found, GOOD is returned and ERROR'CODE:=0.       01740000
                                                                        01742000
        PATTERN must be at least 9 words long, even though a short      01744000
        pattern wont use all 9 words.  PATTERN is zeroed at the         01746000
        start of the routine.                                           01748000
                                                                        01750000
        Note that the pattern text is NOT shifted to uppercase!         01752000
                                                                  >>    01754000
      <<---------------------------------------------------------->>    01756000
   BEGIN                                                                01758000
                                                                        01760000
   INTEGER                                                              01762000
      I,                                                                01764000
      FIRMCOUNT   := 0,       <<number of "firm" chars seen>>           01766000
      LEN,                                                              01768000
      PART        := 0,       <<number of parts seen>>                  01770000
      TEXTLEFT;                                                         01772000
                                                                        01774000
   BYTE ARRAY                                                           01776000
      TEXT'COPY'  (0:64);     <<holds a copy of PTEXT(1...)>>           01778000
                                                                        01780000
   LABEL                                                                01782000
      END'PATTERN'BUILD;                                                01784000
                                                                        01786000
   <<------------------->>                                              01788000
   SUBROUTINE FAIL (N); VALUE N; INTEGER N;                             01790000
      BEGIN                                                             01792000
      PATTERN'BUILD:=FAILED;                                            01794000
      ERROR'CODE:=N;                                                    01796000
      GO END'PATTERN'BUILD;                                             01798000
      END <<FAIL SUB>>;                                                 01800000
   <<------------------->>                                              01802000
                                                                        01804000
   ERROR'CODE:=0;                                                       01806000
   PATTERN(0):=0;                                                       01808000
   MOVE PATTERN(1):=PATTERN(0),(PAT'MAX'PART);                          01810000
                                                                        01812000
   TEXTLEFT:=INTEGER(PTEXT).(9:7);     <<only use bottom 7 bits>>       01814000
                                                                        01816000
   MOVE TEXT'COPY':=PTEXT(1),(TEXTLEFT), 2;                             01818000
   MOVE *:=0;                          <<append a stopper>>             01820000
   @PTEXT:=@TEXT'COPY';                                                 01822000
                                                                        01824000
   WHILE TEXTLEFT > 0 DO                                                01826000
      BEGIN                                                             01828000
                                                                        01830000
      PART:=PART+1;                                                     01832000
      IF PART > PAT'MAX'PART THEN                                       01834000
         FAIL (PB'ERR'MANY'PARTS);                                      01836000
                                                                        01838000
      IF PTEXT = "?" THEN              <<match any 1 character>>        01840000
         BEGIN                <<count number of contiguous "?"...>>     01842000
         SCAN PTEXT WHILE "?",1;       <<leave pointer>>                01844000
         LEN:=TOS-@PTEXT;              <<number of "?">>                01846000
         PATTERN(PART).PATLENf := LEN;                                  01848000
         PATTERN(PART).PATCHARf:="?";                                   01850000
         PATTERN(PART).PATTYPEf:= ANYONECHARACTERp;                     01852000
         FIRMCOUNT:=FIRMCOUNT+LEN;                                      01854000
         END                                                            01856000
                                                                        01858000
      ELSE IF PTEXT = "#" THEN         <<match digit>>                  01860000
         BEGIN                <<count number of contiguous "#"...>>     01862000
         SCAN PTEXT WHILE "#",1;       <<leave pointer>>                01864000
         LEN:=TOS-@PTEXT;              <<number of "#">>                01866000
         PATTERN(PART).PATLENf := LEN;                                  01868000
         PATTERN(PART).PATCHARf:= "#";                                  01870000
         PATTERN(PART).PATTYPEf:= DIGITONLYp;                           01872000
         FIRMCOUNT:=FIRMCOUNT + LEN;                                    01874000
         END                                                            01876000
                                                                        01878000
      ELSE IF PTEXT = "@" THEN   <<matches any number of characters>>   01880000
         BEGIN                <<count number of contiguous "@"...>>     01882000
         SCAN PTEXT WHILE "@",1;       <<leave pointer>>                01884000
         LEN:=TOS-@PTEXT;              <<number of "?">>                01886000
         PATTERN(PART).PATLENf := LEN;                                  01888000
         PATTERN(PART).PATCHARf:="@";                                   01890000
         PATTERN(PART).PATTYPEf:= ANYCHARACTERSp;                       01892000
         END                                                            01894000
                                                                        01896000
      ELSE                    <<not a pattern match character...>>      01898000
         BEGIN                                                          01900000
         I:=INTEGER(PTEXT);                                             01902000
         SCAN PTEXT WHILE I, 1;                                         01904000
         LEN:=TOS-@PTEXT;                                               01906000
         PATTERN(PART).PATLENf := LEN;                                  01908000
         PATTERN(PART).PATCHARf:= INTEGER(PTEXT);                       01910000
         PATTERN(PART).PATTYPEf:= EXACTp;                               01912000
         FIRMCOUNT:=FIRMCOUNT+LEN;                                      01914000
         END;                                                           01916000
                                                                        01918000
      IF FIRMCOUNT > PAT'MAX'FIRM THEN                                  01920000
         FAIL (PB'ERR'MANY'FIRM);                                       01922000
                                                                        01924000
      @PTEXT:=@PTEXT+LEN;                                               01926000
      TEXTLEFT:=TEXTLEFT-LEN;                                           01928000
      END;                                                              01930000
                                                                        01932000
   PATTERN(0):=PART;          <<remember how many parts in pattern.>>   01934000
                                                                        01936000
   PATTERN'BUILD:=GOOD;                                                 01938000
                                                                        01940000
END'PATTERN'BUILD:                                                      01942000
                                                                        01944000
   END <<PATTERN'BUILD PROC>>;                                          01946000
$PAGE "PATTERN'MATCH"                                                   01948000
<<***************************************************************>>     01950000
LOGICAL PROCEDURE PATTERN'MATCH (PTEXT, PATTERN);                       01952000
         VALUE PTEXT;                                                   01954000
         BYTE POINTER PTEXT;                                            01956000
         INTEGER ARRAY PATTERN;                                         01958000
      <<This routine compares the pattern in PATTERN to the             01960000
        title in PTEXT.  Byte(0) of PTEXT is the text length            01962000
        (0 to PAT'MAX'FIRM (usually 8)).  Only the bottom 7             01964000
        bits of the length are used...this maintains compatibility      01966000
        with standard-form titles, which may use the eighth bit         01968000
        as a wildcard flag.                                             01970000
                                                                        01972000
        If the text in PTEXT matches the pattern in PATTERN,            01974000
        a GOOD is returned, otherwise a FAILED.                         01976000
                                                                        01978000
        The layout of PATTERN is:                                       01980000
            PATTERN (0) = number of parts in the pattern.               01982000
            PATTERN (1..PATTERN(0)) = separate pattern parts.           01984000
        Each pattern part is a single word (16 bits) that looks         01986000
        like:                                                           01988000
              0  1  2    7  8        15                                 01990000
            +------+------+--+--------+                                 01992000
            ! Part ! Part ! Part      !                                 01994000
            ! Type !Length! Character !                                 01996000
            !      !      !           !                                 01998000
            +------+------+-----------+                                 02000000
        Field names:                                                    02002000
             PATTYPEf = (0:2)  PATLENf = (2:6)  PATCHARf = (8:8)        02004000
Char:   Possible types:          Meanings:                              02006000
                                                                        02008000
  ?        ANYONECHARACTERp      Match any sequence of PATLENf          02010000
                                 characters.                            02012000
                                                                        02014000
  @        ANYCHARACTERSp        Match any number of characters.        02016000
                                 PATLENf is disregarded, but happens    02018000
                                 to be the number of contiguous         02020000
                                  "@"'s found in the original           02022000
                                 pattern.                               02024000
                                                                        02026000
  #        DIGITONLYp            Match any sequence of PATLENf          02028000
                                 digits.                                02030000
                                                                        02032000
  A..Z,    EXACTp                Match the exact ASCII character        02034000
  a..z, 0..9, ...                that is found in PATLENf field.        02036000
                                                                        02038000
      A pattern text of:  CA?D#@ would be represented as:               02040000
                                                                        02042000
         6, (EXACTp, 1, "C"), (EXACTp, 1, "A"),                         02044000
            (ANYONECHARACTERp, 1, "?"), (EXACTp, 1, "D"),               02046000
            (DIGITONLYp, 1, "#"), (ANYCHARACTERSp, 1, "@")              02048000
                                                                        02050000
      A pattern text of:  ??@@AA would be represented as:               02052000
                                                                        02054000
         3, (ANYONECHARACTERp, 2, "?"), (ANYCHARACTERSp, 2, "@"),       02056000
            (EXACTp, 2, "A")                                            02058000
                                                                >>      02060000
   <<----------------------------------------------------------->>      02062000
   BEGIN                                                                02064000
                                                                        02066000
   PATTERN'MATCH:=SUB'MATCH (PTEXT(1),                                  02068000
                             INTEGER(PTEXT).(9:7),                      02070000
                             PATTERN, 1);                               02072000
                                                                        02074000
   END <<PATTERN'MATCH PROC>>;                                          02076000
$PAGE "SUB'MATCH"                                                       02078000
<<***************************************************************>>     02080000
LOGICAL PROCEDURE SUB'MATCH (PTEXT, ACTUALLEN, PATTERN, STARTPART);     02082000
         VALUE PTEXT, ACTUALLEN, STARTPART;                             02084000
         INTEGER ACTUALLEN, STARTPART;                                  02086000
         BYTE POINTER PTEXT;                                            02088000
         INTEGER ARRAY PATTERN;                                         02090000
      <<This routine attempts to match the remaining portion            02092000
        of the pattern versus the remaining portion of the              02094000
        original text.  If the match succeeds, GOOD is                  02096000
        returned, otherwise FAILED.                                     02098000
        Note: it is recursive!>>                                        02100000
   BEGIN                                                                02102000
   INTEGER                                                              02104000
      I,                                                                02106000
      LEN,                                                              02108000
      MINLEN,                                                           02110000
      PART,                                                             02112000
      PARTS;                                                            02114000
                                                                        02116000
   SUB'MATCH:=FAILED;                                                   02118000
                                                                        02120000
   MINLEN:=0;                                                           02122000
   PARTS:=PATTERN(0);                                                   02124000
   PART:=STARTPART-1;                                                   02126000
                                                                        02128000
         <<determine minimum length that the rest of the                02130000
           pattern must be...>>                                         02132000
                                                                        02134000
   WHILE (PART:=PART+1) <= PARTS DO                                     02136000
      IF (I:=PATTERN(PART)).PATTYPEf <> ANYCHARACTERSp THEN             02138000
         MINLEN:=MINLEN+I.PATLENf;                                      02140000
                                                                        02142000
         <<see if test string has any possible chance of matching       02144000
           pattern...>>                                                 02146000
                                                                        02148000
   IF MINLEN > ACTUALLEN THEN                                           02150000
      RETURN;                 <<FAILED>>                                02152000
                                                                        02154000
         <<loop thru easy parts, recursing to handle                    02156000
           complex parts ("@")...>>                                     02158000
                                                                        02160000
   PART:=STARTPART-1;                                                   02162000
                                                                        02164000
   WHILE (PART:=PART+1) <= PARTS DO                                     02166000
      BEGIN                                                             02168000
      I:=PATTERN(PART);                                                 02170000
      LEN:=I.PATLENf;         <<length of this part>>                   02172000
                                                                        02174000
      IF (ACTUALLEN < LEN) AND I.PATTYPEf <> ANYCHARACTERSp THEN        02176000
         RETURN;              <<can't possibly match>>                  02178000
                                                                        02180000
      CASE I.PATTYPEf OF                                                02182000
         BEGIN                                                          02184000
                                                                        02186000
         <<ANYONECHARACTERp:>>                                          02188000
            ;                          <<valid match, by definition!>>  02190000
                                                                        02192000
         <<ANYCHARACTERSp:>>                                            02194000
            BEGIN                      <<match from 0 to ACTUALLEN>>    02196000
            IF PART = PARTS THEN                                        02198000
               BEGIN                                                    02200000
               SUB'MATCH:=GOOD;        <<is last part.>>                02202000
               RETURN;                                                  02204000
               END;                                                     02206000
                  <<try matching with 0, 1, ..., ACTUALLEN chars...>>   02208000
            LEN:=ACTUALLEN-MINLEN;                                      02210000
            DO                                                          02212000
               IF SUB'MATCH (PTEXT(LEN), ACTUALLEN-LEN,                 02214000
                             PATTERN, PART+1) = GOOD THEN               02216000
                  BEGIN                                                 02218000
                  SUB'MATCH:=GOOD;     <<it worked!>>                   02220000
                  RETURN;                                               02222000
                  END                                                   02224000
            UNTIL                                                       02226000
               (LEN:=LEN-1) < 0;                                        02228000
            RETURN;                    <<it failed!>>                   02230000
            END;                                                        02232000
                                                                        02234000
         <<DIGITONLYp:>>                                                02236000
            BEGIN                                                       02238000
            WHILE (LEN:=LEN-1) >= 0 DO                                  02240000
               IF PTEXT(LEN) <> NUMERIC THEN                            02242000
                  RETURN;              <<not a digit!>>                 02244000
            LEN:=I.PATLENf;                                             02246000
            END;                                                        02248000
                                                                        02250000
         <<EXACTp:>>                                                    02252000
            BEGIN                                                       02254000
            WHILE (LEN:=LEN-1) >= 0 DO                                  02256000
               IF INTEGER(PTEXT(LEN)) <> I.PATCHARf THEN                02258000
                  RETURN;                 <<mismatched!>>               02260000
            LEN:=I.PATLENf;                                             02262000
            END;                                                        02264000
         END;                                                           02266000
                                                                        02268000
      MINLEN:=MINLEN-LEN;              <<subtract # chars matched>>     02270000
      ACTUALLEN:=ACTUALLEN-LEN;        <<ditto>>                        02272000
      @PTEXT:=@PTEXT(LEN);             <<point to remainder of text>>   02274000
                                                                        02276000
      END;        <<end of while loop>>                                 02278000
                                                                        02280000
   IF ACTUALLEN = 0 THEN                                                02282000
      SUB'MATCH:=GOOD;                 <<matched ok!>>                  02284000
                                                                        02286000
   END <<SUB'MATCH PROC>>;                                              02288000
<<***************************************************************>>     02290000
                                                                        02292000
$PAGE "SAY-SEND ROUTINES"                                               02294000
PROCEDURE AHEM;                                                         02296000
         OPTION UNCALLABLE;                                             02298000
   BEGIN                                                                02300000
   OUTPUTBUFFER(0):="  ";                                               02302000
   MOVE OUTPUTBUFFER(1):=OUTPUTBUFFER(0),(65);                          02304000
   @POUT:=@OUTPUTBUFFER';                                               02306000
   END <<AHEM PROC>>;                                                   02308000
<<**************************************************************>>      02310000
                                                                        02312000
PROCEDURE SAY1 (CHAR); VALUE CHAR; LOGICAL CHAR;                        02314000
         OPTION UNCALLABLE;                                             02316000
   BEGIN                                                                02318000
   IF CHAR.(8:8) = 0 THEN                                               02320000
      CHAR:=CHAR.(0:8);                                                 02322000
   POUT:=CHAR;                                                          02324000
   @POUT:=@POUT+1;                                                      02326000
   END <<SAY1 PROC>>;                                                   02328000
<<***************************************************************>>     02330000
LOGICAL PROCEDURE SEND;                                                 02332000
         OPTION UNCALLABLE;                                             02334000
   BEGIN                                                                02336000
   SEND:=FALSE;                                                         02338000
   PRINT(OUTPUTBUFFER, @OUTPUTBUFFER'-@POUT, 0);                        02340000
   IF <> THEN                                                           02342000
      SEND:=TRUE;                                                       02344000
   AHEM;                                                                02346000
   END <<SEND PROC>>;                                                   02348000
<<***************************************************************>>     02350000
                                                                        02352000
LOGICAL PROCEDURE SENDSTOP;                                             02354000
         OPTION UNCALLABLE;                                             02356000
   BEGIN                                                                02358000
   SENDSTOP:=FALSE;                                                     02360000
   PRINT(OUTPUTBUFFER, @OUTPUTBUFFER'-@POUT, %320);                     02362000
   IF <> THEN                                                           02364000
      SENDSTOP:=TRUE;                                                   02366000
   AHEM;                                                                02368000
   END <<SENDSTOP PROC>>;                                               02370000
<<                                                          >>          02372000
$PAGE "PATTERNMATCH"                                                    02374000
LOGICAL PROCEDURE PATTERNMATCH (CUR'FILE,PAT'FILE);                     02376000
                  VALUE CUR'FILE,PAT'FILE;                              02378000
                  BYTE POINTER CUR'FILE,PAT'FILE;                       02380000
BEGIN                                                                   02382000
                                                                        02384000
 BYTE POINTER                                                           02386000
    PSTD,          << Used for STD'... defines >>                       02388000
    CUR'NAME,      << Pointers to filename field, >>                    02390000
    CUR'GROUP,     << file group field, >>                              02392000
    CUR'ACCT,      << file acct field, >>                               02394000
    PAT'NAME,      << pattern name field, >>                            02396000
    PAT'GROUP,     << pattern group field, >>                           02398000
    PAT'ACCT;      << and pattern acct field. >>                        02400000
                                                                        02402000
 INTEGER ARRAY PATTERN(0:8); << BUILT PATTERN GOES HERE >>              02404000
                                                                        02406000
 INTEGER ERROR'CODE; << USED FOR ERRORS FROM PATTERNBUILD >>            02408000
                                                                        02410000
  PATTERNMATCH := FALSE;                                                02412000
                                                                        02414000
  @PSTD     := @CUR'FILE;    << to use following defines >>             02416000
  @CUR'NAME := @PSTD( STD'FILE'INX );  << Pick off filename >>          02418000
  @CUR'GROUP:= @PSTD( STD'GROUP'INX ); << Pick off file group >>        02420000
  @CUR'ACCT := @PSTD( STD'ACCT'INX );  << Pick off file acct >>         02422000
                                                                        02424000
  @PSTD     := @PAT'FILE;    << Now point to pattern file... >>         02426000
  @PAT'NAME := @PSTD( STD'FILE'INX );  << Pattern name... >>            02428000
  @PAT'GROUP:= @PSTD( STD'GROUP'INX);  << Pattern group... >>           02430000
  @PAT'ACCT := @PSTD( STD'ACCT'INX);   << Pattern acct ...>>            02432000
                                                                        02434000
  PATTERN'BUILD( PAT'NAME, PATTERN , ERROR'CODE);                       02436000
  IF ERROR'CODE <> 0 THEN   << FAILED TO BUILD PATTERN >>               02438000
     BEGIN                                                              02440000
      SAY "ERROR BUILDING PATTERN IN PATTERNMATCH-NAME" ENDSAY;         02442000
      SEND;                                                             02444000
      RETURN;                                                           02446000
     END;                                                               02448000
  IF PATTERN'MATCH( CUR'NAME, PATTERN ) = FAILED THEN RETURN;           02450000
                                                                        02452000
  PATTERN'BUILD( PAT'GROUP, PATTERN, ERROR'CODE );                      02454000
  IF ERROR'CODE <> 0 THEN  << FAILED TO BUILD GROUP PAT >>              02456000
     BEGIN                                                              02458000
      SAY "ERROR BUILDING PATTERN IN PATTERNMATCH-GROUP"ENDSAY;         02460000
      SEND;                                                             02462000
      RETURN;                                                           02464000
     END;                                                               02466000
  IF PATTERN'MATCH( CUR'GROUP, PATTERN) = FAILED THEN RETURN;           02468000
                                                                        02470000
  PATTERN'BUILD( PAT'ACCT, PATTERN, ERROR'CODE );                       02472000
  IF ERROR'CODE <> 0 THEN                                               02474000
     BEGIN                                                              02476000
      SAY "ERROR BUILDING PATTERN IN PATTERNMATCH-ACCT"ENDSAY;          02478000
      SEND;                                                             02480000
      RETURN;                                                           02482000
     END;                                                               02484000
  IF PATTERN'MATCH( CUR'ACCT, PATTERN)  = FAILED THEN RETURN;           02486000
                                                                        02488000
  <<  MADE IT ! >>                                                      02490000
  PATTERNMATCH := TRUE;                                                 02492000
  RETURN;                                                               02494000
END; << PATTERNMATCH >>                                                 02496000
                                                                        02498000
                                                                        02500000
$PAGE "CONTROLY"                                                        02502000
<<**********************************************************>>          02504000
<< CONTROLY is the procedure entered in the event of a user >>          02506000
<< hitting Control Y.  It is a very standard procedure.  It >>          02508000
<< switches the CONTROL'Y'DETECTED flag so that after the   >>          02510000
<< current file is recovered, the user is prompted with the >>          02512000
<< question CONTINUE or ABORT?  Then, Control Y is reset    >>          02514000
<< and we return to the point where the Control Y was hit.  >>          02516000
<< This is done by placing %31400+n on the stack and execu- >>          02518000
<< this instruction, where n is the number of words curr-   >>          02520000
<< ently in the stack plus the stack marker.  The instruc-  >>          02522000
<< tion is an EXIT instuction with paramater n.  For more   >>          02524000
<< information see the INTRINSICS manual under the CONTROL Y>>          02526000
<< section.                                                 >>          02528000
<<**********************************************************>>          02530000
PROCEDURE CONTROLY;                                                     02532000
BEGIN                                                                   02534000
INTEGER SDEC=Q+1;                                                       02536000
CONTROL'Y'DETECTED:=TRUE;                                               02538000
PRINT(CNTRLYMSG,-54,0);                                                 02540000
RESETCONTROL;                                                           02542000
TOS:=EXITN+SDEC;                                                        02544000
ASSEMBLE(XEQ 0);                                                        02546000
END;                                                                    02548000
$PAGE "CHECK'LIST"                                                      02550000
LOGICAL PROCEDURE CHECK'LIST;                                           02552000
 << This procedure chases down the list of filesets entered             02554000
     and tries to convert them to standard form.  If we succeed,        02556000
    "TRUE" is returned, if not, an error message is printed,            02558000
    the user is prompted for more input, and "FALSE" is returned>>      02560000
                                                                        02562000
 BEGIN                                                                  02564000
  LOGICAL EOL:=FALSE;                                                   02566000
  BYTE POINTER PSTD;                                                    02568000
  BYTE ARRAY DELIMS(0:5);                                               02570000
  BYTE POINTER DPTR := @DELIMS;                                         02572000
  MOVE DELIMS := (%4," ,",%15,%0);                                      02574000
  @LIST'PT := @FILE'LIST;    <<point to begin of list>>                 02576000
  @OUT'PT  := @OUT'LIST;     <<point to begin of stnd list>>            02578000
  KOUNT := 0;                                                           02580000
  NUM'STRICT := 0;                                                      02582000
                                                                        02584000
   DO BEGIN                                                             02586000
    SCAN LIST'PT WHILE "  ",1;                                          02588000
    @LIST'PT := TOS;                                                    02590000
    DISPLAY'TO'STANDARD(LIST'PT,OUT'PT,ERROR,CHAR'INX,DPTR);            02592000
                                                                        02594000
    IF ERROR = 0 THEN        <<converted to stnd form o.k.>>            02596000
     BEGIN                                                              02598000
      @PSTD := @OUT'PT;  << To use STD'WILD define >>                   02600000
      IF  STD'WILD = 0  THEN NUM'STRICT := NUM'STRICT + 1               02602000
                    ELSE GOT'WILD   := TRUE;                            02604000
      @OUT'PT := @OUT'PT + MAX'STD'LEN;<<bump stnd list pointer>>       02606000
      KOUNT := KOUNT +1;     <<count the number of filesets entered>>   02608000
       IF KOUNT > MAX'LIST THEN                                         02610000
        BEGIN                                                           02612000
         SAY"EXCESSIVE FILESETS IGNORED.  (10 ACCEPTED)"ENDSAY;         02614000
         SEND;                                                          02616000
         NUM'STRICT := MAX'LIST;                                        02618000
         KOUNT := MAX'LIST;                                             02620000
         CHECK'LIST := TRUE;                                            02622000
         RETURN;                                                        02624000
        END;                                                            02626000
      @LIST'PT := @LIST'PT + CHAR'INX ;                                 02628000
      SCAN LIST'PT WHILE "  ",1;                                        02630000
      @LIST'PT := TOS;                                                  02632000
      IF LIST'PT = "," THEN @LIST'PT := @LIST'PT + 1                    02634000
      ELSE IF LIST'PT =  0  THEN EOL := TRUE                            02636000
           ELSE BEGIN                                                   02638000
                   ERROR := SE'ILLEGAL'CHARACTER;                       02640000
                   GO TO ERRMSG;                                        02642000
                END;                                                    02644000
     END                                                                02646000
    ELSE << error from DISPLAY'TO'STND >>                               02648000
     BEGIN                                                              02650000
ERRMSG: CASE ERROR OF                                                   02652000
       BEGIN                                                            02654000
        << NO CASE 0 >> ;                                               02656000
        SAY "PART TOO LONG" ENDSAY;                                     02658000
        SAY "ZERO LENGTH PART FOUND" ENDSAY;                            02660000
        SAY "FOUND WILDCARD AND EITHER $ OR *" ENDSAY;                  02662000
        SAY "FIRST CHARACTER OF PART MAY NOT BE NUMERIC"ENDSAY;         02664000
        SAY "LOCKWORD MAY ONLY FOLLOW THE FILE PART" ENDSAY;            02666000
        SAY "TOO MANY PERIODS WERE FOUND, MAX IS 2" ENDSAY;             02668000
        SAY "A * WAS FOUND, BUT IT WASN'T THE FIRST CHAR" ENDSAY;       02670000
        SAY "BOTH * AND $ MAY NOT BE SPECIFIED" ENDSAY;                 02672000
        SAY "A $ WAS FOUND, BUT IT WASN'T THE FIRST CHAR" ENDSAY;       02674000
        SAY "AN ILLEGAL CHARACTER WAS FOUND" ENDSAY;                    02676000
        SAY "NEEDED PARAMETERS TO THE PROC WERE MISSING" ENDSAY;        02678000
       END;                                                             02680000
       SAY "..." ENDSAY;                                                02682000
       SEND;                                                            02684000
       LEN := @END'OF'LIST - @LIST'PT + 1 ;<<len of input ignored>>     02686000
       MOVE BUF := LIST'PT,(LEN);                                       02688000
       PRINT (TBUF,-LEN," ");                                           02690000
       MOVE BUF(0) := " ";                                              02692000
       MOVE BUF(1) := BUF,(LEN-1);                                      02694000
       MOVE BUF(CHAR'INX) := "^";                                       02696000
       PRINT (TBUF,-LEN," ");                                           02698000
       MOVE BUF := "REENTER ALL FILESETS";                              02700000
       PRINT (TBUF,-20," ");                                            02702000
       @LIST'PT := @FILE'LIST;      <<back up and try again...>>        02704000
       CHECK'LIST := FALSE;                                             02706000
       RETURN;                                                          02708000
      END;                                                              02710000
     END UNTIL EOL = TRUE OR KOUNT > MAX'LIST;                          02712000
    CHECK'LIST := TRUE;                                                 02714000
    RETURN;                                                             02716000
   END;  <<  CHECK'LIST  >>                                             02718000
<<                                                           >>         02720000
$PAGE "MATCHES'LIST"                                                    02722000
LOGICAL PROCEDURE MATCHES'LIST;                                         02724000
 << This Procedure compares the current filename (from FORMDES)         02726000
    with the list of filesets specified.  If it matches a fileset       02728000
    on the list, "TRUE" is returned and the existing file is not        02730000
    overwritten.                                               >>       02732000
                                                                        02734000
 BEGIN                                                                  02736000
  INTEGER K:= 0;                                                        02738000
  @OUT'PT := @OUT'LIST;           <<point to begin of stnd list>>       02740000
   DO BEGIN                       <<loop for each fileset on list>>     02742000
    IF PATTERNMATCH(FORMDES'STD'PTR,OUT'PT) = TRUE THEN                 02744000
     BEGIN                        <<file was on list...>>               02746000
      MATCHES'LIST := TRUE;       <<return "TRUE">>                     02748000
      RETURN;                                                           02750000
     END;                                                               02752000
    @OUT'PT := @OUT'PT + MAX'STD'LEN;  <<bump list pointer>>            02754000
    K := K + 1;                        <<bump fileset counter>>         02756000
   END UNTIL K = KOUNT;       << loop to next fileset on list >>        02758000
  MATCHES'LIST := FALSE;     <<if we fall through -> no match>>         02760000
  FCONTROL(TNUM,7,LEN);      << SKIP TO EOF >>                          02762000
  RETURN;                                                               02764000
 END;   << MATCHES'LIST >>                                              02766000
<<                                                          >>          02768000
                                                                        02770000
$PAGE "CHANGEJIT"                                                       02772000
<<**********************************************************>>          02774000
<< CHANGEJIT alters the Job Information Table to reflect the>>          02776000
<< Group and Account of the file that we are currently      >>          02778000
<< recovering, obtained from the file label.  It is called  >>          02780000
<< before each file is recovered so that we have all the    >>          02782000
<< capabilities needed to manipulate the file in each Group >>          02784000
<< and Account that we are working with.                    >>          02786000
<<**********************************************************>>          02788000
                                                                        02790000
PROCEDURE CHANGEJIT;                                                    02792000
COMMENT:                                                                02794000
  CHANGES  "ACCOUNT" IN JIT TO WORDS 8-11 OF FLAB                       02796000
;                                                                       02798000
BEGIN  <<CHANGEJIT>>                                                    02800000
                                                                        02802000
  INTEGER POINTER PS0=S-0;                                              02804000
  INTEGER                                                               02806000
     X  := 0,                                                           02808000
     JITDST := 0,                                                       02810000
     A, B, C, D, E, F, G, H;                                            02812000
  INTEGER ARRAY XDB(*)=DB+0;                                            02814000
                                                                        02816000
  LOGICAL PROCEDURE EXCHANGEDB(I);                                      02818000
    VALUE I;                                                            02820000
    INTEGER I;                                                          02822000
    OPTION EXTERNAL;                                                    02824000
                                                                        02826000
  INTRINSIC GETPRIVMODE,GETUSERMODE;                                    02828000
                                                                        02830000
  <<CODE>>                                                              02832000
  A:=FLAB(8);  <<MOVE NEW ACCT NAME TO Q RELATIVE STORAGE>>             02834000
  B:=FLAB(9);                                                           02836000
  C:=FLAB(10);                                                          02838000
  D:=FLAB(11);                                                          02840000
  E:=FLAB(4);  <<MOVE NEW GROUP NAME TO Q RELATIVE STORAGE>>            02842000
  F:=FLAB(5);                                                           02844000
  G:=FLAB(6);                                                           02846000
  H:=FLAB(7);                                                           02848000
  PUSH(DL);  <<OBTAIN JITDST #>>                                        02850000
  XCONTRAP (0, DUMMY);                                                  02852000
                                                                        02854000
  GETPRIVMODE;                                                          02856000
  X:=TOS-PS0(-1).(4:12);                                                02858000
  JITDST:=XDB(X+6).(6:10);                                              02860000
                                                                        02862000
  EXCHANGEDB(JITDST);  <<DB AT JIT NOW>>                                02864000
  XDB(16):=A;  <<PUT NEW ACCT NAME INTO THE JIT >>                      02866000
  XDB(17):=B;                                                           02868000
  XDB(18):=C;                                                           02870000
  XDB(19):=D;                                                           02872000
  XDB(24):=E;                                                           02874000
  XDB(25):=F;                                                           02876000
  XDB(26):=G;                                                           02878000
  XDB(27):=H;                                                           02880000
                                                                        02882000
  EXCHANGEDB(0);  <<DB BACK TO STACK>>                                  02884000
  GETUSERMODE;                                                          02886000
                                                                        02888000
  XCONTRAP (@CONTROLY, DUMMY);                                          02890000
                                                                        02892000
                                                                        02894000
  END;  <<CHANGEJIT>>                                                   02896000
                                                                        02898000
                                                                        02900000
$PAGE "CORRECTLABEL"                                                    02902000
<<**********************************************************>>          02904000
<< Here we correct the file label to the way that it used   >>          02906000
<< to be.  We opened the file and wrote the file in sector  >>          02908000
<< size records.  Now we must restore the new file label    >>          02910000
<< with the old file information.                           >>          02912000
<<**********************************************************>>          02914000
                                                                        02916000
PROCEDURE CORRECTLABEL(LDNUM,LBLADR);                                   02918000
VALUE LDNUM,LBLADR;                                                     02920000
INTEGER LDNUM;                                                          02922000
DOUBLE LBLADR;                                                          02924000
COMMENT:                                                                02926000
  REPLACES WORDS 0-26, 29-34, 36-40, 42-43  OF FLAB AT                  02928000
  "LBLADR" OF LOGICAL DEVICE "FLAB" TO THOSE IN                         02930000
  GLOBAL ARRAY "FLAB". ;                                                02932000
                                                                        02934000
BEGIN  <<CORRECTLABEL>>                                                 02936000
  INTEGER ARRAY TANK(0:127);                                            02938000
  DOUBLE POINTER NEW'EXTENTS;                                           02940000
  INTEGER ARRAY REPL'EXTENTS'I(0:63);                                   02942000
  DOUBLE ARRAY REPL'EXTENTS(*)=REPL'EXTENTS'I;                          02944000
  DOUBLE IOCB;                                                          02946000
  INTEGER ARRAY IOCBL(*)=IOCB;                                          02948000
  INTEGER QM4=Q-4,QM5=Q-5,OFFSET,EXTENT'NUM,NUM'EXTENTS;                02950000
                                                                        02952000
  EQUATE FIRSTEXTENT = 22;                                              02954000
                                                                        02956000
  DOUBLE PROCEDURE ATTACHIO(L,Q,D,A,F,C,P,PP,FF);                       02958000
  VALUE L,Q,D,A,F,C,P,PP,FF;                                            02960000
  INTEGER L,Q,D,A,F,C,P,PP,FF;                                          02962000
  OPTION EXTERNAL;                                                      02964000
                                                                        02966000
  INTRINSIC GETUSERMODE,GETPRIVMODE,PRINT,DASCII;                       02968000
                                                                        02970000
  <<CODE>>                                                              02972000
  @TANK:=@TBLOCK;                                                       02974000
  @NEW'EXTENTS:=@TANK + (FIRSTEXTENT * 2);                              02976000
                                                                        02978000
  GETPRIVMODE;                                                          02980000
                                                                        02982000
    <<******************************************************>>          02984000
    << Next we read the file label into TANK, based on the  >>          02986000
    << LDEV number and file label address obtain from the   >>          02988000
    << GETFILEINFO called with the new file number.         >>          02990000
    <<******************************************************>>          02992000
                                                                        02994000
  IOCB:=ATTACHIO(LDNUM,0,0,@TANK,0,128,QM5.(8:8),QM4,1);  <<RD LABEL>>  02996000
                                                                        02998000
  GETUSERMODE;                                                          03000000
  IF IOCBL.(12:4) <> 1 THEN GO BADLOGIC;                                03002000
                                                                        03004000
    <<******************************************************>>          03006000
    << Here we patch up the file label so that the features >>          03008000
    << are the same as they were in the original file.      >>          03010000
    <<  (1) FLAB 0-26; File, Group, Account, Lockword,      >>          03012000
    <<      Dates and File code.                            >>          03014000
    <<  (2) Store-Restore bits cleared.                     >>          03016000
    <<  (3) FLAB 29-33; User label info and old file limit  >>          03018000
    <<      in records.                                     >>          03020000
    <<  (4) FLAB 36-38; FOPTIONS, old record size and block->>          03022000
    <<      size.  The new file has the correct offset, numb>>          03024000
    <<      of extents and extent sizes, so we don't restore>>          03026000
    <<      these.                                          >>          03028000
    <<  (5) FLAB 42-43; Old end of data pointer with the    >>          03030000
    <<      old record size in effect.                      >>          03032000
    <<  (6) Place new CHECKSUM after changes in FLAB 34.    >>          03034000
    <<******************************************************>>          03036000
                                                                        03038000
  MOVE TANK(0):=FLAB(0),(27);  <<0-26>>                                 03040000
  TANK(28).(0:3) := 0;        <<STORE-RESTORE LOADED BITS OFF>>         03042000
  FILECODE:=FLAB(26);<<PICK UP FILE CODE FOR IMAGE FILES>>              03044000
  MOVE TANK(29):=FLAB(29),(5);  <<29-33>>                               03046000
  MOVE TANK(36):=FLAB(36),(3);  <<36-38>>                               03048000
  MOVE TANK(42):=FLAB(42),(2);   <<42-43>>                              03050000
                                                                        03052000
  <<********************************************************>>          03054000
  << Here we must check the old FLAB to see if it had any   >>          03056000
  << extents missing in the middle.  If it did, then we     >>          03058000
  << create a replacement extent map using the extent map   >>          03060000
  << from the new file and form it as the old FLAB was      >>          03062000
  << formed, inserting missing extents in the same place as >>          03064000
  << the old FLAB with the new extent addresses in place of >>          03066000
  << the old ones. Below is a diagram of the extent maps of >>          03068000
  << the files (EXT 1 starts at 44th word, 22nd. Double).   >>          03070000
  <<                                                        >>          03072000
  << Old original             New              Replacement  >>          03074000
  << --------------      --------------      -------------- >>          03076000
  << | Old EXT 1  |----->|  New EXT 1 |----->| Rep. EXT 1 | >>          03078000
  << |------------|      |------------|      |------------| >>          03080000
  << | 0 (missing)| |--->|  New EXT 2 |---|  | 0 (missing)| >>          03082000
  << |------------| |    |------------|   |  |------------| >>          03084000
  << | Old EXT 3  |-| |->|  New EXT 3 |-| |->| Rep. EXT 3 | >>          03086000
  << |------------|   |  |------------| |    |------------| >>          03088000
  << | 0 (missing)|   |  |     0      | |    | 0 (missing)| >>          03090000
  << |------------|   |  |------------| |    |------------| >>          03092000
  << | Old EXT 5  |---|  |     0      | |--->| Rep. EXT 5 | >>          03094000
  << |------------|      |------------|      |------------| >>          03096000
  << ~            ~      ~            ~      ~            ~ >>          03098000
  <<                                                        >>          03100000
  <<********************************************************>>          03102000
                                                                        03104000
  NUM'EXTENTS:=TANK(%47).(11:5);                                        03106000
  EXTENT'NUM := OFFSET := 0;                                            03108000
  MOVE REPL'EXTENTS'I:=( 64(0) );                                       03110000
  WHILE (EXTENT'NUM+OFFSET <= NUM'EXTENTS) DO                           03112000
    BEGIN                                                               03114000
      IF DFLAB(FIRSTEXTENT+EXTENT'NUM+OFFSET) = 0D                      03116000
         THEN OFFSET := OFFSET +1                                       03118000
      ELSE                                                              03120000
         BEGIN                                                          03122000
          REPL'EXTENTS(EXTENT'NUM+OFFSET) := NEW'EXTENTS(EXTENT'NUM);   03124000
          EXTENT'NUM := EXTENT'NUM +1;                                  03126000
         END;                                                           03128000
    END;                                                                03130000
                                                                        03132000
  IF OFFSET <> 0                                                        03134000
     THEN MOVE TANK(44) := REPL'EXTENTS'I,((NUM'EXTENTS+1)*2);          03136000
                                                                        03138000
  CHECKSUM;                                                             03140000
  TANK(34):=TOS;  <<FILE LABEL CHECK SUM>>                              03142000
  GETPRIVMODE;                                                          03144000
  PUSH (STATUS);                                                        03146000
  TOS.(2:1) := 0;                                                       03148000
  SET (STATUS);                                                         03150000
                                                                        03152000
  <<********************************************************>>          03154000
  << Write the corrected file label back to disc.  Check for>>          03156000
  << error conditions of the write.                         >>          03158000
  <<********************************************************>>          03160000
                                                                        03162000
  IOCB:=ATTACHIO(LDNUM,0,0,@TANK,1,128,QM5.(8:8),QM4,1);  <<WR LABEL>>  03164000
  GETUSERMODE;;                                                         03166000
  IF IOCBL.(12:4) <> 1 THEN                                             03168000
   BEGIN                                                                03170000
    BADLOGIC:                                                           03172000
    MOVE TANK:="ATTACHIO ERROR: IOCB = %              ";                03174000
    DASCII(IOCB,8,TANK(12));                                            03176000
    PRINT(TANK,-36,0);                                                  03178000
    CC:=CCL;                                                            03180000
    RETURN;                                                             03182000
   END;                                                                 03184000
  CC:=CCE;                                                              03186000
END;  <<CORRECTLABEL>>                                                  03188000
                                                                        03190000
$PAGE "DUP'FILE"                                                        03192000
<<**********************************************************>>          03194000
<< Called by OB' if the keep option is on to determine if a >>          03196000
<< file already exists by FOPENing the file as an old disk  >>          03198000
<< file and checking if a file number is returned.          >>          03200000
<<**********************************************************>>          03202000
                                                                        03204000
LOGICAL PROCEDURE DUP'FILE;                                             03206000
BEGIN                                                                   03208000
  INTEGER DUPFNUM;                                                      03210000
  IF (DUPFNUM:=FOPEN(FORMDES,1,,,,,,,,,,,FILECODE))<>0 THEN             03212000
  BEGIN                                                                 03214000
       DUP'FILE:=TRUE;                                                  03216000
       FCLOSE(DUPFNUM,0,0);                                             03218000
       MOVE BUF(27):="DUPLICATE FILE (NOT LOADED)";                     03220000
       FWRITE(FILELIST,TBUF,-54,0);                                     03222000
       FCONTROL(TNUM,7,LEN);  <<SKIP TO EOF>>                           03224000
  END;                                                                  03226000
END;  <<DUP'FILE>>                                                      03228000
$PAGE "OUTER BLOCK"                                                     03230000
<<**************O U T E R  B L O C K************************>>          03232000
                                                                        03234000
<< First we clear the buffer via AHEM, print the title and  >>          03236000
<< save the original account and group that we are currently>>          03238000
<< running under via the WHO intrinsic.  If we are running  >>          03240000
<< interactive, we prompt the user for a list of file sub-  >>          03242000
<< sets that is requested to be  recovered.  We then ask the>>          03244000
<< user if existing copies of files are to be kept, if so,  >>          03246000
<< NOTKEEP becomes FALSE and any existing files are not     >>          03248000
<< purged if encountered on the tape, otherwise, any exist- >>          03250000
<< ing files are purged and replaced with the file in tape. >>          03252000
<<**********************************************************>>          03254000
                                                                        03256000
      AHEM;                                                             03258000
      SAY PTITLE ENDSAY;                                                03260000
      MOVE OUTPUTBUFFER'(VUUFF'COL):=OFFICIAL'VUUFF;                    03262000
      SEND;                                                             03264000
      FILELIST:=FOPEN(LIST,%14,1);<<OPEN FILE FOR LP LISTING>>          03266000
      TOS:=0;                                                           03268000
      WHO(S0,,,,SGROUP,SACOUNT);  << SAVE ORIGINAL ACCOUNT NAME >>      03270000
      IF TOS THEN  <<INTERACTIVE>>                                      03272000
      BEGIN                                                             03274000
MORE:  SAY "ENTER FILESETS TO RECOVER " ENDSAY;                         03276000
       SEND;                                                            03278000
       SAY "TERMINATE LIST WITH A NULL LINE" ENDSAY;                    03280000
       SEND;                                                            03282000
       SAY ">" ENDSAY;                                                  03284000
       SENDSTOP;                                                        03286000
       LEN := READ(TBUF,-80);                                           03288000
       MOVE BUF(LEN) := %15;                                            03290000
       IF BUF = "@.@.@" OR LEN = 0 <<get everything>>                   03292000
        THEN GOT'LIST := FALSE                                          03294000
         ELSE                                                           03296000
          BEGIN                                                         03298000
           SCAN BUF WHILE "  ",1;                                       03300000
           @START := TOS;                                               03302000
           IF START = %15 OR START = "@.@.@"                            03304000
            THEN GOT'LIST := FALSE                                      03306000
            ELSE                               <<get a list>>           03308000
             BEGIN                                                      03310000
             GOT'LIST := TRUE;                                          03312000
             MOVE LIST'PT := BUF,(LEN),2;<<copy input list>>            03314000
             MOVE *       := " ",2;      <<end of list blank>>          03316000
             @LIST'PT := TOS - 1;        <<point to end of list>>       03318000
             @END'OF'LIST := @LIST'PT;                                  03320000
              DO BEGIN                                                  03322000
               MOVE BUF := "MORE? >";                                   03324000
               PRINT (TBUF,-7,%320);                                    03326000
               LEN := READ(TBUF,-80);                                   03328000
               MOVE BUF(LEN) := %15;                                    03330000
               SCAN BUF WHILE "  ",1;                                   03332000
               @START := TOS;                                           03334000
               IF START = %15 THEN LEN := 0;                            03336000
               IF @LIST'PT<>@FILE'LIST THEN MOVE LIST'PT := ",";        03338000
               MOVE LIST'PT(1) := BUF,(LEN),2;<<tack on cont.>>         03340000
               @LIST'PT := TOS ;                                        03342000
              END UNTIL LEN = 0;                                        03344000
            @END'OF'LIST := @LIST'PT(-1);                               03346000
            END'OF'LIST := %0;         << NULL EOL >>                   03348000
                                                                        03350000
            SAY " " ENDSAY;                                             03352000
            SEND;                                                       03354000
            IF GOT'LIST THEN                                            03356000
               IF NOT CHECK'LIST THEN GOTO MORE<<invalid list>>         03358000
                ELSE KEEP'SOME := TRUE;                                 03360000
       END;                                                             03362000
      END;                                                              03364000
                                                                        03366000
      SAY "WISH TO KEEP EXISTING COPIES OF FILES? (Y/N)" ENDSAY;        03368000
      SENDSTOP;                                                         03370000
      LEN := READ(TBUF,-3);                                             03372000
      IF BUF="N" OR BUF="n"  THEN NOTKEEP := TRUE                       03374000
                             ELSE NOTKEEP := FALSE;                     03376000
    END; <<IF TOS THEN BEGIN>>                                          03378000
                                                                        03380000
      <<****************************************************>>          03382000
      << Open the tape file "RECOVTP" and set up shop.      >>          03384000
      <<****************************************************>>          03386000
                                                                        03388000
TP:   TNUM:=FOPEN(TAPE,%200,%400,4096,DEV);                             03390000
      IF < THEN                                                         03392000
      BEGIN                                                             03394000
         MOVE BUF:="FAILURE TO OPEN MAG. TAPE FILE";                    03396000
         PRINT (TBUF,-30,0);                                            03398000
         PRINT'FILE'INFO(TNUM);                                         03400000
         GOTO FINI;                                                     03402000
      END;                                                              03404000
      FCONTROL (TNUM,5,LEN);  <<REWIND TAPE>>                           03406000
      GETPRIVMODE;                                                      03408000
      FCONTROL (STDLIST,14,LEN); <<DISABLE BREAK>>                      03410000
      GETUSERMODE;                                                      03412000
      <<BREAK MUST BE DISABLED BECAUSE RECOVER2 ALTERS THE >>           03414000
      <<JIT AND BREAK WILL LEAVE THE USER IN AN UNDESIRABLE>>           03416000
      <<STATE>>                                                         03418000
      XCONTRAP(@CONTROLY,DUMMY);  <<ARM CONTROL-Y TRAP>>                03420000
      <<THIS GIVES THE USER SOME WAY OF HALTING THE PROGRAM>>           03422000
      <<AFTER HE ACCIDENTLY SAYS "GO".>>                                03424000
$PAGE                                                                   03426000
      <<****************************************************>>          03428000
      << This is the start for each file encountered.  Check>>          03430000
      << for Control Y, ask the user if he wants to abort   >>          03432000
      << or continue if one is encountered , disable breaks >>          03434000
      <<****************************************************>>          03436000
                                                                        03438000
CONT:                                                                   03440000
      IF CONTROL'Y'DETECTED THEN                                        03442000
        DO                                                              03444000
         BEGIN                                                          03446000
          MOVE FLAB(8):=ISACOUNT(0),(4),3;<<REPLACE OLD ACCNT>>         03448000
          MOVE FLAB(4):=ISGROUP(0),(4),3;<<REPLACE OLD GROUP>>          03450000
          CHANGEJIT;                                                    03452000
          GETPRIVMODE;                                                  03454000
          FCONTROL(STDLIST,15,LEN); <<ENABLE BREAK>>                    03456000
          GETUSERMODE;                                                  03458000
          PRINT(CNTRLYMSG2,-39,%320); <<CONTINUE OR ABORT?>>            03460000
          LEN:=READ(TBUF,-3);                                           03462000
          IF BUF="A" OR BUF="a" THEN GOTO DONE;                         03464000
         END                                                            03466000
        UNTIL BUF="C" OR BUF="c";                                       03468000
      CONTROL'Y'DETECTED:=FALSE;                                        03470000
      GETPRIVMODE;                                                      03472000
      FCONTROL(STDLIST,14,LEN);  <<RE-DISABLE BREAK>>                   03474000
      GETUSERMODE;                                                      03476000
                                                                        03478000
      <<****************************************************>>          03480000
      << Read the first block of the file from tape.  Check >>          03482000
      << for EOT. If EOT found, change the JIT back to the  >>          03484000
      << original GROUP and ACCOUNT and finish up via :FINI.>>          03486000
      <<****************************************************>>          03488000
                                                                        03490000
      LEN:=FREAD(TNUM,TBLOCK,4096); << READ THE LABEL BLOCK >>          03492000
      IF  >  THEN    << TEST FOR END OF FILE >>                         03494000
         BEGIN                                                          03496000
NEXT:       MOVE BUF:="IS THERE ANOTHER RECOVERY TAPE (Y/N)? ",3;       03498000
            PRINT(TBUF,-38,%320);                                       03500000
            LEN:=READ(TBUF,-3);                                         03502000
            IF BUF(0)="Y" OR BUF(0)="y" THEN <<TEST FOR ANOTHER TAPE>>  03504000
               BEGIN                                                    03506000
                  FCLOSE(TNUM,0,0); << CLOSE TAPE FILE >>               03508000
                  MOVE BUF:="MOUNT NEXT RECOVERY TAPE",3;               03510000
                  PRINT(TBUF,-24,0);                                    03512000
                  GOTO TP;                                              03514000
               END;                                                     03516000
DONE:      MOVE FLAB(8):=ISACOUNT(0),(4),3; <<REPLACE OLD ACCT>>        03518000
           MOVE FLAB(4):=ISGROUP(0),(4),3;  << REPLACE OLD GROUP >>     03520000
           CHANGEJIT;                                                   03522000
           GETPRIVMODE;                                                 03524000
           FCONTROL (STDLIST,15,LEN); <<RE-ENABLE BREAK>>               03526000
           GETUSERMODE;                                                 03528000
           GOTO FINI;                                                   03530000
         END;                                                           03532000
                                                                        03534000
      IF  <  THEN     << CHECK ERROR STATUS >>                          03536000
         BEGIN                                                          03538000
ERR1:       FCHECK(TNUM,ERRCODE);                                       03540000
            IF ERRCODE=23 THEN GOTO NEXT; <<CHECK FOR EOT >>            03542000
            MOVE BUF:="TAPE READ ERROR - CODE    ",3;                   03544000
            LEN:=ASCII(ERRCODE,10,BUF(23));                             03546000
            FWRITE(FILELIST,TBUF,-26,0);                                03548000
            FCONTROL(TNUM,7,LEN);  <<FORWARD SPACE FILE>>               03550000
            GOTO CONT; <<TRY TO CONTINUE WITH NEXT FILE>>               03552000
         END;                                                           03554000
                                                                        03556000
      <<****************************************************>>          03558000
      << Move file label into array FLAB.  Obtain the       >>          03560000
      << FILE.GROUP.ACCOUNT.                                >>          03562000
      <<****************************************************>>          03564000
                                                                        03566000
      MOVE FLAB:=TBLOCK,(128);  <<MOVE FILE LABEL>>                     03568000
      MOVE TBUF:="  ";         << BLANK OUT BUF >>                      03570000
      MOVE TBUF(1) := TBUF,(35);                                        03572000
      MOVE BUF:=TFLAB,(8); BUF(8):="."; << SAVE F.G.A >>                03574000
      MOVE BUF(9):=TFLAB(8),(8); BUF(17):=".";                          03576000
      MOVE BUF(18):=TFLAB(16),(8);                                      03578000
                                                                        03580000
                                                                        03582000
      A := " ";                                                         03584000
      MOVE A (1) := A ,(35);                                            03586000
      FORMDES(0):=" ";                                                  03588000
      MOVE FORMDES(1):=FORMDES(0),(36);                                 03590000
      MOVE A := TFLAB ,(8);                                             03592000
      MOVE A (9) := TFLAB (8),(8);                                      03594000
      MOVE A (18) := TFLAB (16),(8);                                    03596000
      MOVE A (27) := TFLAB (32),(8);                                    03598000
                                                                        03600000
      <<****************************************************>>          03602000
      <<   Move in formal file designator.  Then insert     >>          03604000
      << lockword if one was specified in the FLAB.         >>          03606000
      <<****************************************************>>          03608000
                                                                        03610000
      MOVE FORMDES := A WHILE AN,1; <<FILE NAME>>                       03612000
      IF A(27) <> " " THEN                                              03614000
      BEGIN                                                             03616000
          MOVE * := "/",2;                                              03618000
          MOVE * := A (27) WHILE AN,1;                                  03620000
      END;                                                              03622000
      MOVE * := ".",2;                                                  03624000
      MOVE * := A (9) WHILE AN,1; <<GROUP NAME>>                        03626000
      MOVE * := ".",2;                                                  03628000
      MOVE * := A (18) WHILE AN,1; <<ACCOUNT NAME>>                     03630000
      MOVE * := " ";                                                    03632000
                                                                        03634000
      DISPLAY'TO'STANDARD(FORMDES'PTR,FORMDES'STD'PTR,ERROR,CHAR'INX);  03636000
$PAGE                                                                   03638000
                                                                        03640000
     <<*****************************************************>>          03642000
     << Here we calculate some very important information   >>          03644000
     << from the file label.                                >>          03646000
     <<  (1) We obtain the total number of extents in the   >>          03648000
     <<      file, including the last extent.               >>          03650000
     <<  (2) Obtain the extent size in sectors              >>          03652000
     <<  (3) Obtain the last extent size in sectors         >>          03654000
     <<  (4) Now, we calculate the number of data sectors in>>          03656000
     <<      the file.  This calculation results from the   >>          03658000
     <<      number of normal sectors times the extent size >>          03660000
     <<      plus the last extent size.  Finally, we MUST   >>          03662000
     <<      subtract the sector offset so we have the exact>>          03664000
     <<      number of data sectors in the file so that the >>          03666000
     <<      file system will calculate the extent sizes of >>          03668000
     <<      the new file exactly as the old file.          >>          03670000
     <<  (5) Next we calculate the number of sectors in a   >>          03672000
     <<      block.                                         >>          03674000
     <<  (6) Sector offset from FLAB to data is one less    >>          03676000
     <<      than the sector offset in the file label.      >>          03678000
     <<  (7) File code in the FLAB.                         >>          03680000
     <<  (8) Number of User Labels possible.                >>          03682000
     <<*****************************************************>>          03684000
                                                                        03686000
                                                                        03688000
      NUMEXT:=FLAB(39).(11:5)+1;                                        03690000
      EXTSIZE:=FLAB(41);                                                03692000
      LASTEXTSIZE:=FLAB(40);                                            03694000
      NUMSECT:=DOUBLE(NUMEXT-1)*DOUBLE(EXTSIZE)+                        03696000
      DOUBLE(LASTEXTSIZE)-DOUBLE( SECT'OFFSET );                        03698000
      <<**>>                                                            03700000
      SPB:=(FLAB(38)+127)/128   ; <<SECTORS PER BLOCK>>                 03702000
      SECTOFF := SECT'OFFSET-1;                                         03704000
      FILECODE:=FLAB(26);                                               03706000
      ULABS := ULABEOF := FLAB (29).(8:8);                              03708000
                                                                        03710000
      IF NOT GOT'WILD THEN                                              03712000
        IF NUM'STRICT = 0 AND KEEP'SOME THEN GOTO DONE; <<ALL DONE>>    03714000
                                                                        03716000
      IF KEEP'SOME THEN                          << on list? >>         03718000
        IF NOT MATCHES'LIST THEN GOTO CONT;                             03720000
                                                                        03722000
      CHANGEJIT;  << CHANGE ACCOUNT NAME IN JOB INFORMATION TABLE (JIT) 03724000
                     TO REFLECT ACCOUNT NAME ON LABEL >>                03726000
                                                                        03728000
      NUM'STRICT := NUM'STRICT - 1;   << Decrement get file counter>>   03730000
      IF KEEPING'FILES THEN                      <<save duplicates?>>   03732000
        IF DUP'FILE THEN GOTO CONT;                                     03734000
                                                                        03736000
                                                                        03738000
$PAGE                                                                   03740000
                                                                        03742000
     <<*****************************************************>>          03744000
     << Now we open the file with the parameters that we    >>          03746000
     << calculated above.  We are copying the file in the   >>          03748000
     << following manner:  We copy the file one sector at a >>          03750000
     << time, with the record size of all files being the   >>          03752000
     << default, 128 words.  This works out since blocks are>>          03754000
     << in multiples of sectors, with any wasted space at   >>          03756000
     << the end of each block. Since our blocking factor is >>          03758000
     << the number of sectors in a block and our record size>>          03760000
     << being one sector, we are recovering the file in the >>          03762000
     << exact block size (in sectors) of the old file. Also,>>          03764000
     << since we give the file size as the number of data   >>          03766000
     << records in the file, the extent sizes are calcualted>>          03768000
     << exactly as they were in the old file.  Then, we can >>          03770000
     << patch up the file label later with the old record   >>          03772000
     << size and block size and the file is allocated the   >>          03774000
     << same as it was before.                              >>          03776000
     <<*****************************************************>>          03778000
                                                                        03780000
      DNUM:=FOPEN (FORMDES,%2000,%101,,,,ULABS,SPB,,                    03782000
                 NUMSECT,NUMEXT,,FILECODE);                             03784000
      IF  <  THEN                                                       03786000
         BEGIN                                                          03788000
            FCHECK(DNUM,ERRCODE);                                       03790000
            MOVE BUF(27):="FOPEN FAILED - CODE    ",3;                  03792000
            LEN:=ASCII(ERRCODE,10,BUF(47));                             03794000
            FWRITE(FILELIST,TBUF,-50,0);                                03796000
            FERRMSG(ERRCODE,OUTPUTBUFFER,LEN);                          03798000
            IF = THEN                       << Print Text >>            03800000
             BEGIN                          << Of Error >>              03802000
              @POUT := @POUT + LEN;         << Message >>               03804000
              SEND;                         << If Possible >>           03806000
             END;                                                       03808000
            FCONTROL(TNUM,7,LEN);  << SKIP TO EOF >>                    03810000
            GOTO CONT;  << CONTINUE PROCESSING >>                       03812000
         END;                                                           03814000
                                                                        03816000
      @TANK:=@TBLOCK+128;                                               03818000
      GO TO FIRSTBLOCK;                                                 03820000
      << READ REST OF RECORDS >>                                        03822000
                                                                        03824000
$PAGE                                                                   03826000
      <<****************************************************>>          03828000
      << Read another block of at most 4096 words.  FREAD   >>          03830000
      << will return the length of the read, 4096 or less,  >>          03832000
      << depending on what remains to be read.  If we have  >>          03834000
      << reached an EOF, obtain the LDEV and file label     >>          03836000
      << address of the file.                               >>          03838000
      <<****************************************************>>          03840000
                                                                        03842000
OK:   @TANK:=@TBLOCK;                                                   03844000
      LEN:=FREAD(TNUM,TBLOCK,4096);                                     03846000
      IF  >  THEN                                                       03848000
EOFL:    BEGIN         << HAVE EOF - FINISHED THIS FILE >>              03850000
            FGETINFO(DNUM,,,,,,LDEV,,,,,,,,,,,,,LABADR);                03852000
            IF  <  THEN                                                 03854000
               BEGIN                                                    03856000
                  MOVE BUF(27):="FGETINFO FAILED",3;                    03858000
                  FWRITE(FILELIST,TBUF,-42,0);                          03860000
               END;                                                     03862000
                                                                        03864000
            <<**********************************************>>          03866000
            << Close the file.  If the FCLOSE failure signi->>          03868000
            << fies duplicate file name (100), check the    >>          03870000
            << "NOTKEEP" option flag.  If the keep option   >>          03872000
            << if off (don't keep existing copies of files),>>          03874000
            << than purge the old file and go to "CLOSED'OK">>          03876000
            << If it is another type of error or the keep   >>          03878000
            << option was on, print error message.          >>          03880000
            <<**********************************************>>          03882000
                                                                        03884000
CLOSE:                                                                  03886000
            FCLOSE(DNUM,1,0);                                           03888000
            IF  <  THEN   << FCLOSE FAILURE >>                          03890000
               BEGIN                                                    03892000
                 FCHECK(DNUM,ERRCODE);                                  03894000
                 IF ERRCODE=100 AND NOTKEEP THEN                        03896000
                    BEGIN                                               03898000
                      MOVE COMMAND'STRING:="PURGE ";                    03900000
                      MOVE COMMAND'STRING(6):=FORMDES(0),(37);          03902000
                      COMMAND'STRING(43):=CR;                           03904000
                      COMMAND(COMMAND'STRING,ERRCODE,PARM);             03906000
                      IF = THEN<<PURGED OK,CLOSE FILE>>                 03908000
                       BEGIN                                            03910000
                         FCLOSE(DNUM,1,0);                              03912000
                         GO TO CLOSED'OK ;                              03914000
                       END                                              03916000
                      ELSE                                              03918000
                       BEGIN                                            03920000
                          IF ERRCODE<0 THEN ERRCODE:=-ERRCODE;          03922000
                          MOVE BUF(27):="PURGE ERROR - CODE    ";       03924000
                          LEN:=ASCII(ERRCODE,10,BUF(46));               03926000
                          FWRITE(FILELIST,TBUF,-49,0);                  03928000
                          GETPRIVMODE;                                  03930000
                          J:=GENMSG(2,ERRCODE,,,,,,,-FILELIST);         03932000
                          GETUSERMODE;                                  03934000
                       END;                                             03936000
                    END                                                 03938000
                 ELSE                                                   03940000
                   BEGIN                                                03942000
                     MOVE BUF(27):="FCLOSE FAILURE - CODE    ",3;       03944000
                     LEN:=ASCII(ERRCODE,10,BUF(49));                    03946000
                     FWRITE(FILELIST,TBUF,-52,0);                       03948000
                     FERRMSG(ERRCODE,OUTPUTBUFFER,LEN);                 03950000
                     FWRITE(FILELIST,OUTPUTBUFFER,-LEN,0);              03952000
                   END;                                                 03954000
                 FCLOSE(DNUM,0,0);  << FREE SPACE >>                    03956000
                 GOTO CONT;                                             03958000
              END;                                                      03960000
                                                                        03962000
            <<**********************************************>>          03964000
            << If the file closed properly, correct the file>>          03966000
            << label via CORRECTLABEL, write out the file   >>          03968000
            << information and CONTinue with the next file. >>          03970000
            <<**********************************************>>          03972000
                                                                        03974000
CLOSED'OK:  MOVE BUF(27):="                ";                           03976000
            LEN:=ASCII(LDEV,10,BUF(27)); << SAVE LDEV " >>              03978000
                                                                        03980000
            LEN:=DASCII(LABADR,8,BUF(30)); << SAVE SECTOR ADDRESS >>    03982000
                                                                        03984000
            CORRECTLABEL(LDEV,LABADR);     << FIX UP LABEL >>           03986000
            IF  <  THEN                                                 03988000
               BEGIN                                                    03990000
                  MOVE BUF(27):="NOT RECOVERED";                        03992000
                  FWRITE(FILELIST,TBUF,-40,0);                          03994000
                  GOTO CONT;                                            03996000
               END;                                                     03998000
                                                                        04000000
    FWRITE(FILELIST,TBUF,-41,0);<< SUCCESSFUL FILE RECOVERY >>          04002000
    GOTO CONT;                                                          04004000
   END;                                                                 04006000
$PAGE                                                                   04008000
                                                                        04010000
     <<*****************************************************>>          04012000
     << For each block read, we write each sector seperately>>          04014000
     << as follows:  First, if this is the first block of   >>          04016000
     << file, for each sector between the FLAB and the data >>          04018000
     << of the file, we will write a User Label until ULABS >>          04020000
     << goes to zero.  SECTOFF will go to zero after the    >>          04022000
     << blocks and/or extents that contain the file label   >>          04024000
     << and User Labels are read and taken care of.  After  >>          04026000
     << that the IF SECTOFF > 0 will always fail.           >>          04028000
     <<*****************************************************>>          04030000
                                                                        04032000
FIRSTBLOCK:  <<FINISH REST OF FILE-LABEL BLOCK>>                        04034000
     LEN:=LEN-(@TANK-@TBLOCK)+128;                                      04036000
     WHILE  SECTOFF > 0 AND (LEN:=LEN-128) > 0 DO                       04038000
     BEGIN                                                              04040000
         IF ULABS > 0 THEN                                              04042000
         BEGIN                                                          04044000
             FWRITELABEL (DNUM,TANK,128,ULABEOF-ULABS);                 04046000
             IF <> THEN                                                 04048000
             IF > THEN GO TO CCGL ELSE GO TO CCLL;                      04050000
             ULABS:=ULABS-1;  <<USER LABELS TO BE WRITTEN>>             04052000
           END;                                                         04054000
          SECTOFF:=SECTOFF-1;                                           04056000
          @TANK:=@TANK+128;                                             04058000
      END;                                                              04060000
                                                                        04062000
    <<******************************************************>>          04064000
    << For all data in the block, we write one sector of    >>          04066000
    << data at a time. Remember that we are using record    >>          04068000
    << sizes of one sector (128 words), therefore the writes>>          04070000
    << work out perfect.  Next, check for a variety of      >>          04072000
    << errors on the write.  When all sectors are finished, >>          04074000
    << LEN goes to zero (LEN is the lenght of the read,     >>          04076000
    << between 1-32 sectors per block), we GOTO OK to read  >>          04078000
    << the next block of data in the file.                  >>          04080000
    <<******************************************************>>          04082000
                                                                        04084000
     WHILE (LEN:=LEN-128) > 0 DO                                        04086000
     BEGIN                                                              04088000
         FWRITE(DNUM,TANK,128,0);  << WRITE THE SECTOR >>               04090000
         IF  >  THEN                                                    04092000
CCGL:                                                                   04094000
         BEGIN                                                          04096000
            MOVE BUF(27):="OUT OF DISC SPACE OR TOO MANY RECS ON TP",3; 04098000
            FWRITE(FILELIST,TBUF,-67,0);                                04100000
            FCONTROL(TNUM,7,LEN); <<FORWARD SPACE FILE>>                04102000
            GOTO EOFL; <<CLOSE AND CONTINUE WITH NEXT FILE>>            04104000
         END;                                                           04106000
         IF  <  THEN                                                    04108000
CCLL:                                                                   04110000
         BEGIN                                                          04112000
            FCHECK(DNUM,ERRCODE);                                       04114000
            MOVE BUF(27):="DISC WRITE FAILURE - CODE    ",3;            04116000
            LEN:=ASCII(ERRCODE,10,BUF(53));                             04118000
            FWRITE(FILELIST,TBUF,-56,0);                                04120000
            FERRMSG(ERRCODE,OUTPUTBUFFER,LEN);                          04122000
            IF = THEN                       << Print Text >>            04124000
             BEGIN                          << Of Error  >>             04126000
              @POUT := @POUT + LEN;         << Message >>               04128000
              SEND;                         << If Possible >>           04130000
             END;                                                       04132000
            FCONTROL(TNUM,7,LEN);  <<FORWARD SPACE FILE>>               04134000
            GOTO EOFL; <<CLOSE AND CONTINUE WITH NEXT FILE>>            04136000
         END;                                                           04138000
         @TANK:=@TANK+128;                                              04140000
     END;                                                               04142000
   GOTO OK;                                                             04144000
                                                                        04146000
FINI: FCLOSE(FILELIST,1,0);                                             04148000
      END.  <<END OF MAIN CODE>>                               <<04323>>04150000
