<< LINES .001/.009 ARE RESERVED FOR SYSTEMS INTEGRATION>>               00000001
$control main=recover5,lines=120,privileged,map,uslinit,code            00012000
! recover5                                                              00014000
! hp32002c mpe source g.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
begin                                                                   00030000
                                                                        00032000
equate vuuff'col = 9;                                                   00034000
$include inclvuf                                                        00036000
                                                                        00038000
equate                                                                  00040000
   fisir               = 37,       ! file integrity sir                 00042000
   max'list            = 10,                                            00044000
   jit'account         = 16,       ! offset into jit of account name    00046000
   jit'logon'group     = 24,       ! offset into jit of logon group name00048000
   exitn               = %31400,   ! exit instruction                   00050000
   cr                  = %15,      ! carrage return                     00052000
   nocrlf              = %320,     ! cctl for no cr line feed.          00054000
   forward'space'file  = 7,        ! fcontrol functions                 00056000
   rewind'unload       = 9,                                             00058000
   disable'break       = 14,                                            00060000
   enable'break        = 15,                                            00062000
   read                = 0,        ! flabio function codes              00064000
   write               = 1,                                             00066000
   cont'size           = 12,       ! size of record for continuation    00068000
   tape'rec'size       = 4096;     ! size of sadutil tape records.      00070000
                                                                        00072000
integer array                                                           00074000
   qarray(*)=q+0,                                                       00076000
   logon'account(0:3),             ! save current group and account     00078000
   logon'group  (0:3),                                                  00080000
   tape'buffer(0:tape'rec'size-1), ! tape read buffer                   00082000
   io'buffer(0:49),                ! used for terminal i/o              00084000
   flab(0:127);                    ! store flab of current file         00086000
                                                                        00088000
double array                                                            00090000
   flabdbl(*) = flab;                                                   00092000
                                                                        00094000
byte array tape'name(0:7)      := "RECOVTP*";                           00096000
byte array list'name(0:7)      := "LIST*";                              00098000
byte array default'device(0:7) := "TAPE*";                              00100000
byte array                                                              00102000
   flab'b (*) = flab;                                                   00104000
                                                                        00106000
byte array                                                              00108000
   io'buffer'b(*)=io'buffer,       ! byte terminal i/o buffer           00110000
   file'name(0:26),                ! store file name for message        00112000
   formdes(0:36),                  ! used for fopen                     00114000
   out'list (0:830),                                                    00116000
   file'list(0:360),                                                    00118000
   stnd'form(0:80);                                                     00120000
                                                                        00122000
byte pointer                                                            00124000
   list'pt            := @file'list,                                    00126000
   out'pt             := @out'list,                                     00128000
   formdes'ptr        := @formdes,                                      00130000
   formdes'std'ptr    := @stnd'form,                                    00132000
   end'of'list        := @file'list,                                    00134000
   start;                                                               00136000
                                                                        00138000
logical                                                                 00140000
   control'y'detected := false,    ! was control-y entered?             00142000
   notkeep            := false,    ! keep existing copies of file?      00144000
   keep'some          := false,    ! have we kept any files yet?        00146000
   got'wild           := false,                                         00148000
   continuation;                   ! does current file span reels?      00150000
                                                                        00152000
