{Magnetic tape backup program for APM filestores - RWT March 1987}

%option "-low-nons-nocheck"
%include "inc:util.imp"
%include "inc:fs.imp"
%include "inc:crc.imp"
%constinteger cr=13

%begin

! Management parameters

%integer filestore = 1976 {1976 or 1986 technology}

%string(255)-
  dir   = "*",  nodir   = "",
  file  = "*",  nofile  = "*.MOB,*.LIS",
  perm  = "",   noperm  = ""
%string(31)-
  logfile  = "",
  errfile = "ERROR.LOG",
  since    = ""
%integer dummy=0

! End of parameters

%routine error line
! We may be at the beginning of a log line, so clear it
! prior to putting out an error message
  spaces(80); printsymbol(cr)
  set terminal mode(0)
%end

! Robustified filestore comms start here

%integerfn transact(%bytename b,%integer size)
! Send buffer at B of length SIZE to filestore,
! and receive reply into the same buffer,
! returning its length as result.
%integer timer,bit=1<<lsap
  %cycle
    %cycle
      etherwrite(lsap,b,size)
      timer = cputime+20000
      %cycle
      %repeatuntil ack&bit#0 %or cputime>timer
      %if ack&bit=0 %start
        ack = ack!bit
        error line
        printstring("ACK timeout"); newline
        %continue
      %finish
      %exitif nak&bit=0
      nak = nak!!bit
      error line
      printstring("NAK"); newline
    %repeat
    timer = cputime+20000
    %cycle
      %result = etherread(lsap,b,532) %if dtx&bit#0
    %repeatuntil cputime>timer
    errorline
    printstring("DTX timeout"); newline
  %repeat
%end

%bytemap hdhex(%bytename b,%integername n)
! Read HDhex number at B into N.
! Result is B advanced past the terminator.
  n = 0
  %while b>='0' %cycle
    n = n<<4-'0'+b; b == b[1]
  %repeat
  %result == b[1]
%end

%string(19)%fn datetime
%bytearray bb(1:532)
%string(*)%name s
%bytename b
%integer len
x1:
  s == string(addr(bb(1))); b == length(s)
  s = "G0".tostring(nl)
  b = transact(b[1],b)-1
x2:
  %signal 3,3,,s %if b[1]='-'
  b == hdhex(b[1],len)
{}%if 15#len#18 %start
{}  errorline
{}  printstring("Dodgy date ")
{}  space %and phex2(bb(len)) %for len = 1,1,20
{}  len = cputime+10000
{}  %cycle; %repeatuntil cputime>=len
{}  space; phex1(dtx>>lsap&1); newline
{}  ->x1 %if dtx>>lsap&1=0
{}  b == length(s); b = etherread(lsap,b[1],532)-1
{}  ->x2
{}%finish
  b[-1] = len
  s == string(addr(b[-1]))
  %result = s
%end

%string(255)%fn ninfo(%string(255)filename)
%bytearray bb(1:532)
%string(*)%name s
%bytename b
%integer len
x1:
  s == string(addr(bb(1))); b == length(s)
  s = "N0".filename.tostring(nl)
  b[2] = userno+'0'
  b = transact(b[1],b)-1
  %signal 3,3,,s %if b[1]='-'
  b == hdhex(b[1],len)
  b[-1] = len
  s == string(addr(b[-1]))
  %result = s
%end

%routine openr(%string(255)file,%integername xno,size)
%bytearray bb(1:532)
%string(*)%name s
%integer blocks,pad
%bytename b
  s == string(addr(bb(1)))
  s = "S0".file.tostring(nl)
  b == bb(2)
  b[1] = userno+'0'
  b[-1] = transact(b,b[-1])-1
  %signal 3,3,,s %if b='-'
  b == hdhex(b,xno)
  b == hdhex(b,blocks)
  b == hdhex(b,pad)
  size = blocks<<9-pad
%end

%routine close(%integer xno)
%bytearray bb(1:532)
%string(*)%name s
%bytename b
  s == string(addr(bb(1)))
  s = "K0".tostring(nl)
  b == charno(s,1)
  b[1] = xno+'0'
  b[-1] = transact(b,b[-1])-1
  %signal 3,3,,s %if b='-'
%end

