!verify

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

%begin

%routine error line
! newline
  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(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

%predicate checkblock(%integer xno,bytes,%integername pos,%bytename buf)
%label no
%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
  %signal 3,4,,"misaligned" %unless 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)
    %trueif amount=0
    *move.l b,a0
    *move.l buf,a1
    *moveq #-1,d0
    *add.l amount,d0  
loop: *cmpm.b (a0)+,(a1)+
    *dbne d0,loop
    *bne no
    bytes = bytes-amount; pos = pos+amount; buf == buf[amount]
    %trueif bytes<=0 %or amount<512
  %repeat
no: %false
%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 length(t)=5
  %result = dt
%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.
!
! Then, for each file on the tape, we have a header block containing
! information about the file.  This header block is followed by an
! appropriate number of data blocks.
!
! A single tape mark is written in fornt of the header block of the
! first file in every directory, the purpose of which is merely to
! speed up searches for a particular file during RESTORE operations.

%include "scsitape.inc"

%constinteger -
 virtual block size = 2048,     {user data in each VB}
 overhead = 12,                 {block numbers and checksum fields}
 physical block size = virtual block size + overhead,
 tape blocks = 150

%recordformat vtbf {virtual tape block} -
  (%byte b                {reference byte for tape operations} %or-
   %integer tbn,          {tape block number}
   %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 checkword)

%record(vtbf)%arrayname tape buffer(1:tapeblocks)
%record(vtbf)%name virtual block
%integer vbn=tapeblocks,tbn=-1, fbn
%string(7)tapelabel

%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.
%string(81)s,a {S for SHOULD BE, A for ACTUALLY IS}
%integer k,i
  errorline
  printstring("Please mount ";which;" tape."); newline
  %cycle; %repeatuntil tape unit ready
  tape rewind and wait
  tape mode select(buffered + default density + slow + variable block size)
  k = tape read block(charno(a,1),81)
  length(a) = 4
  printstring("Tape has curious label") %and newline %unless 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
  tape mode select(buffered + default density + slow + sizeof(tapebuffer(1)))
! set terminalmode(0)
  selectout(log); putsym(' '); putstring(tapelabel); putsym(nl)
%end
  
%routine read virtual block
%owninteger ts=0,tm=0
  %cycle
    %if vbn<tape blocks %start
      vbn = vbn+1; virtualblock == tape buffer(vbn)
      %unless virtual block_tbn<0 %start
        %unless virtualblock_tbn=tbn+1 %start
          errorline
          printstring("Unexpected TBN"); write(virtualblock_tbn,1)
          printstring(" - expecting"); write(tbn+1,1); newline
        %finish
        tbn = virtualblock_tbn
        %unless virtualblock_checkword=\virtualblock_tbn %start
          errorline
          printstring("Checkword error"); newline
        %finish
        %return
      %finish
    %finish
    %cycle
      %if ts&fm#0 %start
        errorline; printstring("Tape mark"); newline
      %finish
      vbn = tape readblocks(tape buffer(1)_b,
            tapeblocks*physicalblocksize) // physicalblocksize
      %if vbn#0 %start
        ts = tapestatus; %exit
      %finish
      %if ts&tapestatus&fm#0 %start
        errorline; printstring("Double tape mark"); newline
        tape unload; %stop
      %finish
      %if ts&eom#0 %start
        tape unload
        tape mount("next")
        ts = 0
      %finish
    %repeat
    vbn = vbn+1 %and tape buffer(vbn)_tbn = -1 %while vbn<tape blocks
    vbn = 0
  %repeat
%end

! Tape handling ends here

%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

%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

%routine extract finfo(%string(255)info,
  %string(*)%name name,attributes,stamp,%integername nblocks)
%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)
    nblocks = 0
    %return
  %finish
  pos = 1
  to(' ',name)
  to(' ',attributes)
  to(' ',date)
  to(' ',time)
  to('(',blocks)
  stamp = combine(date,time)
  nblocks = stoi(blocks)
%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

%routine check file(%string(255)name,date,%integer size)
%string(255)aname,aatt,astamp
%integer ablocks,xno=0,pos=0,amt,ok
  %on 3 %start
    errorline
    printstring("File ";name;" no longer accessible"); newline
    read virtual block %and size = size-virtualblocksize %while size>0
    %return
  %finish
  extractfinfo(ninfo(name),aname,aatt,astamp,ablocks)
! %if date#astamp %start
!   errorline
!   printstring("File ";name;"'s stamp has changed to ";astamp); newline
! %finish
  openr(name,xno,ok)
  %unless ok=size %start
    errorline
    printstring("File ";name;"'s size has changed"); newline
  %finish
  ok = 1
  %while size>0 %cycle
    read virtual block
    %if virtualblock_length=0 %start
      errorline
      printstring("Unexpected header block in file ";name); newline
      vbn = vbn-1; close(xno)
      %return
    %finish
    size = size-virtualblock_length
    %continueif ok=0
    ok = 0 %unless checkblock(xno,virtualblock_length,pos,virtualblock_data(1))
  %repeat
  %if ok=0 %start
    errorline
    printstring("File ";name;"'s contents have changed"); newline
  %finish
  close(xno)
%end

! Main program starts here

cliparam = "*" %if cliparam=""
printstring("Looking for ";cliparam); newline
scsireset
tape mount("first")
tape buffer == new(tape buffer)
%cycle
  read virtual block %until virtualblock_fbn=0
  %exitif matches(virtualblock_filename,cliparam)
  printstring("Ignoring ";virtual block_filename); newline
%repeat

%cycle
  %unless virtualblock_fbn=0 %and virtualblock_length=0 %start
    errorline; printstring("Unexpected data block")
    write(virtualblock_fbn,1; virtualblock_length,1); newline
    %continue
  %finish
  printstring(virtualblock_timetaped;" ";-
              virtualblock_filetimestamp;" "); phex(virtualblock_filesize)
  printstring(" ";virtualblock_filename)
  newline
  check file(virtualblock_filename,virtualblock_filetimestamp,
             virtualblock_filesize)
  read virtual block
%repeat

%end