define                                                                  00154000
   dbl                 = double#,                                       00156000
   continuation'record = "CONTINUE"#,                                   00158000
   failed              = false#,                                        00160000
   good                = true#,                                         00162000
   no                  = false#,   ! for get'yes'no                     00164000
   yes                 = true#,                                         00166000
   keeping'files       = not notkeep#,                                  00168000
                                                                        00170000
   def'movetodseg =                                                     00172000
      movetodseg (dstn, dstoffset, dbsource, word'count);               00174000
         value   dstn, dstoffset, dbsource, word'count;                 00176000
         logical dstn, dstoffset, dbsource, word'count;                 00178000
      begin                                                             00180000
      x := tos;                                                         00182000
      assemble (mtds 0);                                                00184000
      tos := x;                                                         00186000
      end #;                                                            00188000
                                                                        00190000
integer                                                                 00192000
   x = x,                          ! the x register                     00194000
   s0 = s-0,                       ! top of stack register, don't delete00196000
   len,                            ! general purpose length var         00198000
   error,                          ! general purpose error var          00200000
   jit'dst,                        ! the jit dst number of current job  00202000
   num'strict := 0,                ! strictly # of files, no wild cards.00204000
   char'inx,                                                            00206000
   kount,                                                               00208000
   num'ulabs,                      ! number of user labels yet to write.00210000
   tape'fnum,                      ! tape file number                   00212000
   list'fnum,                      ! file number of "LIST" file         00214000
   stdin'fnum,                     ! $stdin reopen file number          00216000
   disc'fnum,                      ! current disc file number           00218000
   sect'offset'data,               ! number of sectors from flab to data00220000
   dummy;                                                               00222000
$page "DEFINES & EQUATES for pattern routines"                          00224000
!-----------------------------------------------------------------------00226000
!  pattern...a pattern matcher that implements a fairly simple          00228000
!  pattern matching scheme.  it matches a pattern versus a string       00230000
!  of up to 8 characters.  wildcards, and their meanings, are:          00232000
!        @        match from 0 to 8 characters.                         00234000
!        ?        match any single character.                           00236000
!        #        match any single digit (0..9).                        00238000
!                                                                       00240000
!-----------------------------------------------------------------------00242000
                                                                        00244000
define                                                                  00246000
                                                                        00248000
   pat'max'firm      = 8 #,    <<max number of firm chars>>             00250000
   pat'max'part      = 8 #,    <<max number of pattern parts>>          00252000
   patcharf          = (8:8) #,                                         00254000
   patlenf           = (2:6) #,                                         00256000
   pattypef          = (0:2) #;                                         00258000
                                                                        00260000
equate                                                                  00262000
                                                                        00264000
      <<values found in the pattypef field...>>                         00266000
                                                                        00268000
   anyonecharacterp  = 0,     <<a case statement in sub'match >>        00270000
   anycharactersp    = 1,     <<depends                       >>        00272000
   digitonlyp        = 2,     <<        on this               >>        00274000
   exactp            = 3,     <<                ordering!     >>        00276000
                                                                        00278000
      <<pattern'build errors...>>                                       00280000
                                                                        00282000
   pb'err'many'firm  = 1,     <<more than 8 'firm' chars were found>>   00284000
   pb'err'many'parts = 2;     <<more than 8 parts were found>>          00286000
                                                                        00288000
!-----------------------------------------------------------------------00290000
!                                                                       00292000
!  standard'to'display  and  display'to'standard                        00294000
!                                                                       00296000
!-----------------------------------------------------------------------00298000
                                                                        00300000
equate                                                                  00302000
   max'std'len    = ( 10  <<overhead>> <<max len of std-form title>>    00304000
                     + 2 + 8           <<file part>>                    00306000
                     + 1 + 8           <<lock part>>                    00308000
                     + 1 + 8           <<group part>>                   00310000
                     + 1 + 8           <<acct part>>                    00312000
                     + 1 + 8           <<family part>>                  00314000
                     + 1 + 8           <<host part>>                    00316000
                     + 10     ),       <<expansion!>>                   00318000
   max'title'len  = (  1 + 8           <<"*" & file part length>>       00320000
                     + 1 + 8           <</lockword>>                    00322000
                     + 1 + 8           <<.group>>                       00324000
                     + 1 + 8           <<.account>>                     00326000
                     + 1 ),            <<trailing blank>>               00328000
   max'title'len2 = (max'title'len                                      00330000
                     + 1 + 8           <<-file>>                        00332000
                     + 1 + 8           <<.group     ...no lockword!>>   00334000
                     + 1 + 8           <<.account>>                     00336000
                     + 0 );            <<trailing blank added above>>   00338000
                                                                        00340000
!-----------------------------------------------------------------------00342000
define                                                                  00344000
         <<standard form title defines...>>                             00346000
                                                                        00348000
   std'len'total  = istd (00) #, <<integer: length in bytes, inclu>>    00350000
   std'version    = pstd (02) #,       <<std-form version id (=1) >>    00352000
   std'info       = pstd (03) #,       <<info bits:               >>    00354000
   std'back       = std'info.(13:1) #, <<  1 = back referenced    >>    00356000
   std'dollar     = std'info.(14:1) #, <<  1 = dollar sign        >>    00358000
   std'wild       = std'info.(15:1) #, <<  1 = wildcards in title >>    00360000
   std'file'inx   = pstd (04) #,       <<byte index of file part  >>    00362000
   std'lock'inx   = pstd (05) #,       <<byte index of lock part  >>    00364000
   std'group'inx  = pstd (06) #,       <<byte index of group part >>    00366000
   std'acct'inx   = pstd (07) #,       <<byte index of acct part  >>    00368000
   std'family'inx = pstd (08) #,       <<byte index of family part>>    00370000
   std'host'inx   = pstd (09) #,       <<byte index of host part  >>    00372000
                                                                        00374000
   std'file'parts = pstd (std'file'inx-1)#,  <<# file parts  (:=1)>>    00376000
   std'file'info  = pstd (std'file'inx) #,   <<file info bits:    >>    00378000
   std'file'wild  = std'file'info.(8:1) #,   << 1 = wildcards     >>    00380000
   std'file'len   = std'file'info.(9:7) #,   << length (0 to 8)   >>    00382000
   std'part'lenf  = (9:7) #,                                            00384000
   std'file'      = pstd (std'file'inx+1) #, <<pointer to file txt>>    00386000
                                                                        00388000
   std'lock'info  = pstd (std'lock'inx) #,   <<lock info bits:    >>    00390000
   std'lock'wild  = std'lock'info.(8:1) #,   << 1 = wildcards     >>    00392000
   std'lock'len   = std'lock'info.(9:7) #,   << length (0 to 8)   >>    00394000
   std'lock'      = pstd (std'lock'inx+1) #, <<pointer to lock txt>>    00396000
                                                                        00398000
   std'group'info = pstd (std'group'inx) #,  <<group info bits:    >>   00400000
   std'group'wild = std'group'info.(8:1) #,  << 1 = wildcards     >>    00402000
   std'group'len  = std'group'info.(9:7) #,  << length (0 to 8)   >>    00404000
   std'group'     = pstd (std'group'inx+1) #,<<pointer to group txt>>   00406000
                                                                        00408000
   std'acct'info  = pstd (std'acct'inx) #,   <<acct info bits:    >>    00410000
   std'acct'wild  = std'acct'info.(8:1) #,   << 1 = wildcards     >>    00412000
   std'acct'len   = std'acct'info.(9:7) #,   << length (0 to 8)   >>    00414000
   std'acct'      = pstd (std'acct'inx+1) #, <<pointer to acct txt>>    00416000
                                                                        00418000
   std'family'info= pstd (std'family'inx) #, <<family info bits:  >>    00420000
   std'family'wild= std'family'info.(8:1) #, << 1 = wildcards     >>    00422000
   std'family'len = std'family'info.(9:7) #, << length (0 to 8)   >>    00424000
   std'family'    = pstd (std'family'inx+1)#,<<pntr to family txt >>    00426000
                                                                        00428000
   std'host'info  = pstd (std'host'inx) #,   <<host info bits:    >>    00430000
   std'host'wild  = std'host'info.(8:1) #,   << 1 = wildcards     >>    00432000
   std'host'len   = std'host'info.(9:7) #,   << length (0 to 8)   >>    00434000
   std'host'      = pstd (std'host'inx+1) #; <<pointer to host txt>>    00436000
!-----------------------------------------------------------------------00438000
equate                                                                  00440000
                                                                        00442000
      <<error numbers for standard form conversion...>>                 00444000
                                                                        00446000
         <<from standard to display...>>                                00448000
                                                                        00450000
   de'standard'too'long =  1, <<resultant display title too long>>      00452000
   de'standard'empty    =  2, <<zero length file part in std title>>    00454000
                                                                        00456000
         <<from display to standard...>>                                00458000
                                                                        00460000
   se'part'too'long     =  1, <<part too long>>                         00462000
   se'zero'part         =  2, <<zero length part>>                      00464000
   se'wild'd'or'b       =  3, <<wild and either $ or *>>                00466000
   se'first'is'digit    =  4, <<first char cant be digit>>              00468000
   se'lockword'loc      =  5, <<bad place for lockword>>                00470000
   se'too'many'periods  =  6, <<too many periods>>                      00472000
   se'star'not'first    =  7, <<"*" must be first character>>           00474000
   se'star'and'dollar   =  8, <<dollar and backref true>>               00476000
   se'dollar'not'first  =  9, <<"$" must be first character>>           00478000
   se'illegal'character = 10, <<invalid title character>>               00480000
   se'missing'parameters= 11; <<needed parameters were omitted>>        00482000
$page "ERROR MESSAGE EQUATES"                                           00484000
equate                                                                  00486000
   ! these error message are printed as is.                             00488000
                                                                        00490000
   tape'fsf'error            = 1,                                       00492000
   answer'yes'no             = 2,                                       00494000
   list'fclose'error         = 3,                                       00496000
   tape'fclose'error         = 4,                                       00498000
   not'a'recover5'tape       = 5,                                       00500000
   tape'rewind'unload'error  = 6,                                       00502000
   mount'new'tape            = 7,                                       00504000
   tape'read'error           = 8,                                       00506000
   catastrophic'tape'error   = 9,                                       00508000
   enter'fileset             = 10,                                      00510000
   terminate'list            = 11,                                      00512000
   prompt                    = 12,                                      00514000
   blank'line                = 13,                                      00516000
   keep'files                = 14,                                      00518000
   banner                    = 15,                                      00520000
   invalid'mpe'version       = 16,                                      00522000
   listfile'fopen'error      = 17,                                      00524000
   stdin'fopen'error         = 18,                                      00526000
   user'lacks'sm'cap         = 19,                                      00528000
   tape'fopen'error          = 20,                                      00530000
   control'y'continue        = 21,                                      00532000
   ask'another'tape          = 22,                                      00534000
   ask'continuation'tape     = 23,                                      00536000
   controly'detected         = 24,                                      00538000
   name'pattern'error        = 25,                                      00540000
   group'pattern'error       = 26,                                      00542000
   account'pattern'error     = 27,                                      00544000
   excessive'filesets        = 28,                                      00546000
   part'too'long             = 29,                                      00548000
   zero'len                  = 30,                                      00550000
   invalid'wild              = 31,                                      00552000
   numeric'illegal           = 32,                                      00554000
   invalid'lockword          = 33,                                      00556000
   too'many'periods          = 34,                                      00558000
   invalid'star              = 35,                                      00560000
   invalid'special'chars     = 36,                                      00562000
   invalid'dollar            = 37,                                      00564000
   illegal'char              = 38,                                      00566000
   parms'missing             = 39,                                      00568000
   reenter'filesets          = 40,                                      00570000
   fwrite'list'error         = 41,                                      00572000
   open'tape'file            = 42,                                      00574000
   tape'continuation'error   = 43,                                      00576000
                                                                        00578000
   !--------------------------------------------------------------------00580000
   ! these errors have the current disc file name attached to the begin-00582000
   ! ing of the message.  if 100 <= message'num >= 199 then the error is00584000
   ! outputed  to the  file "LIST".  if message'num >= 200 then the err-00586000
   ! or is outputed to $stdlist.                                        00588000
   !--------------------------------------------------------------------00590000
                                                                        00592000
   duplicate'file'error      = 100,                                     00594000
   fopen'existing'file'error = 101,                                     00596000
   purge'error               = 102,                                     00598000
   fclose'error              = 103,                                     00600000
   file'short'error          = 104,                                     00602000
   successful'recovery       = 105,                                     00604000
   flab'io'error             = 106,                                     00606000
   too'many'ulabs            = 107,                                     00608000
   ulab'write'error          = 108,                                     00610000
   data'write'error          = 109,                                     00612000
   too'many'data'records     = 110,                                     00614000
   disc'fopen'error          = 111,                                     00616000
   ffileinfo'error           = 112,                                     00618000
   tape'data'read'error      = 113,                                     00620000
   file'continuation         = 214;                                     00622000
                                                                        00624000
$include inclflab                                                       00626000
$page "PCB GLOBAL INCLUDE FILE"                                         00628000
$include inclpxg                                                        00630000
$page "EXTERNAL DECLARATIONS"                                           00632000
intrinsic                                                               00634000
                                                                        00636000
fcontrol,fopen,fclose,fcheck,fgetinfo,fread,fwrite,who,xcontrap,        00638000
resetcontrol,terminate,fwritelabel,ffileinfo,ferrmsg,print;             00640000
                                                                        00642000
integer procedure getsir(sir);                                          00644000
value sir;                                                              00646000
integer sir;                                                            00648000
option external;                                                        00650000
                                                                        00652000
procedure relsir(sir,returnv);                                          00654000
value sir,returnv;                                                      00656000
integer sir,returnv;                                                    00658000
option external;                                                        00660000
                                                                        00662000
procedure put'acb'info(fnum,item'num,item);                             00664000
value fnum,item'num,item;                                               00666000
integer fnum,item'num,item;                                             00668000
option external;                                                        00670000
                                                                        00672000
integer procedure flabio(ldev,disc'address,function,target);            00674000
value ldev,disc'address,function;                                       00676000
integer ldev,function;                                                  00678000
double disc'address;                                                    00680000
array target;                                                           00682000
option external;                                                        00684000
                                                                        00686000
integer procedure ropen(fd,fo,ao,rs,dv,fm,ul,bf,nb,fs,ne,ia,fc);        00688000
value   fo,ao,rs,ul,bf,nb,fs,ne,ia,fc;                                  00690000
integer rs,ul,bf,nb,ne,ia,fc;                                           00692000
logical fo,ao;                                                          00694000
double  fs;                                                             00696000
byte array fd,dv,fm;                                                    00698000
option external,variable;                                               00700000
                                                                        00702000
procedure print'message(msg'num,fnum,cctl);                             00704000
value msg'num,fnum,cctl;                                                00706000
integer msg'num,fnum,cctl;                                              00708000
option forward,variable;                                                00710000
                                                                        00712000
logical procedure sub'match (ptext, actuallen, pattern, startpart);     00714000
value ptext, actuallen, startpart;                                      00716000
integer actuallen, startpart;                                           00718000
byte pointer ptext;                                                     00720000
integer array pattern;                                                  00722000
option forward;                                                         00724000
                                                                        00726000
procedure exit'program;                                                 00728000
option forward;                                                         00730000
                                                                        00732000
$page "DISPLAY'TO'STANDARD"                                             00734000
logical procedure display'to'standard (pdis, pstd, error, char'inx,     00736000
                                       delims);                         00738000
            value pdis, pstd, delims;                                   00740000
            integer error, char'inx;                                    00742000
            byte pointer pdis, pstd, delims;                            00744000
            option variable;                                            00746000
   <<this routine converts a display form file title into               00748000
     a standard form file title.  if an error occurs, the error         00750000
     number is reported in error.                                       00752000
     parameters:                                                        00754000
                                                                        00756000
      pdis:  byte pointer, points to a file title (with or              00758000
         without wildcards or group or account.  terminated by          00760000
         a blank!                                                       00762000
         may not be omitted.                                            00764000
                                                                        00766000
      pstd:  byte pointer, will hold standard form title.  as           00768000
         such, must hold at least max'std'len characters!               00770000
         this will be filled with zeroes at start of routine.           00772000
         may not be omitted.                                            00774000
                                                                        00776000
      error: integer, call by reference.                                00778000
         this is initialized to zero at entry.                          00780000
         may not be omitted.                                            00782000
                                                                        00784000
      char'inx: integer, call by reference.                             00786000
         in the event of an error, this is the index of the             00788000
         offending character in pdis.                                   00790000
         in the event of a successful conversion, this is the           00792000
         index of the first character after the file title,             00794000
         presumably the blank that trails it.  it therefore             00796000
         is equivalent to the length of the display form title.         00798000
         may not be omitted.                                            00800000
                                                                        00802000
      delims: byte pointer, call by value.                              00804000
         contains a sequence of characters that are valid to            00806000
         terminate a file title with.  delims (0) is the count of       00808000
         the number of valid delimiters.  thus, to allow a file title   00810000
         to be delimited by blank, comma, semicolon, or minus, one      00812000
         would use:  move delims:=(%4, " ,;-");   or                    00814000
         (%4, "-; ,").                                                  00816000
         note: this cannot be used to prevent letters/digits/wildcards  00818000
         from being part of a title!                                    00820000
         defaults to:   (%4, "-; ,").                                   00822000
                                                                        00824000
   result:                                                              00826000
      failed if an error occurs,                                        00828000
      good if no error.   (good <==> not failed)                        00830000
   -----------------------------------------------------------          00832000
                                                                        00834000
   standard form file title layout:                                     00836000
                                                                        00838000
   byte array:           #bytes  byte index    define to access:        00840000
                                             (using byte pointer        00842000
      +------------------+                    pstd)                     00844000
      ! total length     !    2     0             std'len'total         00846000
      ! (self inclusive) !                                              00848000
      !(note: 2 bytes!)  !                                              00850000
      +------------------+                                              00852000
      ! standard-form    !    1     2             std'version           00854000
      ! version          !                                              00856000
      ! (usually = 1)    !                                              00858000
      +------------------+                                              00860000
      ! information byte !    1     3             std'info              00862000
      ! bits: (8..15)    !                                              00864000
      ! 8 = r e s e r v e!  \                                           00866000
      ! 9 = r e s e r v e!   \                                          00868000
      !10 = r e s e r v e!    >   set to 0.                             00870000
      !11 = r e s e r v e!   /                                          00872000
      !12 = r e s e r v e!  /                                           00874000
      !13 = backreference!                        std'back              00876000
      !14 = dollar       !                        std'dollar            00878000
      !15 = wildcards    !                        std'wild              00880000
      +------------------+                                              00882000
      !index of file part!    1     4             std'file'inx          00884000
      ! in this array    !                                              00886000
      !(if zero, part was!                                              00888000
      !not found)        !                                              00890000
      +------------------+                                              00892000
      !index of lockword !    1     5             std'lock'inx          00894000
      !part in this array!                                              00896000
      +------------------+                                              00898000
      !index of group    !    1     6             std'group'inx         00900000
      !part in this array!                                              00902000
      +------------------+                                              00904000
      !index of acct part!    1     7             std'acct'inx          00906000
      !in this array     !                                              00908000
      +------------------+                                              00910000
      !reserved, := 0    !    1     8             std'host'inx          00912000
      !  (host name)     !                                              00914000
      +------------------+                                              00916000
      !reserved, := 0    !    1     9             std'pv'inx            00918000
      !(private volume   !                                              00920000
      ! (family) name    !                                              00922000
      +------------------+                                              00924000
              ...                                                       00926000
      +------------------+                                              00928000
      ~ dont count on the~                                              00930000
      ~ next part being  ~                                              00932000
      ~ right after the  ~                                              00934000
      ~ above info!!!!   ~                                              00936000
      +------------------+                                              00938000
              ...                                                       00940000
      +------------------+                                              00942000
      ! reserved, := 1   !    1     std'file'inx-1                      00944000
      ! (number of parts !                        std'file'parts        00946000
      ! in file name)    !                                              00948000
      +------------------+                                              00950000
      !file part info:   !    1     std'file'inx  std'file'info         00952000
      !bit 8 = wildcards !                        std'file'wild         00954000
      !bit 9..15= length !                        std'file'len          00956000
      +------------------+                                              00958000
      !file part text... !    0..8  std'file'inx+1                      00960000
      !up to 8 characters!                        std'file'             00962000
      !in length, no fill!                                              00964000
      !characters at end.!                                              00966000
      +------------------+                                              00968000
              ...                                                       00970000
      +------------------+                                              00972000
      ! (second, third...!    0..???                                    00974000
      ! 'nth' file parts !                                              00976000
      ! will follow this !                                              00978000
      ! someday).        !                                              00980000
      +------------------+                                              00982000
              ...                                                       00984000
      +------------------+                                              00986000
      !lock part info:   !    1     std'lock'inx  std'lock'info         00988000
      !bit 8 = wildcards !                        std'lock'wild         00990000
      !bit 9..15= length !                        std'lock'len          00992000
      +------------------+                                              00994000
      !lock part text... !    0..8  std'lock'inx+1                      00996000
      !up to 8 characters!                        std'lock'             00998000
      !in length, no fill!                                              01000000
      !characters at end.!                                              01002000
      +------------------+                                              01004000
              ...                                                       01006000
      +------------------+                                              01008000
      !group part info:  !    1     std'group'inx std'group'info        01010000
      !bit 8 = wildcards !                        std'group'wild        01012000
      !bit 9..15= length !                        std'group'len         01014000
      +------------------+                                              01016000
      !group part text...!    0..8  std'group'inx+1                     01018000
      !up to 8 characters!                        std'group'            01020000
      !in length, no fill!                                              01022000
      !characters at end.!                                              01024000
      +------------------+                                              01026000
              ...                                                       01028000
      +------------------+                                              01030000
      !acct part info:   !    1     std'acct'inx  std'acct'info         01032000
      !bit 8 = wildcards !                        std'acct'wild         01034000
      !bit 9..15= length !                        std'acct'len          01036000
      +------------------+                                              01038000
      !acct part text... !    0..8  std'acct'inx+1                      01040000
      !up to 8 characters!                        std'acct'             01042000
      !in length, no fill!                                              01044000
      !characters at end.!                                              01046000
      +------------------+                                              01048000
              ...                                                       01050000
      ~~~~~~~~~~~~~~~~~~~~                                              01052000
      ~ the following    ~                                              01054000
      ~ two parts are not~                                              01056000
      ~ yet implemented, ~                                              01058000
      ~ but have been    ~                                              01060000
      ~ defined to allow ~                                              01062000
      ~later enhancements~                                              01064000
      ~~~~~~~~~~~~~~~~~~~~                                              01066000
              ...                                                       01068000
      +------------------+                                              01070000
      !family part info: !    1     std'family'inx std'family'info      01072000
      !bit 8 = wildcards !                        std'family'wild       01074000
      !bit 9..15= length !                        std'family'len        01076000
      +------------------+                                              01078000
      !family part text..!    0..8  std'family'inx+1                    01080000
      !up to 8 characters!                        std'family'           01082000
      !in length, no fill!                                              01084000
      !characters at end.!                                              01086000
      +------------------+                                              01088000
              ...                                                       01090000
      +------------------+                                              01092000
      !host part info:   !    1     std'host'inx  std'host'info         01094000
      !bit 8 = wildcards !                        std'host'wild         01096000
      !bit 9..15= length !                        std'host'len          01098000
      +------------------+                                              01100000
      !host part text... !    0..8  std'host'inx+1                      01102000
      !up to 8 characters!                        std'host'             01104000
      !in length, no fill!                                              01106000
      !characters at end.!                                              01108000
      +------------------+                                              01110000
                                                                        01112000
   ----------------------------------------------------------->>        01114000
   begin                                                                01116000
                                                                        01118000
   label                                                                01120000
      xit;                                                              01122000
                                                                        01124000
   byte array                                                           01126000
      default'delims (0:4);                                             01128000
                                                                        01130000
   logical                                                              01132000
      bitmask     = q - 4,                                              01134000
      char'type   := false,                                             01136000
      digit       := false,                                             01138000
      done        := false,                                             01140000
      letter      := false,                                             01142000
      wild        := false,                                             01144000
      wild'part   := false;                                             01146000
                                                                        01148000
   integer                                                              01150000
      delim'inx   := 0,   <<used to index through delims>>              01152000
      part'inx    := 0,   <<index of info for current part>>            01154000
      part'len    := 0,   <<length of current part>>                    01156000
      state       := 0,   <<0, 1, 2, 3: file, lock, group, acct>>       01158000
      total'len   := 0;   <<cumulative length of std title thus far>>   01160000
                                                                        01162000
   byte                                                                 01164000
      char;                                                             01166000
                                                                        01168000
   define                                                               01170000
      state'file  = 0 #,                                                01172000
      state'lock  = 1 #,                                                01174000
      state'group = 2 #,                                                01176000
      state'acct  = 3 #;                                                01178000
                                                                        01180000
   <<---------------------->>                                           01182000
   subroutine err (n); value n; integer n;                              01184000
      begin                                                             01186000
                                                                        01188000
      error:= n;                                                        01190000
      display'to'standard:=failed;                                      01192000
      go xit;                                                           01194000
                                                                        01196000
      end <<err sub>>;                                                  01198000
   <<--------------------->>                                            01200000
   subroutine append'char;                                              01202000
      begin                                                             01204000
                                                                        01206000
      total'len:=total'len+1;                                           01208000
      if (part'len:=part'len+1) > 8 then                                01210000
         err (se'part'too'long);       <<part too long>>                01212000
                                                                        01214000
      pstd(total'len):=char;                                            01216000
                                                                        01218000
      end <<append'char sub>>;                                          01220000
   <<------------------------->>                                        01222000
   logical subroutine check'delim (char); value char; byte char;        01224000
      begin                                                             01226000
                                                                        01228000
      delim'inx:=delims(0)+1;                                           01230000
                                                                        01232000
      while (delim'inx:=delim'inx-1) > 0 do                             01234000
         if delims(delim'inx) = char then                               01236000
            begin                                                       01238000
            check'delim:=good;                                          01240000
            return;                                                     01242000
            end;                                                        01244000
                                                                        01246000
      check'delim:=failed;                                              01248000
                                                                        01250000
      end <<check'delim sub>>;                                          01252000
   <<------------------------>>                                         01254000
   subroutine classify'char;                                            01256000
      begin                                                             01258000
                                                                        01260000
            <<classify the character...>>                               01262000
                                                                        01264000
      wild:=digit:=letter:=false;                                       01266000
                                                                        01268000
      if char="@" or char="?" or char="#" then                          01270000
         wild:=true                    <<wildcard>>                     01272000
      else if %60 <= integer(char) <= %71 then                          01274000
         digit:=true                   <<digit from 0..9>>              01276000
      else if %101 <= integer(char) <= %132 then                        01278000
         letter:=true                  <<uppercase a..z>>               01280000
      else if %141 <= integer(char) <= %172 then                        01282000
         begin                                                          01284000
         letter:=true;                 <<lowercase a..z>>               01286000
            <<upcase it...>>                                            01288000
         char:=(char-"a")+"A";                                          01290000
         end;                                                           01292000
                                                                        01294000
      end <<classify'char sub>>;                                        01296000
   <<--------------------->>                                            01298000
   subroutine close'part;                                               01300000
      begin                                                             01302000
                                                                        01304000
      if part'len = 0 then                                              01306000
         err (se'zero'part);           <<zero length part>>             01308000
                                                                        01310000
      case state of                                                     01312000
         begin                                                          01314000
                                                                        01316000
         <<state'file:>>                                                01318000
            begin                                                       01320000
            std'file'wild:=wild'part;                                   01322000
            std'file'len:=part'len;                                     01324000
            end;                                                        01326000
                                                                        01328000
         <<state'lock:>>                                                01330000
            begin                                                       01332000
            std'lock'wild:=wild'part;                                   01334000
            std'lock'len:=part'len;                                     01336000
            end;                                                        01338000
                                                                        01340000
         <<state'group:>>                                               01342000
            begin                                                       01344000
            std'group'wild:=wild'part;                                  01346000
            std'group'len:=part'len;                                    01348000
            end;                                                        01350000
                                                                        01352000
         <<state'acct:>>                                                01354000
            begin                                                       01356000
            std'acct'wild:=wild'part;                                   01358000
            std'acct'len:=part'len;                                     01360000
            end                                                         01362000
         end;                                                           01364000
                                                                        01366000
      end <<close'part sub>>;                                           01368000
   <<--------------------->>                                            01370000
   subroutine look'at'char;                                             01372000
      begin                                                             01374000
                                                                        01376000
      if wild then                                                      01378000
         begin                         <<wildcard found>>               01380000
         wild'part:=true;                                               01382000
         std'wild:=true;                                                01384000
         if logical(std'dollar) or logical(std'back) then               01386000
            err (se'wild'd'or'b);      <<wild and either $ or *>>       01388000
         if part'len=0 and char="#" then                                01390000
            err (se'first'is'digit);   <<first char cant be digit>>     01392000
         end                                                            01394000
                                                                        01396000
      else if part'len=0 and digit then                                 01398000
         err (se'first'is'digit);      <<first char cant be digit>>     01400000
                                                                        01402000
      append'char;                                                      01404000
                                                                        01406000
      end <<look'at'char sub>>;                                         01408000
   <<--------------------->>                                            01410000
   subroutine start'part;                                               01412000
      begin                                                             01414000
                                                                        01416000
      part'inx:= (total'len:=total'len+1);                              01418000
                                                                        01420000
      case state of                                                     01422000
         begin                                                          01424000
                                                                        01426000
         <<state'file:>>                                                01428000
            begin                                                       01430000
            pstd(part'inx):=1;                                          01432000
            part'inx:= (total'len:=total'len+1);                        01434000
            std'file'inx:=part'inx;                                     01436000
            end;                                                        01438000
                                                                        01440000
         <<state'lock:>>                                                01442000
            std'lock'inx:=part'inx;                                     01444000
                                                                        01446000
         <<state'group:>>                                               01448000
            std'group'inx:=part'inx;                                    01450000
                                                                        01452000
         <<state'acct:>>                                                01454000
            std'acct'inx:=part'inx;                                     01456000
                                                                        01458000
         end;                                                           01460000
                                                                        01462000
      wild'part:=false;                                                 01464000
      part'len:=0;                                                      01466000
                                                                        01468000
      end <<start'part sub>>;                                           01470000
   <<--------------------->>                                            01472000
                                                                        01474000
   if bitmask.(11:4) <> %17 then                                        01476000
      err (se'missing'parameters);                                      01478000
                                                                        01480000
   if not bitmask.(15:1) then                                           01482000
      begin                                                             01484000
      @delims:=@default'delims;                                         01486000
      move delims:=(%4, " ,;-");                                        01488000
      end;                                                              01490000
                                                                        01492000
   display'to'standard:=good;                                           01494000
                                                                        01496000
   error:=0;                                                            01498000
                                                                        01500000
   pstd(0):=0;                                                          01502000
   move pstd(1):=pstd(0),(max'std'len-1);                               01504000
   std'version:=1;            <<this is version 1 of std form>>         01506000
   total'len:=10-1;           <<first available index-1>>               01508000
                                                                        01510000
   state:=state'file;                                                   01512000
   start'part;                                                          01514000
                                                                        01516000
   char'inx:=0;                                                         01518000
   done:=false;                                                         01520000
                                                                        01522000
   while not done do                                                    01524000
      begin                                                             01526000
                                                                        01528000
            <<classify the character...>>                               01530000
                                                                        01532000
      char:=pdis(char'inx);                                             01534000
      classify'char;                                                    01536000
                                                                        01538000
            <<look at the character...>>                                01540000
                                                                        01542000
      if wild or letter or digit then                                   01544000
         look'at'char                                                   01546000
                                                                        01548000
      else if char = "." or char = "/" then                             01550000
         begin                                                          01552000
         close'part;                   <<close off current part>>       01554000
         if char = "/" then                                             01556000
            if state <> state'file then                                 01558000
               err (se'lockword'loc)   <<bad place for lockword>>       01560000
            else                                                        01562000
               state:=state'lock                                        01564000
         else if state = state'file then                                01566000
            state:=state'group         <<dot moves from file->group>>   01568000
         else if state = state'lock then                                01570000
            state:=state'group         <<dot moves from lock->group>>   01572000
         else if state = state'group then                               01574000
            state:=state'acct          <<dot moves from group->acct>>   01576000
         else                                                           01578000
            err (se'too'many'periods); <<too many periods>>             01580000
         start'part;                   <<setup next part>>              01582000
         end                                                            01584000
                                                                        01586000
      else if char = "*" then                                           01588000
         begin                                                          01590000
         std'back:=true;                                                01592000
         if state <> state'file or part'len <> 0 then                   01594000
            err (se'star'not'first);   <<"*" must be first character>>  01596000
         if logical(std'dollar) then                                    01598000
            err (se'star'and'dollar);  <<dollar and backref true>>      01600000
         end                                                            01602000
                                                                        01604000
      else if char = "$" then                                           01606000
         begin                                                          01608000
         std'dollar:=true;                                              01610000
         if state <> state'file or part'len <> 0 then                   01612000
            err (se'dollar'not'first); <<"$" must be first character>>  01614000
         if logical(std'back) then                                      01616000
            err (se'star'and'dollar);  <<dollar and backref bad>>       01618000
         end                                                            01620000
                                                                        01622000
      else if check'delim (char) = good then                            01624000
         done:=true                                                     01626000
                                                                        01628000
      else                                                              01630000
         err (se'illegal'character);   <<invalid title character>>      01632000
                                                                        01634000
      if not done then                                                  01636000
         char'inx:=char'inx+1;                                          01638000
                                                                        01640000
      end;                                                              01642000
                                                                        01644000
   close'part;                                                          01646000
                                                                        01648000
   total'len:=total'len+1;                                              01650000
   pstd(0):=total'len.(0:8);                                            01652000
   pstd(1):=total'len.(8:8);                                            01654000
                                                                        01656000
xit:                                                                    01658000
                                                                        01660000
   end <<display'to'standard proc>>;                                    01662000
$page "STANDARD'TO'DISPLAY"                                             01664000
<<************************************************************>>        01666000
logical procedure standard'to'display (pstd, pdis, error, len);         01668000
            value pstd, pdis;                                           01670000
            integer error, len;                                         01672000
            byte pointer pstd, pdis;                                    01674000
   begin                                                                01676000
   integer                                                              01678000
      part'len;                                                         01680000
   label                                                                01682000
      xit;                                                              01684000
   <<------------------>>                                               01686000
   subroutine err (n); value n; integer n;                              01688000
      begin                                                             01690000
                                                                        01692000
      error:=n;                                                         01694000
      standard'to'display:=failed;                                      01696000
      go xit;                                                           01698000
                                                                        01700000
      end <<err sub>>;                                                  01702000
   <<------------------->>                                              01704000
   subroutine append'char (char); value char; byte char;                01706000
      begin                                                             01708000
                                                                        01710000
      pdis(len):=char;                                                  01712000
      len:=len+1;                                                       01714000
      if len > max'title'len then                                       01716000
         err (de'standard'too'long);                                    01718000
                                                                        01720000
      end <<append'char sub>>;                                          01722000
   <<------------------>>                                               01724000
   subroutine append'part (char, inx); value char, inx;                 01726000
            byte char;                                                  01728000
            integer inx;                                                01730000
      begin                                                             01732000
                                                                        01734000
      if char <> " " then                                               01736000
         append'char (char);                                            01738000
                                                                        01740000
      part'len:=pstd(inx).std'part'lenf;                                01742000
      while part'len > 0 do                                             01744000
         begin                                                          01746000
         inx:=inx+1;                                                    01748000
         part'len:=part'len-1;                                          01750000
         append'char (pstd(inx));                                       01752000
         end;                                                           01754000
                                                                        01756000
      end <<append'part sub>>;                                          01758000
   <<---------------------->>                                           01760000
                                                                        01762000
   error:=0;                                                            01764000
                                                                        01766000
   len:=0;                                                              01768000
                                                                        01770000
   if logical(std'back) then                                            01772000
      append'char ("*")                                                 01774000
   else if logical(std'dollar) then                                     01776000
      append'char ("$");                                                01778000
                                                                        01780000
   if std'file'inx = 0 then                                             01782000
      err (de'standard'empty)                                           01784000
   else                                                                 01786000
      append'part (" ", std'file'inx);                                  01788000
                                                                        01790000
   if std'lock'inx > 0 then                                             01792000
      append'part ("/", std'lock'inx);                                  01794000
                                                                        01796000
   if std'group'inx > 0 then                                            01798000
      append'part (".", std'group'inx);                                 01800000
                                                                        01802000
   if std'acct'inx > 0 then                                             01804000
      append'part (".", std'acct'inx);                                  01806000
                                                                        01808000
   append'char (" ");                                                   01810000
   len:=len-1;                <<dont count trailing blank>>             01812000
                                                                        01814000
   standard'to'display := good;                                         01816000
                                                                        01818000
xit:                                                                    01820000
                                                                        01822000
   end <<standard'to'display proc>>;                                    01824000
$page"PATTERN'BUILD"                                                    01826000
logical procedure pattern'build (ptext, pattern, error'code);           01828000
         value ptext;                                                   01830000
         integer error'code;                                            01832000
         byte pointer ptext;                                            01834000
         integer array pattern;                                         01836000
      << this routine encodes a "pattern" into a special format for     01838000
        use by the procedure pattern'match.  (see the comment in        01840000
        that procedure for the layout of an encoded "pattern".)         01842000
                                                                        01844000
        this assumes ptext points to a string of 1 to pat'max'firm      01846000
        characters composed of (usually) a..z, a..z, 0..9, and          01848000
        "#?@".  this string is a "pattern".  pat'max'firm is usually    01850000
        8.  the first byte of the text is the length of the text,       01852000
        not self-inclusive.  thus the text "CAT#" would be represented  01854000
        as:  %4, "C", "A", "T", "#".                                    01856000
                                                                        01858000
        note: for compatibility with standard-form titles,              01860000
        only the bottom 7 bits of the length are used...thus,           01862000
        a pointer like:   %(2)10000011, "C", "?", "#"                   01864000
        can be passed into pattern'build without having to              01866000
        zap the wildcard bit.                                           01868000
                                                                        01870000
        if more than pat'max'part parts are found in the pattern text,  01872000
        the routine result will be failed and error'code will be set    01874000
        to pb'err'many'parts.  pat'max'part is usually 8.               01876000
                                                                        01878000
        if the pattern text contains more than pat'max'firm "firm"      01880000
        characters, a failed will be returned and error'code will be    01882000
        set to pb'err'many'firm.  pat'max'firm is usually 8.            01884000
        a "firm" character is any character that matches at least       01886000
        1 character (i.e: any character other than "@" is a "firm"      01888000
        character).                                                     01890000
                                                                        01892000
        if no error is found, good is returned and error'code:=0.       01894000
                                                                        01896000
        pattern must be at least 9 words long, even though a short      01898000
        pattern wont use all 9 words.  pattern is zeroed at the         01900000
        start of the routine.                                           01902000
                                                                        01904000
        note that the pattern text is not shifted to uppercase!         01906000
                                                                  >>    01908000
      <<---------------------------------------------------------->>    01910000
   begin                                                                01912000
                                                                        01914000
   integer                                                              01916000
      i,                                                                01918000
      firmcount   := 0,       <<number of "firm" chars seen>>           01920000
      len,                                                              01922000
      part        := 0,       <<number of parts seen>>                  01924000
      textleft;                                                         01926000
                                                                        01928000
   byte array                                                           01930000
      text'copy'  (0:64);     <<holds a copy of ptext(1...)>>           01932000
                                                                        01934000
   label                                                                01936000
      end'pattern'build;                                                01938000
                                                                        01940000
   <<------------------->>                                              01942000
   subroutine fail (n); value n; integer n;                             01944000
      begin                                                             01946000
      pattern'build:=failed;                                            01948000
      error'code:=n;                                                    01950000
      go end'pattern'build;                                             01952000
      end <<fail sub>>;                                                 01954000
   <<------------------->>                                              01956000
                                                                        01958000
   error'code:=0;                                                       01960000
   pattern(0):=0;                                                       01962000
   move pattern(1):=pattern(0),(pat'max'part);                          01964000
                                                                        01966000
   textleft:=integer(ptext).(9:7);     <<only use bottom 7 bits>>       01968000
                                                                        01970000
   move text'copy':=ptext(1),(textleft), 2;                             01972000
   move *:=0;                          <<append a stopper>>             01974000
   @ptext:=@text'copy';                                                 01976000
                                                                        01978000
   while textleft > 0 do                                                01980000
      begin                                                             01982000
                                                                        01984000
      part:=part+1;                                                     01986000
      if part > pat'max'part then                                       01988000
         fail (pb'err'many'parts);                                      01990000
                                                                        01992000
      if ptext = "?" then              <<match any 1 character>>        01994000
         begin                <<count number of contiguous "?"...>>     01996000
         scan ptext while "?",1;       <<leave pointer>>                01998000
         len:=tos-@ptext;              <<number of "?">>                02000000
         pattern(part).patlenf := len;                                  02002000
         pattern(part).patcharf:="?";                                   02004000
         pattern(part).pattypef:= anyonecharacterp;                     02006000
         firmcount:=firmcount+len;                                      02008000
         end                                                            02010000
                                                                        02012000
      else if ptext = "#" then         <<match digit>>                  02014000
         begin                <<count number of contiguous "#"...>>     02016000
         scan ptext while "#",1;       <<leave pointer>>                02018000
         len:=tos-@ptext;              <<number of "#">>                02020000
         pattern(part).patlenf := len;                                  02022000
         pattern(part).patcharf:= "#";                                  02024000
         pattern(part).pattypef:= digitonlyp;                           02026000
         firmcount:=firmcount + len;                                    02028000
         end                                                            02030000
                                                                        02032000
      else if ptext = "@" then   <<matches any number of characters>>   02034000
         begin                <<count number of contiguous "@"...>>     02036000
         scan ptext while "@",1;       <<leave pointer>>                02038000
         len:=tos-@ptext;              <<number of "?">>                02040000
         pattern(part).patlenf := len;                                  02042000
         pattern(part).patcharf:="@";                                   02044000
         pattern(part).pattypef:= anycharactersp;                       02046000
         end                                                            02048000
                                                                        02050000
      else                    <<not a pattern match character...>>      02052000
         begin                                                          02054000
         i:=integer(ptext);                                             02056000
         scan ptext while i, 1;                                         02058000
         len:=tos-@ptext;                                               02060000
         pattern(part).patlenf := len;                                  02062000
         pattern(part).patcharf:= integer(ptext);                       02064000
         pattern(part).pattypef:= exactp;                               02066000
         firmcount:=firmcount+len;                                      02068000
         end;                                                           02070000
                                                                        02072000
      if firmcount > pat'max'firm then                                  02074000
         fail (pb'err'many'firm);                                       02076000
                                                                        02078000
      @ptext:=@ptext+len;                                               02080000
      textleft:=textleft-len;                                           02082000
      end;                                                              02084000
                                                                        02086000
   pattern(0):=part;          <<remember how many parts in pattern.>>   02088000
                                                                        02090000
   pattern'build:=good;                                                 02092000
                                                                        02094000
end'pattern'build:                                                      02096000
                                                                        02098000
   end <<pattern'build proc>>;                                          02100000
$page "PATTERN'MATCH"                                                   02102000
<<***************************************************************>>     02104000
logical procedure pattern'match (ptext, pattern);                       02106000
         value ptext;                                                   02108000
         byte pointer ptext;                                            02110000
         integer array pattern;                                         02112000
      <<this routine compares the pattern in pattern to the             02114000
        title in ptext.  byte(0) of ptext is the text length            02116000
        (0 to pat'max'firm (usually 8)).  only the bottom 7             02118000
        bits of the length are used...this maintains compatibility      02120000
        with standard-form titles, which may use the eighth bit         02122000
        as a wildcard flag.                                             02124000
                                                                        02126000
        if the text in ptext matches the pattern in pattern,            02128000
        a good is returned, otherwise a failed.                         02130000
                                                                        02132000
        the layout of pattern is:                                       02134000
            pattern (0) = number of parts in the pattern.               02136000
            pattern (1..pattern(0)) = separate pattern parts.           02138000
        each pattern part is a single word (16 bits) that looks         02140000
        like:                                                           02142000
              0  1  2    7  8        15                                 02144000
            +------+------+--+--------+                                 02146000
            ! part ! part ! part      !                                 02148000
            ! type !length! character !                                 02150000
            !      !      !           !                                 02152000
            +------+------+-----------+                                 02154000
        field names:                                                    02156000
             pattypef = (0:2)  patlenf = (2:6)  patcharf = (8:8)        02158000
char:   possible types:          meanings:                              02160000
                                                                        02162000
  ?        anyonecharacterp      match any sequence of patlenf          02164000
                                 characters.                            02166000
                                                                        02168000
  @        anycharactersp        match any number of characters.        02170000
                                 patlenf is disregarded, but happens    02172000
                                 to be the number of contiguous         02174000
                                  "@"'s found in the original           02176000
                                 pattern.                               02178000
                                                                        02180000
  #        digitonlyp            match any sequence of patlenf          02182000
                                 digits.                                02184000
                                                                        02186000
  a..z,    exactp                match the exact ascii character        02188000
  a..z, 0..9, ...                that is found in patlenf field.        02190000
                                                                        02192000
      a pattern text of:  ca?d#@ would be represented as:               02194000
                                                                        02196000
         6, (exactp, 1, "C"), (exactp, 1, "A"),                         02198000
            (anyonecharacterp, 1, "?"), (exactp, 1, "D"),               02200000
            (digitonlyp, 1, "#"), (anycharactersp, 1, "@")              02202000
                                                                        02204000
      a pattern text of:  ??@@aa would be represented as:               02206000
                                                                        02208000
         3, (anyonecharacterp, 2, "?"), (anycharactersp, 2, "@"),       02210000
            (exactp, 2, "A")                                            02212000
                                                                >>      02214000
   <<----------------------------------------------------------->>      02216000
   begin                                                                02218000
                                                                        02220000
   pattern'match:=sub'match (ptext(1),                                  02222000
                             integer(ptext).(9:7),                      02224000
                             pattern, 1);                               02226000
                                                                        02228000
   end <<pattern'match proc>>;                                          02230000
$page "SUB'MATCH"                                                       02232000
<<***************************************************************>>     02234000
logical procedure sub'match (ptext, actuallen, pattern, startpart);     02236000
         value ptext, actuallen, startpart;                             02238000
         integer actuallen, startpart;                                  02240000
         byte pointer ptext;                                            02242000
         integer array pattern;                                         02244000
      <<this routine attempts to match the remaining portion            02246000
        of the pattern versus the remaining portion of the              02248000
        original text.  if the match succeeds, good is                  02250000
        returned, otherwise failed.                                     02252000
        note: it is recursive!>>                                        02254000
   begin                                                                02256000
   integer                                                              02258000
      i,                                                                02260000
      len,                                                              02262000
      minlen,                                                           02264000
      part,                                                             02266000
      parts;                                                            02268000
                                                                        02270000
   sub'match:=failed;                                                   02272000
                                                                        02274000
   minlen:=0;                                                           02276000
   parts:=pattern(0);                                                   02278000
   part:=startpart-1;                                                   02280000
                                                                        02282000
         <<determine minimum length that the rest of the                02284000
           pattern must be...>>                                         02286000
                                                                        02288000
   while (part:=part+1) <= parts do                                     02290000
      if (i:=pattern(part)).pattypef <> anycharactersp then             02292000
         minlen:=minlen+i.patlenf;                                      02294000
                                                                        02296000
         <<see if test string has any possible chance of matching       02298000
           pattern...>>                                                 02300000
                                                                        02302000
   if minlen > actuallen then                                           02304000
      return;                 <<failed>>                                02306000
                                                                        02308000
         <<loop thru easy parts, recursing to handle                    02310000
           complex parts ("@")...>>                                     02312000
                                                                        02314000
   part:=startpart-1;                                                   02316000
                                                                        02318000
   while (part:=part+1) <= parts do                                     02320000
      begin                                                             02322000
      i:=pattern(part);                                                 02324000
      len:=i.patlenf;         <<length of this part>>                   02326000
                                                                        02328000
      if (actuallen < len) and i.pattypef <> anycharactersp then        02330000
         return;              <<can't possibly match>>                  02332000
                                                                        02334000
      case i.pattypef of                                                02336000
         begin                                                          02338000
                                                                        02340000
         <<anyonecharacterp:>>                                          02342000
            ;                          <<valid match, by definition!>>  02344000
                                                                        02346000
         <<anycharactersp:>>                                            02348000
            begin                      <<match from 0 to actuallen>>    02350000
            if part = parts then                                        02352000
               begin                                                    02354000
               sub'match:=good;        <<is last part.>>                02356000
               return;                                                  02358000
               end;                                                     02360000
                  <<try matching with 0, 1, ..., actuallen chars...>>   02362000
            len:=actuallen-minlen;                                      02364000
            do                                                          02366000
               if sub'match (ptext(len), actuallen-len,                 02368000
                             pattern, part+1) = good then               02370000
                  begin                                                 02372000
                  sub'match:=good;     <<it worked!>>                   02374000
                  return;                                               02376000
                  end                                                   02378000
            until                                                       02380000
               (len:=len-1) < 0;                                        02382000
            return;                    <<it failed!>>                   02384000
            end;                                                        02386000
                                                                        02388000
         <<digitonlyp:>>                                                02390000
            begin                                                       02392000
            while (len:=len-1) >= 0 do                                  02394000
               if ptext(len) <> numeric then                            02396000
                  return;              <<not a digit!>>                 02398000
            len:=i.patlenf;                                             02400000
            end;                                                        02402000
                                                                        02404000
         <<exactp:>>                                                    02406000
            begin                                                       02408000
            while (len:=len-1) >= 0 do                                  02410000
               if integer(ptext(len)) <> i.patcharf then                02412000
                  return;                 <<mismatched!>>               02414000
            len:=i.patlenf;                                             02416000
            end;                                                        02418000
         end;                                                           02420000
                                                                        02422000
      minlen:=minlen-len;              <<subtract # chars matched>>     02424000
      actuallen:=actuallen-len;        <<ditto>>                        02426000
      @ptext:=@ptext(len);             <<point to remainder of text>>   02428000
                                                                        02430000
      end;        <<end of while loop>>                                 02432000
                                                                        02434000
   if actuallen = 0 then                                                02436000
      sub'match:=good;                 <<matched ok!>>                  02438000
                                                                        02440000
   end <<sub'match proc>>;                                              02442000
$page "PATTERNMATCH"                                                    02444000
logical procedure patternmatch (cur'file,pat'file);                     02446000
                  value cur'file,pat'file;                              02448000
                  byte pointer cur'file,pat'file;                       02450000
begin                                                                   02452000
                                                                        02454000
 byte pointer                                                           02456000
    pstd,          << used for std'... defines >>                       02458000
    cur'name,      << pointers to filename field, >>                    02460000
    cur'group,     << file group field, >>                              02462000
    cur'acct,      << file acct field, >>                               02464000
    pat'name,      << pattern name field, >>                            02466000
    pat'group,     << pattern group field, >>                           02468000
    pat'acct;      << and pattern acct field. >>                        02470000
                                                                        02472000
 integer array pattern(0:8); << built pattern goes here >>              02474000
                                                                        02476000
 integer error'code; << used for errors from patternbuild >>            02478000
                                                                        02480000
  patternmatch := false;                                                02482000
                                                                        02484000
  @pstd     := @cur'file;    << to use following defines >>             02486000
  @cur'name := @pstd( std'file'inx );  << pick off filename >>          02488000
  @cur'group:= @pstd( std'group'inx ); << pick off file group >>        02490000
  @cur'acct := @pstd( std'acct'inx );  << pick off file acct >>         02492000
                                                                        02494000
  @pstd     := @pat'file;    << now point to pattern file... >>         02496000
  @pat'name := @pstd( std'file'inx );  << pattern name... >>            02498000
  @pat'group:= @pstd( std'group'inx);  << pattern group... >>           02500000
  @pat'acct := @pstd( std'acct'inx);   << pattern acct ...>>            02502000
                                                                        02504000
  pattern'build( pat'name, pattern , error'code);                       02506000
  if error'code <> 0 then   << failed to build pattern >>               02508000
     begin                                                              02510000
      print'message(name'pattern'error);                                02512000
      return;                                                           02514000
     end;                                                               02516000
  if pattern'match( cur'name, pattern ) = failed then return;           02518000
                                                                        02520000
  pattern'build( pat'group, pattern, error'code );                      02522000
  if error'code <> 0 then  << failed to build group pat >>              02524000
     begin                                                              02526000
      print'message(group'pattern'error);                               02528000
      return;                                                           02530000
     end;                                                               02532000
  if pattern'match( cur'group, pattern) = failed then return;           02534000
                                                                        02536000
  pattern'build( pat'acct, pattern, error'code );                       02538000
  if error'code <> 0 then                                               02540000
     begin                                                              02542000
      print'message(account'pattern'error);                             02544000
      return;                                                           02546000
     end;                                                               02548000
  if pattern'match( cur'acct, pattern)  = failed then return;           02550000
                                                                        02552000
  <<  made it ! >>                                                      02554000
  patternmatch := true;                                                 02556000
  return;                                                               02558000
end; << patternmatch >>                                                 02560000
                                                                        02562000
                                                                        02564000
$page "CONTROLY"                                                        02566000
!-----------------------------------------------------------------------02568000
! controly  is  the  procedure  entered  in  the event of a user hitting02570000
! control y.  it is a very standard procedure.  it switches the control'02572000
! 'y'detected flag so that after the current file is recovered, the user02574000
! is  asked  if  he  wishes  to continue or not.  then, the control-y is02576000
! reset and we return to the point where the control y was hit.  this is02578000
! this is done by placing %31400+n on the stack and executiexit instruc-02580000
! where  n  is the number of words currently in the stack plus the stack02582000
! plus  the stack marker.  for more information, see the intrinsics man-02584000
! al under control y.                                                   02586000
!-----------------------------------------------------------------------02588000
                                                                        02590000
procedure controly;                                                     02592000
begin                                                                   02594000
integer sdec=q+1;                                                       02596000
control'y'detected:=true;                                               02598000
print'message(controly'detected);                                       02600000
resetcontrol;                                                           02602000
tos:=exitn+sdec;                                                        02604000
assemble(xeq 0);                                                        02606000
end;                                                                    02608000
$page "CHECK'LIST"                                                      02610000
logical procedure check'list;                                           02612000
 << this procedure chases down the list of filesets entered             02614000
     and tries to convert them to standard form.  if we succeed,        02616000
    "TRUE" is returned, if not, an error message is printed,            02618000
    the user is prompted for more input, and "FALSE" is returned>>      02620000
                                                                        02622000
 begin                                                                  02624000
  integer array error'list(*)=pb := part'too'long,zero'len,invalid'wild,02626000
  numeric'illegal,invalid'lockword,too'many'periods,invalid'star,       02628000
  invalid'special'chars,invalid'dollar,illegal'char,parms'missing;      02630000
                                                                        02632000
  logical eol:=false;                                                   02634000
  byte pointer pstd;                                                    02636000
  byte array delims(0:5);                                               02638000
  byte pointer dptr := @delims;                                         02640000
  move delims := (%4," ,",%15,%0);                                      02642000
  @list'pt := @file'list;    <<point to begin of list>>                 02644000
  @out'pt  := @out'list;     <<point to begin of stnd list>>            02646000
  kount := 0;                                                           02648000
  num'strict := 0;                                                      02650000
                                                                        02652000
   do begin                                                             02654000
    scan list'pt while "  ",1;                                          02656000
    @list'pt := tos;                                                    02658000
    display'to'standard(list'pt,out'pt,error,char'inx,dptr);            02660000
                                                                        02662000
    if error = 0 then        <<converted to stnd form o.k.>>            02664000
     begin                                                              02666000
      @pstd := @out'pt;  << to use std'wild define >>                   02668000
      if  std'wild = 0  then num'strict := num'strict + 1               02670000
                    else got'wild   := true;                            02672000
      @out'pt := @out'pt + max'std'len;<<bump stnd list pointer>>       02674000
      kount := kount +1;     <<count the number of filesets entered>>   02676000
       if kount > max'list then                                         02678000
        begin                                                           02680000
         print'message(excessive'filesets);                             02682000
         num'strict := max'list;                                        02684000
         kount := max'list;                                             02686000
         check'list := true;                                            02688000
         return;                                                        02690000
        end;                                                            02692000
      @list'pt := @list'pt + char'inx ;                                 02694000
      scan list'pt while "  ",1;                                        02696000
      @list'pt := tos;                                                  02698000
      if list'pt = "," then @list'pt := @list'pt + 1                    02700000
      else if list'pt =  0  then eol := true                            02702000
           else begin                                                   02704000
                   error := se'illegal'character;                       02706000
                   go to errmsg;                                        02708000
                end;                                                    02710000
     end                                                                02712000
    else << error from display'to'stnd >>                               02714000
     begin                                                              02716000
errmsg:                                                                 02718000
       len := @end'of'list - @list'pt + 1 ;<<len of input ignored>>     02720000
       move io'buffer'b := list'pt,(len);                               02722000
       print (io'buffer,-len," ");                                      02724000
       io'buffer'b := " ";                                              02726000
       move io'buffer'b(1) := io'buffer'b,(len-1);                      02728000
       move io'buffer'b(char'inx) := "^";                               02730000
       print (io'buffer,-len," ");                                      02732000
       print'message(error'list(error-1));                              02734000
       print'message(reenter'filesets);                                 02736000
       @list'pt := @file'list;      <<back up and try again...>>        02738000
       check'list := false;                                             02740000
       return;                                                          02742000
      end;                                                              02744000
     end until eol = true or kount > max'list;                          02746000
    check'list := true;                                                 02748000
    return;                                                             02750000
   end;  <<  check'list  >>                                             02752000
<<                                                           >>         02754000
$page "MATCHES'LIST"                                                    02756000
logical procedure matches'list;                                         02758000
 << this procedure compares the current filename (from formdes)         02760000
    with the list of filesets specified.  if it matches a fileset       02762000
    on the list, "TRUE" is returned and the existing file is not        02764000
    overwritten.                                               >>       02766000
                                                                        02768000
 begin                                                                  02770000
  integer k:= 0;                                                        02772000
  @out'pt := @out'list;           <<point to begin of stnd list>>       02774000
   do begin                       <<loop for each fileset on list>>     02776000
    if patternmatch(formdes'std'ptr,out'pt) = true then                 02778000
     begin                        <<file was on list...>>               02780000
      matches'list := true;       <<return "TRUE">>                     02782000
      return;                                                           02784000
     end;                                                               02786000
    @out'pt := @out'pt + max'std'len;  <<bump list pointer>>            02788000
    k := k + 1;                        <<bump fileset counter>>         02790000
   end until k = kount;       << loop to next fileset on list >>        02792000
  matches'list := false;     <<if we fall through -> no match>>         02794000
  return;                                                               02796000
 end;   << matches'list >>                                              02798000
$page "PRINT'MESSAGE"                                                   02800000
procedure print'message(message'num,fnum,cctl);                         02802000
value message'num,fnum,cctl;                                            02804000
integer message'num,fnum,cctl;                                          02806000
option variable;                                                        02808000
                                                                        02810000
begin                                                                   02812000
integer                                                                 02814000
   error'code;                                                          02816000
logical                                                                 02818000
   pmap = q-4;                                                          02820000
define                                                                  02822000
   l = len := move io'buffer'b(29) :=#,                                 02824000
   p = len := move io'buffer'b :=#,                                     02826000
   cctl'specified = pmap.(15:1)#,                                       02828000
   fnum'specified = pmap.(14:1)#;                                       02830000
                                                                        02832000
if not cctl'specified then                                              02834000
   cctl := 0;                                                           02836000
                                                                        02838000
if message'num >= 100 then                                              02840000
   begin   ! insert the file name and fwrite to list file.              02842000
   move io'buffer'b := file'name,(26);                                  02844000
   move io'buffer'b(26) := " - ";                                       02846000
   case (message'num mod 100) of                                        02848000
     begin                                                              02850000
     l "duplicate name in directory, file not recovered";               02852000
     l "FOPEN of existing file to purge failed";                        02854000
     l "purge of existing file failed";                                 02856000
     l "FCLOSE to save the file failed";                                02858000
     l "the file on the tape is shorter than calculated";               02860000
     l "successful recovery of file";                                   02862000
     l "I/O error when reading/writing the file label";                 02864000
     l "has more user labels on the tape than file label reflects";     02866000
     l "write error while writing the file's user labels";              02868000
     l "write error while writing data to the file";                    02870000
     l "has more data records on tape than the file label reflects";    02872000
     l "FOPEN of the disc file failed";                                 02874000
     l "FFILEINFO of file failed";                                      02876000
     l "read error encountered on data portion of file on tape";        02878000
     l "continues on another tape";                                     02880000
     end;                                                               02882000
   len := len+29;                                                       02884000
   end                                                                  02886000
else                                                                    02888000
   begin   ! just print the message, no file name attached.             02890000
   case message'num - 1 of                                              02892000
     begin                                                              02894000
     p "Error occured on forward space file of 'RECOVTP'";              02896000
     p "Answer 'YES' or 'NO'";                                          02898000
     p "FCLOSE of output file 'LIST' failed";                           02900000
     p "FCLOSE of file 'RECOVTP' failed";                               02902000
     p "The file 'RECOVTP' is not in the SADUTIL format";               02904000
     p "Error occured on rewind-unload of 'RECOVTP'";                   02906000
     p "Mount a new recovery tape or serial disc";                      02908000
     p "Read error encountered on file label block of tape";            02910000
     p "Catastrophic tape error, can't continue";                       02912000
     p "Enter filesets to recover";                                     02914000
     p "Terminate the fileset list with a null line";                   02916000
     p ">";                                                             02918000
     p " ";                                                             02920000
     p "Do you wish to keep existing copies of files? ";                02922000
     p "RECOVER5 V.UU.FF (C) HEWLETT-PACKARD CO., 1984";                02924000
     p "RECOVER5 will only run on MPE-V (G.00.00) or later";            02926000
     p "FOPEN of output file 'LIST' failed";                            02928000
     p "FOPEN of $STDIN failed";                                        02930000
     p "You must have system manager capability to run RECOVER5";       02932000
     p "FOPEN of tape or serial disc file 'RECOVTP' failed";            02934000
     p "CONTROL-Y detected, do you wish to continue? ";                 02936000
     p "Is there another recovery tape available? ";                    02938000
     p "Is there a continuation tape for this file? ";                  02940000
     p "CONTROL-Y will be acknowleged at the end of this file";         02942000
     p "Error building pattern in paternmatch-name";                    02944000
     p "Error building pattern in paternmatch-group";                   02946000
     p "Error building pattern in paternmatch-account";                 02948000
     p "Exessive filesets ignored (10 accepted)";                       02950000
     p "Part too long";                                                 02952000
     p "Zero length part found";                                        02954000
     p "Found wildcard and either '$' or '*'";                          02956000
     p "First character of part may not be numeric";                    02958000
     p "Lockword may only follow the file part";                        02960000
     p "Too many periods were found, the maximum is two";               02962000
     p "A '*' was found, but it wasn't the first character";            02964000
     p "Both '$' and '*' may not be specified";                         02966000
     p "A '$' was found, but it wasn't the first character";            02968000
     p "An illegal character was found";                                02970000
     p "Needed parameters to the proc were missing";                    02972000
     p "Reenter all filesets";                                          02974000
     p "FWRITE to output file 'LIST' failed";                           02976000
     p "Mount and reply to tape or serial disc file 'RECOVTP'";         02978000
     p "The tape mounted doesn't contain the continuation of this file";02980000
     end;                                                               02982000
  end;                                                                  02984000
                                                                        02986000
if message'num >= 100 then                                              02988000
   begin   ! output message to file "LIST" and get file error.          02990000
   if message'num >= 200                                                02992000
      then print(io'buffer,-len,cctl)                                   02994000
      else fwrite(list'fnum,io'buffer,-len,0);                          02996000
   if <> then                                                           02998000
      begin                                                             03000000
      print'message(fwrite'list'error,list'fnum);                       03002000
      exit'program;                                                     03004000
      end;                                                              03006000
   if fnum'specified then                                               03008000
      begin                                                             03010000
      fcheck(fnum,error'code);                                          03012000
      ferrmsg(error'code,io'buffer,len);                                03014000
      fwrite(list'fnum,io'buffer,-len,0);                               03016000
      if <> then                                                        03018000
         begin                                                          03020000
         print'message(fwrite'list'error,list'fnum);                    03022000
         exit'program;                                                  03024000
         end;                                                           03026000
      end;                                                              03028000
   end                                                                  03030000
else                                                                    03032000
   begin   ! print the message, and possibly do file stuff.             03034000
   if message'num = banner then                                         03036000
      move io'buffer'b(vuuff'col) := official'vuuff;                    03038000
   print(io'buffer,-len,cctl);                                          03040000
   if <> then                                                           03042000
      terminate;                                                        03044000
   if fnum'specified then                                               03046000
      begin                                                             03048000
      fcheck(fnum,error'code);                                          03050000
      ferrmsg(error'code,io'buffer,len);                                03052000
      print(io'buffer,-len,0);                                          03054000
      if <> then                                                        03056000
         terminate;                                                     03058000
      end;                                                              03060000
   end;                                                                 03062000
end;                                                                    03064000
                                                                        03066000
$page "DUPLICATE'FILE"                                                  03068000
logical procedure duplicate'file;                                       03070000
                                                                        03072000
!-----------------------------------------------------------------------03074000
! if  the user wants to keep existing copies of his files (keeping'files03076000
! is  true)  then duplicate'file will be called to determine if the file03078000
! already exists.  if so, then print an appropriate error message.      03080000
!                                                                       03082000
! output variable:                                                      03084000
!    duplicate'file - true is a duplicate file exists, false otherwise. 03086000
!-----------------------------------------------------------------------03088000
                                                                        03090000
begin                                                                   03092000
integer                                                                 03094000
   dup'fnum;                                                            03096000
                                                                        03098000
duplicate'file := false;                                                03100000
dup'fnum := fopen(formdes,1,%10502,,,,,,,,,,flfilecode);                03102000
if dup'fnum <> 0 then                                                   03104000
   begin       ! the fopen succeeded, a duplicate file exists.          03106000
   fclose(dup'fnum,0,0);                                                03108000
   print'message(duplicate'file'error);                                 03110000
   duplicate'file := true;                                              03112000
   end;                                                                 03114000
end;                                                                    03116000
$page "GET'YES'NO"                                                      03118000
logical procedure get'yes'no(message'num);                              03120000
value message'num;                                                      03122000
integer message'num;                                                    03124000
                                                                        03126000
!-----------------------------------------------------------------------03128000
! this  procedure  prompts the user with the message number sent and ex-03130000
! pects a yes or no response.                                           03132000
!                                                                       03134000
! input variable:                                                       03136000
!    message'num - the message number to print.                         03138000
!                                                                       03140000
! output variable:                                                      03142000
!    get'yes'no  - true if the user responded with yes, false if no.    03144000
!-----------------------------------------------------------------------03146000
                                                                        03148000
begin                                                                   03150000
logical                                                                 03152000
  good'answer := false;                                                 03154000
                                                                        03156000
do begin   ! until a correct answer is given.                           03158000
   print'message(message'num,,nocrlf);                                  03160000
   len := fread(stdin'fnum,io'buffer,-5);                               03162000
   if len > 1 then                                                      03164000
      if io'buffer'b = "YES" or io'buffer'b = "yes" then                03166000
         begin                                                          03168000
         get'yes'no := yes;                                             03170000
         good'answer := true;                                           03172000
         end                                                            03174000
      else if io'buffer'b = "NO" or io'buffer'b = "no" then             03176000
         begin                                                          03178000
         get'yes'no := no;                                              03180000
         good'answer := true;                                           03182000
         end;                                                           03184000
   if not good'answer then                                              03186000
      print'message(answer'yes'no);                                     03188000
   end                                                                  03190000
until good'answer;                                                      03192000
end;                                                                    03194000
$page "EXIT'PROGRAM"                                                    03196000
procedure exit'program;                                                 03198000
                                                                        03200000
!-----------------------------------------------------------------------03202000
! this  procedure is called in emergency situations in which there is no03204000
! hope for recovery.  it closes the list and tape file and terminates.  03206000
!-----------------------------------------------------------------------03208000
                                                                        03210000
begin                                                                   03212000
fclose(list'fnum,1,0);                                                  03214000
if < then                                                               03216000
   print'message(list'fclose'error,list'fnum);                          03218000
fclose(tape'fnum,0,0);                                                  03220000
if < then                                                               03222000
   print'message(tape'fclose'error,tape'fnum);                          03224000
terminate;                      ! end this madness once and for all.    03226000
end;                                                                    03228000
$page "CONTROL"                                                         03230000
procedure control(function,msg'number);                                 03232000
value function,msg'number;                                              03234000
integer function,msg'number;                                            03236000
                                                                        03238000
!-----------------------------------------------------------------------03240000
! control  performs  fcontrol  functions  against the tape drive.  if an03242000
! error occurs, then print the message sent and exit the program.       03244000
!                                                                       03246000
! input variables:                                                      03248000
!    function - the fcontrol function to execute                        03250000
!    msg'number - if an error occurs, print this message.               03252000
!-----------------------------------------------------------------------03254000
                                                                        03256000
begin                                                                   03258000
fcontrol(tape'fnum,function,dummy);                                     03260000
if < then                                                               03262000
   begin                                                                03264000
   print'message(msg'number,tape'fnum);                                 03266000
   exit'program;                                                        03268000
   end;                                                                 03270000
end;                                                                    03272000
$page "CHANGE'JIT"                                                      03274000
procedure change'jit(group,account);                                    03276000
array group,account;                                                    03278000
                                                                        03280000
!-----------------------------------------------------------------------03282000
! due  to  a  design  feature  of mpe, users cannot create files accross03284000
! account  boundries,  even  if  they  have  all the capabilities in the03286000
! world.  therefore,  in order for recover5 to close files with the save03288000
! option  in  all groups and accounts, it must kludge the jit to reflect03290000
! the  current  file  being  saved.  therefore, right before the file is03292000
! to be closed, we change the group logon and account name in the jit to03294000
! be  that  of the current file being saved.  we them immediately change03296000
! it back to the original group logon and account.  during the time that03298000
! we are called from close'file, break and control-y will be disabled so03300000
! that  the  user  cannot get into trouble, ie. exiting the program with03302000
! his jit set to another group and account.                             03304000
!                                                                       03306000
! input global variable:                                                03308000
!    jit'dst - the data segment number of our job information table, ob-03310000
!    tained from the pcb global area in set'up'shop.                    03312000
!                                                                       03314000
! input variable:                                                       03316000
!    group & account - obviously, the group and account to place into   03318000
!    the jit.                                                           03320000
!-----------------------------------------------------------------------03322000
                                                                        03324000
begin                                                                   03326000
subroutine def'movetodseg;                                              03328000
                                                                        03330000
movetodseg(jit'dst,jit'account,@account,4);                             03332000
movetodseg(jit'dst,jit'logon'group,@group,4);                           03334000
end;                                                                    03336000
$page "CORRECTLABEL"                                                    03338000
logical procedure correct'file'label(label'address);                    03340000
value label'address;                                                    03342000
double label'address;                                                   03344000
                                                                        03346000
!-----------------------------------------------------------------------03348000
! correct'file'label changes the file label of the disc file just recov-03350000
! ered  back  to  the way it originally was.  we must patch back a whole03352000
! bunch of file label variables to their original state.  it first reads03354000
! the  old  file  label,  updates  the  new file label with the original03356000
! label's  data,  corrects  the  extent map  and writes the new improved03358000
! label back out.                                                       03360000
!                                                                       03362000
! input variable:                                                       03364000
!    label'address - the ldev and disc adress of the file's flab.       03366000
!-----------------------------------------------------------------------03368000
                                                                        03370000
begin                                                                   03372000
integer array                                                           03374000
   new'flab(0:127),                                                     03376000
   repl'extents'i(0:63);                                                03378000
double  array                                                           03380000
   repl'extents  (*) = repl'extents'i;                                  03382000
double pointer                                                          03384000
   new'extents;                                                         03386000
integer                                                                 03388000
   ldev,                                                                03390000
   p1 = label'address,                 ! ldev and hoda                  03392000
   fisir'return,                                                        03394000
   offset,                                                              03396000
   extent'num;                                                          03398000
                                                                        03400000
fisir'return := getsir(fisir);                                          03402000
ldev := p1.(0:8);                                                       03404000
p1.(0:8) := 0;                                                          03406000
if (flabio(ldev,label'address,read,new'flab) <> 0) then                 03408000
   begin   ! error reading the flab, report it and return.              03410000
   correct'file'label := failed;                                        03412000
   relsir(fisir,fisir'return);                                          03414000
   return;                                                              03416000
   end;                                                                 03418000
                                                                        03420000
move new'flab(12) := flab(12),(15);    ! 12-26                          03422000
new'flab(28).(0:3) := 0;               ! clear store/restore/load bits  03424000
move new'flab(29):= flab(29),(3);      ! 29-31                          03426000
move new'flab(36):= flab(36),(3);      ! 36-38                          03428000
move new'flab(42):= flab(42),(2);      ! 42-43                          03430000
move new'flab(108):= flab(108),(20);   ! 108-127                        03432000
                                                                        03434000
!-----------------------------------------------------------------------03436000
! here  we  must check the old flab to see if it had any extents missing03438000
! the  middle.  if it did, then we create a replacement extent map using03440000
! the  extent  map  from  the  new  file and form it as the old flab was03442000
! formed,  inserting  missing  extents in the same place as the old flab03444000
! with  the  new  extent  addresses in place of the old ones. below is a03446000
! diagram demonstrating possible extent map permutation.                03448000
!                                                                       03450000
!    old original             new              replacement              03452000
!    --------------      --------------      --------------             03454000
!    | old ext 1  |----->|  new ext 1 |----->| rep. ext 1 |             03456000
!    |------------|      |------------|      |------------|             03458000
!    | 0 (missing)| |--->|  new ext 2 |---|  | 0 (missing)|             03460000
!    |------------| |    |------------|   |  |------------|             03462000
!    | old ext 3  |-| |->|  new ext 3 |-| |->| rep. ext 3 |             03464000
!    |------------|   |  |------------| |    |------------|             03466000
!    | 0 (missing)|   |  |     0      | |    | 0 (missing)|             03468000
!    |------------|   |  |------------| |    |------------|             03470000
!    | old ext 5  |---|  |     0      | |--->| rep. ext 5 |             03472000
!    |------------|      |------------|      |------------|             03474000
!    ~            ~      ~            ~      ~            ~             03476000
!                                                                       03478000
!-----------------------------------------------------------------------03480000
                                                                        03482000
extent'num := offset := 0;                                              03484000
move repl'extents'i:=( 64(0) );                                         03486000
@new'extents := @new'flab(flextindex);                                  03488000
while (extent'num+offset <= flnumexts) do                               03490000
  begin                                                                 03492000
  if flabdbl(dflextindex+extent'num+offset) = 0d then                   03494000
     offset := offset +1                                                03496000
  else                                                                  03498000
     begin                                                              03500000
     repl'extents(extent'num+offset) := new'extents(extent'num);        03502000
     extent'num := extent'num +1;                                       03504000
     end;                                                               03506000
  end;                                                                  03508000
                                                                        03510000
move new'flab(flextindex) := repl'extents'i,((flnumexts+1)*2);          03512000
                                                                        03514000
if (flabio(ldev,label'address,write,new'flab) <> 0)                     03516000
   then correct'file'label := failed                                    03518000
   else correct'file'label := good;                                     03520000
relsir(fisir,fisir'return);                                             03522000
end;                                                                    03524000
$page "CLOSE'FILE"                                                      03526000
logical procedure close'file;                                           03528000
                                                                        03530000
!-----------------------------------------------------------------------03532000
! this  procedure closes the newly created file.  it checks on a variety03534000
! of possible error conditions. if the file already exists, and the user03536000
! does  not  want  to keep the old file, then purge the old file and re-03538000
! close  the  new.  we  disable break and control-y during the procedure03540000
! because  we  don't want the user exiting the program while his jit re-03542000
! flects  another  user's  group and account.  we will turn them back on03544000
! when the jit is changed back to the user's original group and account.03546000
!                                                                       03548000
! input global variable:                                                03550000
!    disc'fnum - file number of the newly created file.                 03552000
!                                                                       03554000
! output variable:                                                      03556000
!   close'file - failed if an error occured.                            03558000
!                good  if everything went a-ok.                         03560000
!-----------------------------------------------------------------------03562000
                                                                        03564000
begin                                                                   03566000
integer                                                                 03568000
   old'fnum,                                                            03570000
   error'code;                                                          03572000
                                                                        03574000
close'file := good;    ! assume successful completion.                  03576000
fcontrol(stdin'fnum,disable'break,dummy);                               03578000
xcontrap(0,dummy);                                                      03580000
change'jit(flgrpname,flacctname);                                       03582000
fclose(disc'fnum,1,0); ! attempt to close the file with the save option.03584000
if < then              ! oh, oh, the fclose save failed.                03586000
   begin                                                                03588000
   fcheck(disc'fnum,error'code);                                        03590000
   if error'code=100 and notkeep then                                   03592000
      begin            ! ok, purge the old file, save the new.          03594000
      old'fnum := fopen(formdes,1,%10502,,,,,,,,,,flfilecode);          03596000
      if < then        ! damn, fopen of old for purge failed.           03598000
         begin         ! let the user know about the failure.           03600000
         print'message(fopen'existing'file'error,old'fnum);             03602000
         fclose(disc'fnum,0,0);     ! new file gone!                    03604000
         close'file := failed;      ! report error.                     03606000
         end                                                            03608000
      else             ! old file fopened, now fclose w/ purge.         03610000
         begin                                                          03612000
         fclose(old'fnum,4,0);                                          03614000
         if = then                                                      03616000
            begin      ! file purged ok, close new file save.           03618000
            fclose(disc'fnum,1,0);                                      03620000
            if < then                                                   03622000
               begin   ! this should never, ever happen.                03624000
               print'message(fclose'error,disc'fnum);                   03626000
               close'file := failed;                                    03628000
               end;                                                     03630000
            end                                                         03632000
         else                                                           03634000
            begin      ! error purging the existing file.               03636000
            print'message(purge'error,disc'fnum);                       03638000
            fclose(disc'fnum,0,0);  ! new file is gone, deleted kapoot. 03640000
            fclose(old'fnum,0,0);   ! try closing it with default disp. 03642000
            close'file := failed;   ! report error.                     03644000
            end;                                                        03646000
         end;                                                           03648000
      end                                                               03650000
   else                                                                 03652000
     begin         ! other fclose failure, alert user.                  03654000
     print'message(fclose'error,disc'fnum);                             03656000
     fclose(disc'fnum,0,0);         ! close new file, gone!             03658000
     close'file := failed;          ! report error.                     03660000
     end;                                                               03662000
   end;                                                                 03664000
change'jit(logon'group,logon'account);                                  03666000
fcontrol(stdin'fnum,enable'break,dummy);                                03668000
xcontrap(@controly,dummy);                                              03670000
end;                                ! close'file procedure.             03672000
$page "PROCESS'FILE'EOF"                                                03674000
procedure process'file'eof;                                             03676000
                                                                        03678000
!-----------------------------------------------------------------------03680000
! this procedure does the necessary processing to save a disc file after03682000
! it  has  been read in. it closes the new disc file for save via close'03684000
! 'file.  if that is successfull, it corrects the file label of the file03686000
! to reflect the correct information.                                   03688000
!-----------------------------------------------------------------------03690000
                                                                        03692000
begin                                                                   03694000
double                                                                  03696000
   label'address;             ! disk address of the flab.               03698000
                                                                        03700000
ffileinfo(disc'fnum,19,label'address);                                  03702000
if <> or label'address = 0d then                                        03704000
   print'message(ffileinfo'error,disc'fnum)                             03706000
else if close'file then                                                 03708000
   begin                      ! the fclose was successful.              03710000
   if correct'file'label(label'address)                                 03712000
      then print'message(successful'recovery)                           03714000
      else print'message(flab'io'error);                                03716000
   end;                                                                 03718000
end;                                                                    03720000
$page "READ'FILE'FROM'TAPE - Declaration and SUBROUTINE ERROR"          03722000
procedure read'file'from'tape(record'len,tape'pntr);                    03724000
value record'len,tape'pntr;                                             03726000
integer record'len;                                                     03728000
integer pointer tape'pntr;                                              03730000
!-----------------------------------------------------------------------03732000
! this  procedure reads records from tape and writes to the current file03734000
! until  eof  is encountered on the tape.  it is called from recover'all03736000
! files  in  two  cases.  the first is to simply read in the user labels03738000
! and  data  from  a  normal file on tape.  the second is to continue to03740000
! read in a "continuation" file, ie. only data will be present.         03742000
!                                                                       03744000
! input variable:                                                       03746000
!    record'len - if  this  is  a  continuation file, than this variable03748000
!    will  have  the  value  0 because the indication for a continuation03750000
!    file  is  a  12 word record with the file, group & account.  with a03752000
!    a  normal file, this variable will have the value of the first tape03754000
!    record  (usually 4096 words, unless we have a very small file) less03756000
!    128 words for the flab.                                            03758000
!                                                                       03760000
!    tape'pntr - pointer to the area in the tape buffer to start to use.03762000
!    if  record'len <> 0 then this will have the value of @tape'buffer +03764000
!    128 (since we skip over the flab).                                 03766000
!                                                                       03768000
! output global variable:                                               03770000
!    continuation - sets this to true if it encounters a file that spans03772000
!    more than one reels of tape.                                       03774000
!-----------------------------------------------------------------------03776000
                                                                        03778000
begin                                                                   03780000
logical                                                                 03782000
   done := false;                                                       03784000
byte pointer                                                            03786000
   tape'pntr'b;                                                         03788000
                                                                        03790000
subroutine error(msg'number);                                           03792000
value msg'number;                                                       03794000
integer msg'number;                                                     03796000
                                                                        03798000
!-----------------------------------------------------------------------03800000
! this  subroutine is called if an error is encountered while writing to03802000
! the  disc file.  it prints an error message and skips to the next file03804000
! on  the  tape.  it then performs the final processing of the file like03806000
! an  eof has been reached to salvage what we can.  this is done via the03808000
! procedure process'file'eof.                                           03810000
!-----------------------------------------------------------------------03812000
                                                                        03814000
begin                                                                   03816000
print'message(msg'number,disc'fnum);                                    03818000
control(forward'space'file,tape'fsf'error);                             03820000
process'file'eof;                                                       03822000
assemble(exit 0);                                                       03824000
end;                                                                    03826000
$page "READ'FILE'FROM'TAPE - Outer block "                              03828000
do begin      ! until we hit then end of the tape or an error occurs.   03830000
   if record'len > 0 then                                               03832000
      begin   ! normal processing, lets do it.                          03834000
      if sect'offset'data > 0 then                                      03836000
         begin                  ! need to write ulabs?                  03838000
         while sect'offset'data > 0 and record'len > 0 do               03840000
            begin               ! possible write ulabs.                 03842000
            if num'ulabs > 0 then                                       03844000
               begin            ! definetely have ulabs.                03846000
               fwritelabel(disc'fnum,tape'pntr,128,fllbl-num'ulabs);    03848000
               if < then error(ulab'write'error);                       03850000
               if > then error(too'many'ulabs);                         03852000
               num'ulabs := num'ulabs - 1;                              03854000
               end;                                                     03856000
            sect'offset'data := sect'offset'data - 1;                   03858000
            @tape'pntr := @tape'pntr + 128;                             03860000
            record'len := record'len - 128;                             03862000
            end;   ! of while loop.                                     03864000
         end;   ! of if clause.                                         03866000
                                                                        03868000
      if record'len > 0 then                                            03870000
         begin  ! write the rest of the buffer mr, nobuf in one shot    03872000
         fwrite(disc'fnum,tape'pntr,record'len,0);                      03874000
         if < then error(data'write'error);                             03876000
         if > then error(too'many'data'records);                        03878000
         end;                                                           03880000
      end;   ! of normal processing if clause.                          03882000
                                                                        03884000
   ! now read the next block from tape into the buffer and continue.    03886000
                                                                        03888000
   continuation := false;                                               03890000
   @tape'pntr := @tape'buffer;                                          03892000
   @tape'pntr'b := @tape'pntr * 2;                                      03894000
   record'len := fread(tape'fnum,tape'pntr,tape'rec'size);              03896000
   if > then                                                            03898000
      begin   ! eof encountered, process it and leave.                  03900000
      process'file'eof;                                                 03902000
      done := true;                                                     03904000
      end                                                               03906000
   else if < then                                                       03908000
      begin   ! tape read error, attempt to skip bad file.              03910000
      print'message(tape'data'read'error,tape'fnum);                    03912000
      control(forward'space'file,tape'fsf'error);                       03914000
      done := true;             ! done with this file.                  03916000
      end                                                               03918000
   else if record'len = 4 and tape'pntr'b = continuation'record then    03920000
      begin   ! continuation file, will ask for next tape.              03922000
      continuation := true;     ! set global flag.                      03924000
      done := true;                                                     03926000
      print'message(file'continuation);                                 03928000
      end;                                                              03930000
   end  ! of do loop.                                                   03932000
until done;                                                             03934000
end; ! of read'file'from'tape.                                          03936000
$page "FOPEN'FILE"                                                      03938000
logical procedure fopen'file;                                           03940000
                                                                        03942000
!-----------------------------------------------------------------------03944000
! this  procedure  performs the fopen of the disc file based on the info03946000
! found  in  the  flab  just  read  from tape.  we fopen the file with a03948000
! record  size  of 128 words and a blocking factor of the number of sec-03950000
! tors  per  block.  the  special entry point ropen has been implemented03952000
! for recover5 to patch the block size to 1 sector and the blocking fac-03954000
! tor  to 1 so that we can write to the file unbuffered, multi-record in03956000
! increments of one sector.  when we write to the file, we will "stream"03958000
! the  file, which means that the file system will perform the entire 4k03960000
! transfer  in as little as a single i/o, depending on extent boundries.03962000
! this will greatly increase the performance of recover5.               03964000
!                                                                       03966000
! output global variables:                                              03968000
!                                                                       03970000
!    sect'offset'data - number of sectors from flab to file's data      03972000
!    num'ulabs        - the number of user labels to be written         03974000
!-----------------------------------------------------------------------03976000
                                                                        03978000
begin                                                                   03980000
integer                                                                 03982000
   sectors'per'block;                                                   03984000
double                                                                  03986000
   num'data'sectors;                  ! number of data sectors in file. 03988000
                                                                        03990000
fopen'file := failed;                 ! assume failure.                 03992000
sectors'per'block := (flblksize+127)/128;                               03994000
num'ulabs := fllbl;                                                     03996000
num'data'sectors := (dbl(flnumexts) * dbl(flextsize)) +                 03998000
                    dbl(fllastextsize) - dbl(flsectoff);                04000000
sect'offset'data  := flsectoff - 1;   ! less one for flab.              04002000
                                                                        04004000
disc'fnum := ropen(formdes,%2000,%421,,,,num'ulabs,sectors'per'block,,  04006000
              num'data'sectors,flnumexts+1,,flfilecode);                04008000
if <                                                                    04010000
   then print'message(disc'fopen'error,disc'fnum)                       04012000
   else fopen'file := good;                                             04014000
end;                                                                    04016000
$page "RECOVER'FILE"                                                    04018000
logical procedure recover'file;                                         04020000
                                                                        04022000
!-----------------------------------------------------------------------04024000
! this  procedure  determines  if  a file is to be recovered or not.  it04026000
! checks  out  all the file lists to see if the current file being exam-04028000
! ined on tape matches the list of files supplied by the user.  finally,04030000
! if  the keep option has been specified, it determines if a file of the04032000
! same name already exists.  if all the files specified have been found,04034000
! then we exit the program.                                             04036000
!                                                                       04038000
! output variables:                                                     04040000
!    recover'file - if all criteria is met, then true else false.       04042000
!-----------------------------------------------------------------------04044000
                                                                        04046000
begin                                                                   04048000
recover'file := false;    ! assume that the file is not to be recovered.04050000
if not got'wild and num'strict = 0 and keep'some then                   04052000
   exit'program;          ! all specified files recovered, no wild cards04054000
                                                                        04056000
if keep'some and not matches'list then                                  04058000
   return;                                                              04060000
                                                                        04062000
num'strict := num'strict - 1;                                           04064000
                                                                        04066000
if keeping'files and duplicate'file then                                04068000
   return;                ! a duplicate file exists.                    04070000
                                                                        04072000
recover'file := true;     ! all criteria is met, recover that file.     04074000
end;                                                                    04076000
$page "ANOTHER'TAPE"                                                    04078000
procedure another'tape(message'num);                                    04080000
value message'num;                                                      04082000
integer message'num;                                                    04084000
                                                                        04086000
!-----------------------------------------------------------------------04088000
! this  procedure  outputs a message to the user and them prompts him to04090000
! determine  if another tape is available.  it is called when the end of04092000
! a  reel  has been it or if the user mounts the wrong tape when contin-04094000
! uing.  if  the user ever signifies that another tape is not available,04096000
! we will exit the program.                                             04098000
!                                                                       04100000
! input variable:                                                       04102000
!    message'num - the message number to print before the prompt.       04104000
!-----------------------------------------------------------------------04106000
                                                                        04108000
begin                                                                   04110000
logical                                                                 04112000
  answer;      ! yes or no?                                             04114000
                                                                        04116000
control(rewind'unload,tape'rewind'unload'error);                        04118000
                                                                        04120000
answer := get'yes'no(message'num);                                      04122000
if answer = no                                                          04124000
   then exit'program                                                    04126000
   else print'message(mount'new'tape);                                  04128000
end;                                                                    04130000
$page "TAPE'ERROR'RECOVERY"                                             04132000
procedure tape'error'recovery(num'tape'errors);                         04134000
integer num'tape'errors;                                                04136000
                                                                        04138000
!-----------------------------------------------------------------------04140000
! this  procedure  attempts  to  recover from an error while reading the04142000
! file  label  block from tape.  it outputs a message and checks a coun-04144000
! ter. if 5 read errors have occured in a row, then we exit the program.04146000
! if the forward space file fails, we also exit the program.            04148000
!                                                                       04150000
! input variables:                                                      04152000
!    num'tape'errors - an  integer by reference containing the number of04154000
!    consecutive read errors encountered.  again, if the magic number of04156000
!    5 it hit, then rip this joint.                                     04158000
!-----------------------------------------------------------------------04160000
                                                                        04162000
begin                                                                   04164000
print'message(tape'read'error,tape'fnum);                               04166000
num'tape'errors := num'tape'errors + 1;                                 04168000
if num'tape'errors > 4 then                                             04170000
   begin                                                                04172000
   print'message(catastrophic'tape'error);                              04174000
   exit'program;                                                        04176000
   end                                                                  04178000
else                                                                    04180000
   control(forward'space'file,tape'fsf'error);                          04182000
end;                                                                    04184000
$page "GET'FILE'LIST"                                                   04186000
procedure get'file'list;                                                04188000
                                                                        04190000
!-----------------------------------------------------------------------04192000
! this procedure prompts the user for a list of the file sets to attempt04194000
! to  recover.  it  then  asks  the user if he wants to to keep existing04196000
! copies of the files.                                                  04198000
!                                                                       04200000
! output global variable:                                               04202000
!    notkeep - true if the user does not want to keep existing copies.  04204000
!-----------------------------------------------------------------------04206000
                                                                        04208000
begin                                                                   04210000
logical                                                                 04212000
   answer,                   ! true = yes, false = no.                  04214000
   done := true;                                                        04216000
                                                                        04218000
do begin   ! until the user gives a legal list of files.                04220000
   print'message(enter'fileset);                                        04222000
   print'message(terminate'list);                                       04224000
   print'message(prompt,,nocrlf);                                       04226000
   len := fread(stdin'fnum,io'buffer,-80);                              04228000
   move io'buffer'b(len) := cr;                                         04230000
   scan io'buffer'b while "  ",1;                                       04232000
   @start := tos;                                                       04234000
   if start = cr or start = "@.@.@" then                                04236000
      done := true                                                      04238000
   else                                                                 04240000
      begin                                ! get a real list.           04242000
      move list'pt := io'buffer'b,(len),2; ! copy input list.           04244000
      move * := " ",2;                     ! blank the end of the list. 04246000
      @list'pt := tos - 1;                 ! points to end of list.     04248000
      @end'of'list := @list'pt;                                         04250000
      do begin                                                          04252000
         print'message(prompt,,nocrlf);                                 04254000
         len := fread(stdin'fnum,io'buffer,-80);                        04256000
         move io'buffer'b(len) := cr;                                   04258000
         scan io'buffer'b while "  ",1;                                 04260000
         @start := tos;                                                 04262000
         if start = cr then len := 0;                                   04264000
         if @list'pt <> @file'list then                                 04266000
            move list'pt := ",";                                        04268000
         move list'pt(1) := io'buffer'b,(len),2;                        04270000
         @list'pt := tos ;                                              04272000
         end                                                            04274000
      until len = 0;                                                    04276000
      @end'of'list := @list'pt(-1);                                     04278000
      end'of'list := %0;           ! null eol                           04280000
      print'message(blank'line);                                        04282000
                                                                        04284000
      if not check'list then                                            04286000
         done := false                                                  04288000
      else                                                              04290000
         begin                                                          04292000
         keep'some := true;                                             04294000
         done := true;                                                  04296000
         end;                                                           04298000
      end;  ! of blank line or @.@.@ was entered.                       04300000
   end   ! of until done.                                               04302000
until done;                                                             04304000
                                                                        04306000
! now prompt the user to see if he wants to keep existing files.        04308000
                                                                        04310000
answer := get'yes'no(keep'files);                                       04312000
if answer = no                                                          04314000
   then notkeep := true                                                 04316000
   else notkeep := false;                                               04318000
end;                                                                    04320000
$page "SET'UP'SHOP"                                                     04322000
procedure set'up'shop;                                                  04324000
                                                                        04326000
!-----------------------------------------------------------------------04328000
! this  procedure  does  some  initialization  needed to set up the work04330000
! environment.  it  prints  the  banner, checks if we are running on the04332000
! correct  system  and opens the list files. it then obtains the list of04334000
! file  sets   to recover.  finally, it opens the mag tape file, fetches04336000
! the jit dst from the pxglobal area and arms the control-y trap.       04338000
!-----------------------------------------------------------------------04340000
                                                                        04342000
begin                                                                   04344000
integer pointer                                                         04346000
   pcb = 3;                  ! sysglobal relative pointer to the pcb.   04348000
integer                                                                 04350000
   pcbglobloc;               ! q relative offset to pcbx global area.   04352000
double                                                                  04354000
   capabilities;             ! user capability mask.                    04356000
logical                                                                 04358000
   mode,                     ! users mode, interactive or duplicative.  04360000
   capabilities1 = capabilities;                                        04362000
define                                                                  04364000
   pcb'size            = pcb(1)#,                                       04366000
   mpev'pcb'size       = %25#,                                          04368000
   mode'interactive    = mode.(15:1)#,                                  04370000
   system'manager'cap  = capabilities1.(0:1)#;                          04372000
                                                                        04374000
print'message(banner);                                                  04376000
if pcb'size <> mpev'pcb'size then                                       04378000
   begin   ! not the correct version of mpe, rip this joint.            04380000
   print'message(invalid'mpe'version);                                  04382000
   terminate;                                                           04384000
   end;                                                                 04386000
                                                                        04388000
list'fnum := fopen(list'name,%14,1);                                    04390000
if <> then                                                              04392000
   begin   ! list file open failed, split city.                         04394000
   print'message(listfile'fopen'error,list'fnum);                       04396000
   terminate;                                                           04398000
   end;                                                                 04400000
                                                                        04402000
stdin'fnum := fopen(,%41,0);                                            04404000
if < then                                                               04406000
   begin   ! stdin file open failed, split city.                        04408000
   print'message(stdin'fopen'error,stdin'fnum);                         04410000
   terminate;                                                           04412000
   end;                                                                 04414000
                                                                        04416000
! obtain the original group and account, mode and capabilties.          04418000
                                                                        04420000
who(mode,capabilities,,,logon'group,logon'account);                     04422000
if not system'manager'cap then                                          04424000
   begin   ! user does not have system manager capability, kill him.    04426000
   print'message(user'lacks'sm'cap);                                    04428000
   terminate;                                                           04430000
   end;                                                                 04432000
                                                                        04434000
! get the list of file sets to recover and open tape file.              04436000
                                                                        04438000
if mode'interactive then                                                04440000
   get'file'list;                                                       04442000
                                                                        04444000
print'message(open'tape'file);                                          04446000
tape'fnum := fopen(tape'name,%200,%400,tape'rec'size,default'device);   04448000
if < then                                                               04450000
   begin                                                                04452000
   print'message(tape'fopen'error,tape'fnum);                           04454000
   terminate;                                                           04456000
   end;                                                                 04458000
                                                                        04460000
pxglobal;                   ! set pcbglobloc for pxglobal defines.      04462000
jit'dst := pxg'jitdst;      ! save jit'dst for kludge.                  04464000
                                                                        04466000
xcontrap(@controly,dummy);  ! enable the control-y trap procedure.      04468000
end;                                                                    04470000
$page "CHECK'CONTROLY"                                                  04472000
procedure check'controly;                                               04474000
                                                                        04476000
!-----------------------------------------------------------------------04478000
! this  procedure  checks  to  see if control-y has been hit.  if so, it04480000
! promts  the user to determine if he wants to continue or not.  if not,04482000
! we exit the program.                                                  04484000
!                                                                       04486000
! global input variable:                                                04488000
!    control'y'detected - set to true when controly trap is entered.    04490000
!-----------------------------------------------------------------------04492000
                                                                        04494000
begin                                                                   04496000
logical                                                                 04498000
   answer;                                                              04500000
                                                                        04502000
if control'y'detected then                                              04504000
   begin                                                                04506000
   answer := get'yes'no(control'y'continue);                            04508000
   if answer = no then                                                  04510000
      exit'program;                                                     04512000
   end;                                                                 04514000
control'y'detected := false;                                            04516000
end;                                                                    04518000
$page "PARSE'FORMAL'DESIGNATOR"                                         04520000
procedure parse'formal'designator(flab);                                04522000
integer array flab;                                                     04524000
                                                                        04526000
!-----------------------------------------------------------------------04528000
! this procedure will parse the file label name into a formal designator04530000
! used  by fopen  and a  file name used by the message procedure.  it is04532000
! important  that  the  delimiter of formdes  is  a  blank   because the04534000
! procedure display'to'standard expects it that way.                    04536000
!                                                                       04538000
! input variable:                                                       04540000
!    flab - an array containing the file label.                         04542000
!                                                                       04544000
! output global variables:                                              04546000
!    file'name - in the form file.group.account for message procedure   04548000
!    formdes   - in the form file/lock.group.account for fopen          04550000
!-----------------------------------------------------------------------04552000
                                                                        04554000
begin                                                                   04556000
byte array temp(0:35);                                                  04558000
                                                                        04560000
move file'name := (26 (" "));                                           04562000
                                                                        04564000
move file'name     := flab'b    ,(8);   ! file name                     04566000
move file'name(8)  := ".";                                              04568000
move file'name(9)  := flab'b(8) ,(8);   ! group name                    04570000
move file'name(17) := ".";                                              04572000
move file'name(18) := flab'b(16),(8);   ! account name                  04574000
                                                                        04576000
move temp    := (36 (" "));                                             04578000
move formdes := (36 (" "));                                             04580000
                                                                        04582000
move temp     := flab'b    ,(8);        ! file name                     04584000
move temp(9)  := flab'b(8) ,(8);        ! group name                    04586000
move temp(18) := flab'b(16),(8);        ! account name                  04588000
move temp(27) := flab'b(32),(8);        ! lock word                     04590000
                                                                        04592000
                                                                        04594000
move formdes := temp while an,1;        ! file name                     04596000
if temp(27) <> " " then                                                 04598000
   begin                                ! a lock word exists            04600000
   move * := "/",2;                                                     04602000
   move * := temp(27) while an,1;       ! move it in                    04604000
   end;                                                                 04606000
move * := ".",2;                                                        04608000
move * := temp(9)  while an,1;          ! group name                    04610000
move * := ".",2;                                                        04612000
move * := temp(18) while an,1;          ! account name                  04614000
move * := " ";                          ! delimiter                     04616000
end;                                                                    04618000
$page "RECOVER'ALL'FILES"                                               04620000
procedure recover'all'files;                                            04622000
                                                                        04624000
!-----------------------------------------------------------------------04626000
! this  procedure  controls  all  the  file recovery.  it reads the file04628000
! label  block, determines what needs to be done, ie. continuation file,04630000
! normal recovery or skip the current file.                             04632000
!                                                                       04634000
! global input variable:                                                04636000
!    continuation - set by read'file'from'tape if a file spans more than04638000
!    one reel of tape.                                                  04640000
!-----------------------------------------------------------------------04642000
                                                                        04644000
begin                                                                   04646000
logical                                                                 04648000
   skip'file;        ! set to true if we have to skip over current file.04650000
integer                                                                 04652000
   record'len,       ! length of first record read.                     04654000
   num'read'errors;  ! if numerous read errors encountered, then quit.  04656000
integer pointer                                                         04658000
   tape'pntr;        ! current location of tape pointer in buffer.      04660000
byte pointer                                                            04662000
   tape'pntr'b;                                                         04664000
                                                                        04666000
do begin             ! until all the requested files are found.         04668000
   check'controly;   ! if user wants to quit, we may never return.      04670000
   skip'file := false;                                                  04672000
   @tape'pntr := @tape'buffer;                                          04674000
   @tape'pntr'b := @tape'pntr * 2;                                      04676000
   record'len := fread(tape'fnum,tape'pntr,tape'rec'size);              04678000
   if < then                                                            04680000
      tape'error'recovery(num'read'errors)                              04682000
   else if > then                                                       04684000
      begin                  ! ask the user for another tape, if none is04686000
      if continuation        ! available, then we will not return.      04688000
         then another'tape(ask'continuation'tape)                       04690000
         else another'tape(ask'another'tape);                           04692000
      end                                                               04694000
   else                                                                 04696000
      begin                  ! successful read of 1st. block, what's up?04698000
      num'read'errors := 0;  ! reset the error counter.                 04700000
      if continuation then                                              04702000
         begin               ! this is a continution file, read rest.   04704000
         if record'len = cont'size and tape'pntr'b = flab'b,(24) then   04706000
            begin            ! the correct tape was mounted, read it.   04708000
            record'len := 0;                                            04710000
            read'file'from'tape(record'len,tape'pntr);                  04712000
            end                                                         04714000
         else                                                           04716000
            begin            ! wrong continuation tape has been mounted.04718000
            print'message(tape'continuation'error);                     04720000
            another'tape(ask'continuation'tape);                        04722000
            end;                                                        04724000
         end                                                            04726000
      else if record'len = cont'size then                               04728000
         skip'file := true   ! continuation file, skip over it.         04730000
      else                                                              04732000
         begin               ! a normal file, do the needed processing. 04734000
         move flab := tape'pntr,(128);       ! important, save the flab.04736000
         parse'formal'designator(flab);                                 04738000
         display'to'standard(formdes'ptr,formdes'std'ptr,error,         04740000
                                                          char'inx);    04742000
         if not recover'file or not fopen'file then                     04744000
            skip'file := true                                           04746000
         else                                                           04748000
            begin            ! we want it and it opened without error.  04750000
            record'len := record'len - 128;  ! compensate for flab.     04752000
            @tape'pntr := @tape'pntr + 128;                             04754000
            read'file'from'tape(record'len,tape'pntr);                  04756000
            end;                                                        04758000
         end;                                                           04760000
                                                                        04762000
      if skip'file then                                                 04764000
         control(forward'space'file,tape'fsf'error);                    04766000
      end;   ! of successful read of file label block.                  04768000
   end   ! of do forever.                                               04770000
until false;                                                            04772000
end;                                                                    04774000
$page "Outer block"                                                     04776000
set'up'shop;                                                            04778000
recover'all'files;                                                      04780000
end.                                                                    04782000