%routine readblock(%integer xno,bytes,%integername pos,%bytename buf)
%bytearray bb(1:532)
%integer amount,p
%bytename b
  %routine addhex(%integer k)
    addhex(k>>4) %and k = k&15 %if k>47
    b[p] = k+'0'
    p = p+1
  %end
  %returnunless pos&511=0
  %cycle
    b == bb(1)
    b = 'R'
    b[1] = xno+'0'
    p = 2; addhex(pos>>9)
    b[p] = nl
    amount = transact(b,p+1)
    %if b='-' %start
      b = amount-2; %signal 3,4,b[1]-'0',string(addr(b))
    %finish
    b == hdhex(b,amount)
    %returnif amount=0
    *move.l b,a0
    *move.l buf,a1
    *moveq #-1,d0
    *add.l amount,d0  
loop: *move.b (a0)+,(a1)+
    *dbra d0,loop
    bytes = bytes-amount; pos = pos+amount; buf == buf[amount]
    %returnif bytes<=0 %or amount<512
  %repeat
%end

%routine connectfile(%string(255)file,%integer mode,%integername start,size)
%integer xno,pos
  openr(file,xno,size)
  start = heapget(size)
  pos = 0
  readblock(xno,size,pos,byte(start))
  close(xno)
%end

%routine openw(%string(255)file,%integername xno)
%bytearray bb(1:532)
%string(*)%name s
%integer blocks,pad
%bytename b
  s == string(addr(bb(1)))
  s = "T0".file.tostring(nl)
  b == charno(s,1)
  b[1] = userno+'0'
  b[-1] = transact(b,b[-1])-1
  %signal 3,3,,s %if b='-'
  b == hdhex(b,xno)
%end

%routine writeblock(%integer xno,bytes,%integername pos,%bytename buf)
%bytearray bb(1:532)
%integer amount,p
%bytename b
  %routine addhex(%integer k)
    addhex(k>>4) %and k = k&15 %if k>47
    b[p] = k+'0'
    p = p+1
  %end
  %returnif bytes=0
  %signal 3,4,,"not at block boundary" %unless pos&511=0
  %signal 3,4,,"multiblock write" %if bytes>512
  b == bb(1)
  b = 'W'; b[1] = xno+'0'; p = 2; addhex(pos>>9)
  b[p] = ','; p = p+1; addhex(bytes); b[p] = nl
  *move.l p,d0
  *move.l b,a1
  *move.l buf,a0
  *lea 1(a1,d0),a1
  *moveq #-1,d0
  *add.l bytes,d0
loop: *move.b (a0)+,(a1)+
  *dbra d0,loop
  amount = transact(b,p+1+bytes)
  pos = pos+bytes
%end

%recordformat output file fm(%integer buf,pos,bytes,xno)
%record(output file fm)%name curout

%routine selectout(%record(output file fm)%name r)
  curout == r
%end

%routine openout(%string(255)file)
  curout = 0
  openw(file,curout_xno)
  curout_buf = heapget(512)
%end

%routine flushout
  %returnif curout_bytes=0
  writeblock(curout_xno,curout_bytes,curout_pos,byte(curout_buf))
  curout_bytes = 0
%end

%routine closeout
  flushout
  close(curout_xno); curout_xno = 0
  heapput(curout_buf)
%end

%routine putsym(%integer k)
  byte(curout_buf+curout_bytes) = k
  curout_bytes = curout_bytes+1
  flushout %if curout_bytes=512
%end

%routine putstring(%string(255)s)
%integer i
  putsym(charno(s,i)) %for i = 1,1,length(s)
%end

%record(output file fm)err=0,log=0

! Robustified filestore comms end here

%string(31)%fn combine(%string(*)%name d,t)
! Combine date and time strings into a single "DD/MM/YY:hh.mm.ss".
%string(31)dt
  dt = d.":".t
  dt = dt.".00" %if filestore=1976
  %result = dt
%end

%string(31)%fn now
! Ask filetore for the date and time, then combine them into a "standard" form.
%string(31)dt,d,t
  dt = datetime; dt -> d.("  ").t
  %result = combine(d,t)
%end

! Tape handling starts here

! The tape format looks like this:
!
! First, a "standard" 80 byte tape label record, the first 4 bytes
! of which contain the characters 'VOL1', the next 6 bytes contain
! the label (up to 6 alphanumerics padded on the right with spaces),
! the remainder of the record contains spaces.  There follows one
! filler block.
!
! Then, for each file on the tape, we have a file mark followed by
! a header block containing information about the file, then a number
! of data blocks.  The last file is followed by a file mark and as
! many dummy filler blocks as necessary to flush out the redundant
! blocks. Finally, there is a double file mark.
!
! The blocks themselves "know" whether they are dummy blocks, file
! headers, or data blocks.  The purpose of the file marks is only to
! ease quick seeking to the next file when reading.  Indeed, it may be
! decided in due course to have file marks only in front of the first
! file in every directory.
!
! As security against tape corruption, each block is recorded several
! times, staggered such that virtual block N appears in physical block
! K and K+S and K+2*S (and so on (but at the moment we only triplicate)),
! where S is a fixed stagger parameter.  Thus a single tape error shorter
! than S blocks will only wipe out one of the many (three) copies of the
! block.

%include "scsitape.inc"

%constinteger -
 redundancy = 1,                {number of VBs per PB}
 virtual block size = 2048,     {user data in each VB}
 overhead = 12,                 {block numbers and checksum fields}
 physical block size = (virtual block size + overhead) * redundancy,
 stagger = 20,
 tape blocks = 150,
 extra = (redundancy-1)*stagger

%recordformat vtbf {virtual tape block} -
  (%byte b                {reference byte for CRC operations} %or-
   %integer tbn,          {tape block number (-1 for fillers)}
   %half fbn,             {file block number (0 for headers)}
         length,          {block data content (0 for headers)}
   ((%integer file size,
     %string(31)time taped, file time stamp,
     %string(255)file name, file attributes) %or-
    %bytearray data(1:virtual block size)),
   %integer crc)

%recordformat ptbf {physical tape block} -
  (%record(vtbf)%array block(1:redundancy))

%record(ptbf)%arrayname tape buffer(1:tapeblocks+(extra!1))
%record(vtbf)%name filler,virtual block
%string(7)tapelabel
%integer put, tbn, fbn

%routine tape mount(%string(63)which)
! Request a new tape to be mounted, and ask the operator to
! type in the tape label.  The label actually on the tape
! is checked and must be the same as typed in.  But typing
! "*" as the label matches anything.  Typing '!' after a
! label causes the tape to be re-labelled.
%string(81)s,a {S for SHOULD BE, A for ACTUALLY IS}
%integer k,i
  %if dummy#0 %then tapelabel = "DUMMY" %elsestart
    errorline
    printstring("Please mount ";which;" tape and type in its label."); newline
    printstring("Type '*' if you don't know the label."); newline
    printstring("Type '!' after the label if the tape is not yet labelled.")
    newline
    prompt("Label:")
    %cycle
      %cycle
        read(s); readsymbol(k) %until k=nl
        %exitif tape unit ready
        printstring("Tape not ready"); newline
      %repeat
      tape rewind and wait
      tape mode select(buffered + default density + slow + variable block size)
      %if s -> s.("!") %start;             !write a new label
        length(s) = 6 %if length(s)>6
        toupper(s); k = 0
        %for i = 1,1,length(s) %cycle
          k = charno(s,i)
          k = 0 %andexitunless 'A'<=k<='Z' %or '0'<=k<='9'
        %repeat
        %if k=0 %or charno(s,1)<'A' %start
          printstring("That is not a valid label - alphanumerics only please.")
          newline; %continue
        %finish
        s = "VOL1".s
        s = s." " %until length(s)=80
        k = tape write block(charno(s,1),80)
        tape rewind and wait;              !prepare to check it
      %else
        length(s) = 6 %if length(s)>6
        s = "VOL1".s; toupper(s)
        s = s." " %until length(s)=80
      %finish
      k = tape read block(charno(a,1),81)
      length(a) = 4
      printstring("Tape has no proper label") %and newline %and-
      %continueunless k=80 %and a="VOL1"
      length(a) = 80
      tapelabel = ""
      %for i = 5,1,10 %cycle
        k = charno(a,i); tapelabel = tapelabel.tostring(k) %unless k=' '
      %repeat
      printstring("Tape label is "; tapelabel); newline
      %exitif a=s
      %exitif s->("*")
    %repeat
    tape mode select(buffered + default density + slow + sizeof(tapebuffer(1)))
  %finish
  set terminalmode(0)
  selectout(log); putsym(' '); putstring(tapelabel); putsym(nl)
%end
  
%routine tape flush(%integer marks)
%bytename start
%integer expect,wrote,j,i
  start == tape buffer(1)_block(1)_b
  expect = (put-1)*physical block size
  %if expect#0=dummy %start
    %cycle
      wrote = tape write blocks(start,expect)
      %if wrote=expect %start
        %for j = 2,1,redundancy %cycle
          %for i = 1,1,(j-1)*stagger %cycle
            tape buffer(i)_block(j) = tape buffer(put-1+i)_block(j)
          %repeat
        %repeat
        %exit
      %finish
!Should really check for bad spot (backtrack, erase some, try again)
!but at the moment just assume we ran out of tape.
!Write the whole buffer again even if some of it went out OK.
      tape unload
      errorline
      printstring("Tape ";tapelabel;" is full."); newline
      tape mount("the next")
    %repeat
  %finish
  put = 1; virtual block == tape buffer(1)_block(1)
  %unless marks=0 %start
    tape write marks(marks) %if dummy=0
    selectout(log); putsym(nl)
  %finish
%end

%routine write virtual block(%integer length)
%integer i
  virtual block_length = length
  virtual block_tbn = tbn; tbn = tbn+1
  virtual block_fbn = fbn; fbn = fbn+1
  append crc(virtual block_b,virtual block size + overhead - 4)
  tapebuffer(put+(i-1)*stagger)_block(i) = virtualblock %for i = 2,1,redundancy
  put = put+1; virtual block == tape buffer(put)_block(1)
  tape flush(0) %if put>tape blocks
%end

%routine tape open
! Set up buffers and mount first tape.
%integer j,i
  tape buffer == new(tapebuffer)
  filler == new(filler)
  filler_data(i) = '^' %for i = 1,1,virtualblocksize
  filler_tbn = -1; filler_fbn = 0; filler_length = 0; filler_filesize = 0
  filler_timetaped = now
  filler_filetimestamp = filler_timetaped
  filler_filename = "EUCSD APM Filestore Backup Tape"
  filler_fileattributes = "Version 24/03/87"
  append crc (filler_b,virtual block size - 4)
  %for j = 2,1,redundancy %cycle
    tape buffer(i)_block(j) = filler %for i = 1,1,(j-1)*stagger
  %repeat
  put = 1; virtual block == tape buffer(put)_block(1)
  tbn = 0; fbn = 0
  virtual block = filler; write virtual block(0)
  scsireset %if dummy=0
  tape mount("the first")
%end

%routine tape close
%integer i
  %for i = 1,1,(redundancy-1)*stagger %cycle
    virtual block = filler; fbn = 0; tbn = 0; write virtual block(0)
  %repeat
  tape flush(2)
  tape unload %if dummy=0
%end

! Tape handling ends here

%recordformat string list fm(%record(string list fm)%name next,%string(255)s)
%recordformat file list fm(%record(file list fm)%name next,
     %string(255)name,attributes,stamp,%integer blocks)

! Agenda lists

%record(string list fm)%name-
  indir == nil,   exdir == nil,
  infile == nil,  exfile == nil,
  inperm == nil,  experm == nil,

%routine vet date
%ownstring(31)sample="00/00/00:00.00.00"
%bytename d,s
%integer i
  d == length(since); s == length(sample)
  %cycle
    d = s %if d>s
    %while d<s %cycle
      d = d+1; d[d] = s[d]
    %repeat
    %for i = 1,1,d %cycle
      %if s[i]='0' %start
        ->retry %unless '0'<=d[i]<='9'
      %else
        ->retry %unless d[i]=s[i]
      %finish
    %repeat
    printstring("Threshold date: ";since); newline
    %return
retry:
    read(since)
    readsymbol(i) %until i=nl
  %repeat
%end

%routine mangle date(%string(*)%name date)
! Swap year and day so dates may be compared simply as strings.
! NB: Call me twice and it's like you never called me at all.
%bytename d
%byte k
  d == length(date)
  k = d[1]; d[1] = d[7]; d[7] = k
  k = d[2]; d[2] = d[8]; d[8] = k
%end

%record(string list fm)%map prepend(%string(*)%name s,%record(string list fm)%name list)
%record(string list fm)%name item
  item == new(item); item_s = s
  item_next == list; %result == item
%end

%record(string list fm)%map reverse(%record(string list fm)%name old)
%record(string list fm)%name new == nil, item
  %cycle
    %result == new %if old==nil
    item == old; old == old_next
    item_next == new; new == item
  %repeat
%end

%record(string list fm)%map concat(%record(string list fm)%name list1,list2)
! Reverse LIST2 and stick it on the front of LIST1.
! NB: No copying takes place.
%record(string list fm)%name c
  c == list2
  %result == list1 %if c==nil
  list2 == reverse(list2)
  c_next == list1
  %result == list2
%end

%routine dispose string list(%record(string list fm)%name list)
%record(string list fm)%name cell
  %cycle
    cell == list; %returnif cell==nil
    list == list_next; dispose(cell)
  %repeat
%end

%routine dispose file list(%record(file list fm)%name list)
%record(file list fm)%name cell
  %cycle
    cell == list; %returnif cell==nil
    list == list_next; dispose(cell)
  %repeat
%end

%predicate Matches(%string (*) %name s, p)
! S=Subject, P=Pattern. Pattern is the one with the stars in it.
%integer slen = 0, plen = 0
  %predicate m (%integer spos,ppos)
    %integer psym = 0,ssym = 0
    %cycle
      %if ppos=plen %start
        %true %if spos=slen
        %false
      %finish
      ppos = ppos+1; psym = charno(p,ppos)
      %exitif psym='*'
      %falseif spos=slen
      spos = spos+1; ssym = charno(s,spos)
      psym = ssym %if ssym!32=psym!32 %and 'a'<=psym!32<='z'
      %unless ssym=psym %start
        %falseunless psym='%'
      %finish
    %repeat
    %cycle
      %trueif m(spos,ppos)
      %exitif spos=slen
      spos = spos+1; ssym = charno(s,spos)
    %repeat
    %false
  %end
  slen = length(s)
  plen = length(p)
  %true %if m(0,0)
  %false
%end

%predicate specified(%string(255)s,%record(string list fm)%name in,ex)
! True if S is not in EX but is in IN,
! or if it matches nothing in EX but something in IN,
! false otherwise.
%record(string list fm)%name r
  toupper(s)
  r == ex
  %while r##nil %cycle
    %falseif s=r_s; r == r_next
  %repeat
  r == in
  %while r##nil %cycle
    %trueif s=r_s; r == r_next
  %repeat
  r == ex
  %while r##nil %cycle
    %falseif matches(s,r_s); r == r_next
  %repeat
  r == in
  %while r##nil %cycle
    %trueif matches(s,r_s); r == r_next
  %repeat
  %false
%end

%record(string list fm)%map list of(%string(255)s,title)
! S is a list of names separated by commas.
! Each name is either simple or wild or begins with '@', in which case
! it refers to a file containing further names (separated by commas,
! spaces, or line breaks).
! Result is a linked list of all the names in question.
%record(string list fm)%name c == nil
%string(255)component

  %routine add on
  ! Global string COMPONENT is comma-free but may begin with '@'.
  ! If not, add a record containing that name to global list C,
  ! otherwise open that file, and read all the names in it into
  ! COMPONENT, and call LISTOF for each one.
  %owninteger stream=0
    %on 3,9 %start
      selectinput(stream); closeinput; stream = stream-1
      %return
    %finish
    %returnif component=""
    %if stream>=3 %start
      errorline
      printstring("Cannot read file ";component;" - nested too deeply")
      newline; %stop
    %finish
    %if charno(component,1)='@' %start
      component -> ("@").component
      stream = stream+1; openinput(stream,component)
      %cycle
        selectinput(stream)
        prompt(title)
        read(component)
        prompt(":")
        c == concat(c,listof(component,title))
      %repeat
    %finishelse c == prepend(component,c)
  %end

  %unless s="" %start
    add on %while s -> component.(",").s
    component = s; add on
  %finish
  %result == c
%end

%integerfn stringlistlength(%record(string list fm)%name x)
%integer n=0
  %cycle
    %result = n %if x==nil; n = n+1; x == x_next
  %repeat
%end

%integerfn filelistlength(%record(file list fm)%name x)
%integer n=0
  %cycle
    %result = n %if x==nil; n = n+1; x == x_next
  %repeat
%end

%integerfn blocksum(%record(file list fm)%name x)
! Sum of sizes of all the files in X.
%integer n=0
  %cycle
    %result = n %if x==nil; n = n+x_blocks; x == x_next
  %repeat
%end

%routine extract finfo(%string(255)info,%record(file list fm)%name r)
%string(255)blocks,date,time
%integer pos
  %routine to(%integer sep,%string(255)%name s)
    s = ""
    pos = pos+1 %while pos<=length(info) %and charno(info,pos)=' '
    %cycle
      %returnif pos>length(info) %or charno(info,pos)=sep
      s = s.tostring(charno(info,pos)); pos = pos+1
    %repeat
  %end
  %on 4 %start
    errorline
    printstring(event_message;" in info line"); newline
    printstring(info); newline
    selectout(err)
    putstring(event_message;" in info line"); putsym(nl)
    putstring(info); putsym(nl)
    r_blocks = 1
    %return
  %finish
  pos = 1
  to(' ',r_name)
  to(' ',r_attributes)
  to(' ',date)
  to(' ',time)
  to('(',blocks)
  r_stamp = combine(date,time)
  r_blocks = stoi(blocks)
%end

%record(string list fm)%map top level directory
! Return a complete list of top level directories,
! upper cased, with blank and bad entries removed.
! All entries will have a colon at the end.
%record(string list fm)%name list==nil,cell
%string(255)s
%integer a=0,p,i,j,k,l
%bytearray buff(0:511)

  %on 3 %start
    %if filestore=1986 %start
      heapput(a) %unless a=0
    %finish
    %result == list
  %finish

  %if filestore=1976 %start
    %for p = 0,1,15 %cycle
      s = tostring(p+'0')
      k = fcommr('\'<<8,s,buff(0),512)
      %for i = 0, 8, 504 %cycle
        s = ""
        %for j = i,1,i+7 %cycle
          k = buff(j)
          k = k-32 %if 'a'<=k<='z'
          s = s.tostring(k) %unless k<=' '
        %repeat
        %unless s="---" %or s="*BAD*" %start
          s = s.":"
          cell == new(cell); cell_next == list; list == cell; cell_s = s
        %finish
      %repeat
    %repeat
  %elseif filestore=1986
    connectfile("LOCAL:",0,a,l); p = a
    %cycle
      s = ""
      %while l>0 %cycle
        l = l-1; k = byte(p); p = p+1
        %if k<=' ' %start
          %continueif s=""; %exit
        %finish
        s = s.tostring(k)
      %repeat
      %exitif s=""
      cell == new(cell); cell_next == list; list == cell; cell_s = s
    %repeat
    heapput(a)
  %finish
  %result == list
%end

%record(string list fm)%map entries(%string(255)directory)
! Return all the entries in the specified directory, except those
! with names containing '!'.  Strip a trailing '?' from name if any.
%integer dodgy=0,lives=9,a,p=0,l,k
%record(string list fm)%name list==nil,cell
%bytename ls
%string(255)s
  %predicate healthy
  %integer i,k
    %for i = 0,1,l-1 %cycle
      k = byte(p+i)
      %falseif k>=128 %or (k<=' ' %and k#nl)
    %repeat
    %true
  %end
  %on 3 %start
    heapput(a) %unless p=0
    %result == list
  %finish
  ls == length(s)
  %cycle
    connectfile(directory,0,a,l); p = a
    %exitif healthy
    errorline
    printstring("Dodgy characters in directory ";directory); newline
    selectout(err)
    putstring("Dodgy characters in directory ";directory); putsym(nl)
    lives = lives-1
    %exitif lives<=0
    heapput(a); p = 0
  %repeat
  %cycle
    ls = 0; dodgy = 0
    %while l>0 %cycle
      l = l-1; k = byte(p); p = p+1
{}    dodgy = 1 %if k&128#0 %or (k<=' ' %and k#nl)
      %exitif k=nl
      ls = ls+1; ls[ls] = k
    %repeat
{}  %if dodgy#0 %start
{}    errorline
{}    printstring("Dodgy directory entry ";s); newline
{}    selectout(err)
{}    putstring("Dodgy directory entry ";s); putsym(nl)
{}    %continue
{}  %finish
    %exitif ls=0
    %continueif ls[ls]='!'
    ls = ls-1 %if ls[ls]='?'
    cell == new(cell); cell_next == list; list == cell; cell_s = directory.s
  %repeat
  heapput(a); %result == list
%end

%record(string list fm)%map directory entries(%record(string list fm)%name in)
! Extract copies of those entries in the list which end in ':'.
%record(string list fm)%name list==nil,cell
%string(255)%name s
  %while in##nil %cycle
    s == in_s
    %if charno(s,length(s))=':' %start
      cell == new(cell); cell_s = s; cell_next == list; list == cell
    %finish
    in == in_next
  %repeat
  %result == list
%end

!%record(string list fm)%map alias entries(%record(string list fm)%name in)
!! Extract copies of those entries in the list which end in '>',
!! but strip the '>' off the end of the copies.
!%record(string list fm)%name list==nil,cell
!%string(255)%name s
!  %while in##nil %cycle
!    s == in_s
!    %if length(s)>1 %and charno(s,length(s))='>' %start
!      cell == new(cell); cell_s = s; cell_next == list; list == cell
!    %finish
!    in == in_next
!  %repeat
!  %result == list
!%end

%record(string list fm)%map file entries(%record(string list fm)%name in)
! Extract copies of those entries in the list which end with ':' NOR '>'.
%record(string list fm)%name list==nil,cell
%integer k
  %while in##nil %cycle
    k = charno(in_s,length(in_s))
    %if ':'#k#'>' %start
      cell == new(cell); cell_s = in_s; cell_next == list; list == cell
    %finish
    in == in_next
  %repeat
  %result == list
%end

%string(255)%fn file name part(%string(255)s)
! Remove any directory prefix and version number suffix.
%integer p
  %if s -> s.(":-") %start; %finish {strip off version number}
  p = length(s)
  p = p-1 %while p>0 %and charno(s,p)#':'
  %result = substring(s,p+1,length(s))
%end

%record(string list fm)%map directory agenda(%record(string list fm)%name input)
! Generate copy of those items in INPUT specified in the IN/EX lists.
%record(string list fm)%name list==nil,cell
%string(255)s
  %while input##nil %cycle
    s = input_s; length(s) = length(s)-1  {asjust for colon}
    %if specified(s,indir,exdir) %start
      cell == new(cell); cell_s = input_s; cell_next == list; list == cell
    %else
!     errorline
!     printstring(" Excluding directory ";input_s); newline
    %finish
    input == input_next
  %repeat
  %result == list
%end

%record(file list fm)%map file agenda(%record(string list fm)%name input)
! Generate copy of those items in INPUT specified in the IN/EX lists of
! files and permissions, and which are young enough.
%record(file list fm)%name list==nil,cell
  %on 3 %start
    errorline
    printstring(event_message); newline
    selectout(err); putstring(event_message); putsym(nl)
    input == input_next %unless input==nil
  %finish
  %while input##nil %cycle
    %if specified(filenamepart(input_s),infile,exfile) %start
      cell == new(cell); cell = 0
      extract finfo(ninfo(input_s),cell)
      mangledate(cell_stamp)
      %if specified(cell_attributes,inperm,experm) %and cell_stamp>=since %start
        cell_name = input_s
        cell_next == list; list == cell
      %else
        dispose(cell)
!       errorline
!       printstring("       Ignoring file ";input_s); newline
      %finish
    %else
!     errorline
!     printstring("      Excluding file ";input_s); newline
    %finish
    input == input_next
  %repeat
  %result == list
%end

%integerfn process file(%record(file list fm)%name f)
! Write the specified files to tape, and log it.
! Result is the number of files (0,1) successfully processed.
%string(31)start
%integer token=0,size,pos,i
  %on 3 %start
    errorline
    printstring(event_message); newline
    selectout(err); putstring(event_message); putsym(nl)
    close(token) %unless token=0
    %result=0
  %finish
  mangledate(f_stamp)
  start = now
  openr(f_name,token,size)
  %if size<=0 %start
    errorline
    printstring("File size "); write(size,0)
    printstring(" bytes for file ";f_name); newline
    selectout(err)
    putstring("File size "; itos(size,0); " bytes for file"; f_name)
    putsym(nl)
    close(token)
    %result = 0
  %finish
  virtual block = filler
  virtual block_time taped = start
  virtual block_file time stamp = f_stamp
  virtual block_file attributes = f_attributes
  virtual block_file size = size
  virtual block_file name = f_name
  fbn = 0
  write virtual block(0)
  pos = 0
  %while size>=virtualblocksize %cycle
    readblock(token,virtualblocksize,pos,virtualblock_data(1))
    size = size-virtualblocksize
    write virtual block(virtualblocksize)
  %repeat
  %unless size=0 %start
    virtualblock_data(i) = '^' %for i = 1,1,virtualblocksize
    readblock(token,size,pos,virtualblock_data(1))
    write virtual block(size)
  %finish
  close(token); token = 0
  selectout(log); putstring(f_name); putsym(nl)
  %result = 1
%end

%integer dirsleft

%integerfn process files(%record(string list fm)%name raw)
! Scrutinise the raw list provided, discarding those files we don't want,
! then process (and log to the terminal) all files remaining.
%record(file list fm)%name list,cell
%integer filesdone=0,blocksleft,filesleft
  list == file agenda(raw)
  blocksleft = blocksum(list)
  filesleft = filelistlength(list)
  cell == list
  %while cell##nil %cycle
    write(cell_blocks,4; blocksleft,6; filesleft,3; dirsleft,3)
    space; printstring(cell_name)
    spaces(80-21-length(cell_name)); printsymbol(cr)
    filesdone = filesdone+process file(cell)
    blocksleft = blocksleft-cell_blocks
    filesleft = filesleft-1
    cell == cell_next
  %repeat
  dispose file list(list)
  dispose string list(raw)
  %result = filesdone
%end

%routine process directories(%record(string list fm)%name raw,%integer n)
! Scrutinise the raw list provided, discarding those directories we don't want,
! then process the directories and the files and subdirectories in them.
%record(string list fm)%name list,cell,e,d
  list == directory agenda(raw)
  n = n+stringlistlength(list)
  cell == list
  %while cell##nil %cycle
    e == entries(cell_s)
    d == directory entries(e)
    dirsleft = n+stringlistlength(d); n = n-1
    %if process files(reverse(file entries(e)))=0 %start
!     errorline
!     printstring("     Empty directory ";cell_s); newline
    %finishelse tape flush(1)
    process directories(reverse(d),n)
    dispose string list(e)
    cell == cell_next
  %repeat
  dispose string list(list)
  dispose string list(raw)
%end

%routine logfilename(%string(*)%name s)
%string(255)b,a
  tolower(s)
  %returnif s -> b.(".log").a %and a=""
  s = s.".log"
%end

! Main program starts here

! %on 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
!   printstring("*Aborted ")
!   write(event_event,0; event_sub,1; event_extra,1); space
!   phex(event_extra); space; printstring(event_message); newline
!   selectout(err); closeout %unless err_xno=0
!   selectout(log); closeout %unless log_xno=0
!   %stop
! %finish

! Use PAM to acquire program parameters

  defineparam("Since - exclude files older than",since,pammajor!pamnodefault)
  defineparam("Dirs - include directories",dir,0)
  defineparam("NoDirs - exclude directories",nodir,0)
  defineparam("Files - include files",file,0)
  defineparam("NoFiles - exclude files",nofile,0)
  defineparam("Perms - include files permitted",perm,0)
  defineparam("NoPerms - exclude files permitted",noperm,0)
  defineparam("Logfile",logfile,pammajor!pamnewgroup!pamnodefault)
  defineparam("Errorlog",errfile,0)
  defineintparam("Type of filestore - 1976 or 1986",filestore,pammajor)
  definebooleanparams("DUmmy",dummy,0)
  processparameters(cliparam)
  %stopif 1976#filestore#1986
  logfilename(logfile;errfile)

! Obtain date of last log file if it exists

  %begin
  %record(file list fm)info
    %on 3 %start
      since = "01/10/76"
      %return
    %finish
    %returnif since -> ("/")  {date explicitly specified}
    logfilename(since)
    info = 0
    extract finfo(ninfo(since),info)
    since = info_stamp
  %end

  %if perm=""=noperm %start
    %if filestore=1976 %then perm = "*A" %else perm = "*$*"
  %finish

  prompt("Since:")
  vetdate
  prompt(":")
  mangledate(since)

! Build the inclusion/exclusion lists

  indir == listof(dir,"Include directories:")
  exdir == listof(nodir,"Exclude directories:")
  infile == listof(file,"Include files:")
  exfile == listof(nofile,"Exclude files:")
  inperm == listof(perm,"Include permissions:")
  experm == listof(noperm,"Exclude permissions:")

! Do the work

  selectout(err); openout(errfile)
  selectout(log); openout(logfile)
  tapeopen
  process directories(reverse(directory entries(top level directory)),0)
  tapeclose
  selectout(log); putstring(now); putsym(nl); closeout
  selectout(err); closeout
%end