program tp (input,output,xfil,bfil,cfil,ffil);
{$S- ;}
{$W- ;}
const
   { VMS definitiions }
   SS$_NORMAL = %x01;
   SS$_ENDOFFILE = %x00;
   CLI$K_GETCMD = %x01;
   IO$_WRITELBLK = %x20;
   IO$_READLBLK = %x21;
   IO$_REWIND = %x24;
   IO$_REWINDOFF = %x22;
   IO$_SKIPFILE = %x25;
   IO$_SKIPRECORD = %x26;
   IO$_SPACEFILE = %x02;
   IO$_SPACERECORD = %x09;
   IO$_WRITEOF = %x28;

   { ASCII character codes }
   NEWLINE = %x0A;
   ESC = %x1B;

   {Conversion of UNIX time in seconds to VMS time in 100-nanoseconds}
   TIME_DIFF = 10000000;
   { data structure sizes }
   LINELEN = 133;
   DIRSIZ = 62;
   BLOCK = 512;

type
   short = 0..65535;
   filename = packed array[1..32] of char;
   string63 = packed array[1..63] of char;
   string24 = packed array[1..24] of char;
   string4 = packed array[1..4] of char;
   string6 = packed array[1..6]  of char;
   textline = packed array[1..LINELEN] of char;
   iosb = packed record
             status, count : 0..65535;
             info: integer;
          end;
   strdesc = packed record
                length: integer;
                addr: ^string63;
             end;
   timstr = packed record
               length: integer;
               addr: ^string24;
            end;
   systime = packed record
                time0,time4 : integer;
             end;
   clireqdesc = packed record
                   rqtype: integer;
                   fill1: integer;
                   rqdesc: strdesc;
                   fill2: array [1..3] of integer;
                end;
   tap_blk = array [1..BLOCK] of char;
   dir_typ = packed record
                path_name: array [1..32] of char;
                mode: packed set of 0..15;
                uid,
                gid: 0..255;
                unused1: char;
                size0: 0..255;
                size1: 0..65535;
                time_modified: integer;
                tape_address: 0..65535;
                unused2: array [1..16] of char;
                chksum: short;
             end;
   dir_ent = record
                case boolean of
                   FALSE: (words: packed array [1..32] of 0..65535);
                   TRUE:  (dirent: dir_typ);
             end;
   dir_blk = record
                case boolean of
                   FALSE: (blk: tap_blk);
                   TRUE:  (direct: array [1..8] of dir_ent);
             end;

   name_store = record
                   bin: Boolean;
                   len: integer;
                   str: filename;
                end;

var
   xfil: text;
   bfil: file of tap_blk;
   cfil: text;
   ffil: text;
   ind_file: Boolean;
   bflg: Boolean;
   tape: string6;
   line: textline;
   tchan: integer;
   tapeiosb: iosb;
   tapedir: array [1..DIRSIZ] of dir_blk;
   names: array[1..496] of name_store;
   today, unix_base: string24;
   pr_time: timstr; {for storing converted ascii time strings}
   off_time: systime; {difference between seconds and 100-nanoseconds}
   base_diff, file_time: systime;
   boot: tap_blk;
   buffer: tap_blk;
   position: 0..65535;
   address: integer;
   size: integer;
   numblocks: integer;
   getcmd: clireqdesc;
   old: Boolean;
   wflg: boolean;
   vflg: boolean;
   tflg: boolean;
   xflg: boolean;
   cflg: boolean;
   i: integer;
   c: char;

value
   line := (LINELEN of ' ');
   buffer := (BLOCK of ' ');
   tape := '_MTA0:';
   unix_base := '1-JAN-1970 00:00:00.00  ';
   today := '-- ::.                  ';
   off_time := (TIME_DIFF, 0);
   position := 1;
   numblocks := 0;
   address := 0;
   bflg := FALSE;
   wflg := FALSE;
   vflg := FALSE;
   tflg := FALSE;
   xflg := FALSE;
   cflg := FALSE;
   old := FALSE;
   ind_file := FALSE;

   procedure prname(str: array[integer] of char);
   var
      i: integer;
   {
      Print a null terminated string.
   }
   begin {prname}
      i:=lower(str);
      while str[i] <> chr(0) do
         begin
            write(str[i]);
            i := i + 1;
         end;
   end; {prname}

   procedure sys$asctim(var timlen: integer; var timbuf: timstr;
                        var timadr: systime; cvtflg: integer); extern;

   procedure quaadd(var addend1, addend2, sum: systime); extern;

   procedure quamul(var multiplier, multiplicand, product: systime); extern;

   procedure quasub(var minuend, subtrahend, difference: systime); extern;

   procedure quadiv(var numerator, denominator, quotient: systime); extern;

   procedure vmstime(tapetime: integer; var cvttime: systime);
   var
      expnd: systime;
   {
      convert UNIX time to VMS time
   }
   begin {vmstime}
      expnd.time0 := tapetime;
      expnd.time4 := 0;
      quamul(off_time, expnd, cvttime);
      quaadd(cvttime, base_diff, cvttime);
   end; {vmstime}

   function unixtime(var filetime: systime): integer;
   var
      expnd: systime;
   begin {unixtime}
      quasub(filetime, base_diff,expnd);
      quadiv(expnd, off_time, expnd);
      unixtime := expnd.time0;
   end; {unixtime}

   function sys$qiow(%immed d1,chan,func: integer; var iosbl: iosb;
                     %immed d2, d3: integer;
                     var p1: char; %immed p2,p3,p4,p5,p6: integer):
                                                  integer; extern;

   procedure setuptape;
   var
      devar: string63;
      i,trnlen,status: integer;

   function sys$trnlog(%stdescr lognam: string4; var trlen: integer;
                       %stdescr rslbuf: string63; %immed d1, d2, d3: integer):
                                                  integer; extern;

   function sys$assign(%stdescr devnam: string6; var chan: integer;
                       %immed d1, d2: integer): integer; extern;

   {
      Assign a channel to the selected tape drive.
   }
   begin {setuptape}
      status := sys$assign(tape, tchan,0,0);
      if status <> 1 then
         begin
         writeln(' sys$assign status: ', status:8 hex);
         halt;
         end;
   end; {setuptape}

   procedure setupfile(var name: filename; len: integer; lognam: string4);
   type
      strdesc = record length: integer; addr: ^filename end;
   var
      fp: ^filename;
      fd: strdesc;

      function sys$crelog(%immed tblflg: integer; %stdescr lognam: string4;
                          var eqlnam: strdesc; %immed acmode: integer):
                                                        Boolean; extern;
   {
      Assign the passed filename to the passed 4-character logical name,
      to allow multiple file access from Pascal.
   }
   begin {setupfile}
      new(fp); fp^ := name;
      with fd do
         begin length := len; addr := fp end;
      if not sys$crelog(2,lognam,fd,0) then
         begin
         writeln(' Internal error: sys$crelog failed.');
         halt;
         end;
   end; {setupfile}

   procedure getfname(var fname: filename);
   var
      done: Boolean;
      i: integer;
      fil: filename;
   {
      Read a file name from the terminal or user-supplied file.
      }
   begin {getfname}
      done := FALSE;
      while not done do
         begin
            if not ind_file then
               begin
                  write('Filename: ');
                  readln(fname);
                  if fname[1] = '@' then
                     begin
                        i := 2;
                        while fname[i] <> ' ' do
                           begin
                              fname[i-1] := fname[i];
                              i := i + 1
                           end;
                        setupfile(fname, i-2, 'FFIL');
                        open(ffil, OLD);
                        reset(ffil);
                        ind_file := TRUE;
                     end
                  else
                     done := TRUE
               end
            else
               begin
                  if not eof(ffil) then
                     begin
                        readln(ffil, fname);
                        done := TRUE
                     end
                  else
                     begin
                        close(ffil);
                        ind_file := FALSE
                     end
               end
         end
   end; {getfname}

   function vmsfile(name: array[integer] of char; var fname: filename): integer;
   label
      1;
   var
      len,lastdot,lastdir: integer;
      i,j: integer;
   {
      Convert the tape filename to a VMS filename.
      This proceeds by removing non-alphanumeric characters,
      and converting names with '/'s into equivalent directory
      names for VMS.
   }
   begin {vmsfile}
      i := 1;
      len := 2;
      fname[1]:='['; fname[2]:=']'; lastdir:=2;
      lastdot := 0;
      while name[i] <> chr(0) do
         case name[i] of
            '/':
               if i > 1 then
                  begin
                     i := i + 1;
                     if lastdot <> 0 then
                        begin
                           for j := lastdot to len -1 do
                              fname[j] := fname[j+1];
                           len := len - 1;
                           lastdot := 0;
                        end;
                     while len - lastdir > 9 do
                        len := len - 1;
                     len := len + 1;
                     fname[len] := fname[lastdir];
                     fname[lastdir] := '.';
                     lastdir := len
                  end
               else
                  i := i + 1;
            '.':
               if i > 1 then
                  begin
                     if lastdot <> 0 then
                        begin
                           for j := lastdot to len -1 do
                              fname[j] := fname[j+1];
                           len := len - 1;
                        end;
                     while len - lastdir > 9 do
                        len := len - 1;
                     lastdot := len + 1;
                     goto 1
                  end
               else
                  if name[i+1]='/' then
                     i := i + 2
                  else
                     begin
                        lastdot := len + 1;
                        goto 1
                     end;
            ':','_','+','-':
               i := i+1;
         otherwise
1:
            begin
               len := len+1;
               fname[len] := name[i];
               i := i+1;
            end;
         end;
      if lastdot <> 0 then
         while len - lastdot > 3 do
            len := len - 1
      else
         begin
            while len - lastdir > 9 do
               len := len - 1;
            len := len + 1;
            fname[len] := '.';
         end;
      vmsfile:=len;
   end; {vmsfile}
   
   function filesize(fname: name_store): integer;
   var
      ct: integer;
   {
      Returns the number of bytes of the given VMS file by reading the file.
      Bflg indicates whehter or not it is a binary file.
   }
      
   begin {filesize}
      if fname.bin then
         begin
            setupfile(fname.str,fname.len,'BFIL');
            open(bfil,512,OLD,FIXED);
            reset(bfil);
            ct := 0;
            get(bfil);
            while not eof(bfil) do
               begin
                  ct := ct + 512;
                  get(bfil)
               end;
            close(bfil)
         end
      else
         begin
            setupfile(fname.str,fname.len,'CFIL');
            open(cfil,OLD);
            reset(cfil);
            ct := 0;
            while not eof(cfil) do
               begin
                  ct := ct + 1;
                  read(cfil, c);
               end;
            close(cfil)
         end;
      filesize := ct;
   end; {filesize}

   function unixfile(name: filename; var fname: array[integer] of char): integer;
   label
      1;
   var
      len: integer;
      i: integer;
      dir: Boolean;
   {
      Convert the VMS filename to a UNIX tape filename.
   }

   begin {unixfile}
      dir := FALSE;
      i := 0;
      len := 1;
      while name[len] <> ' ' do
         begin
            case name[len] of
            '[':
               begin
                  len := len + 1;
                  dir := TRUE;
                  if name[len] = '.' then
                     begin
                        i := i + 1;
                        fname[i] := '.';
                        len := len + 1
                     end;
                  i := i + 1;
                  fname[i] := '/';
               end;
   
            ']':
               begin
                  dir := FALSE;
                  len := len + 1;
                  i := i + 1;
                  fname[i] := '/';
               end;
   
            '.':
               begin
                  len := len + 1;
                  i := i + 1;
                  if dir then
                     fname[i] := '/'
                  else
                     fname[i] := '.';
               end;
   
            otherwise
               begin
                  i := i + 1;
                  if name[len] in ['A'..'Z'] then
                     fname[i] := chr(ord(name[len])+32)
                  else
                     fname[i] := name[len];
                  len := len + 1
               end;
            end;
            if i = 32 then
               begin
                  while name[len] <> ' ' do len := len + 1;
                  goto 1
               end
         end;
1:    {come here if fname too long}
      while i < 31 do
         begin
            i := i + 1;
            fname[i] := chr(0)
         end;
      unixfile := len-1
   end; {unixfile}

   procedure rewind;
   var
      status: integer;
      c: char;
   {
      Rewind the tape.
   }
   begin {rewind}
      status := sys$qiow(0,tchan,IO$_REWIND,tapeiosb,
                         0,0,c,0,0,0,0,0);
      if status <> 1 then
         begin
         writeln(' sys$qiow rewind status: ', status:8 hex);
         halt;
         end;
      address := 0;
   end; {rewind}

   procedure unload;
   var
      status: integer;
      c: char;
   {
      Rewind the tape off-line.
   }
   begin {unload}
      status := sys$qiow(0,tchan,IO$_REWINDOFF,tapeiosb,
                         0,0,c,0,0,0,0,0);
      if status <> 1 then
         begin
         writeln(' sys$qiow unload status: ', status:8 hex);
         halt;
         end;
      address := 0;
   end; {unload}

   procedure skip(n: integer);
   var
      status: integer;
      junk: record
               case boolean of
                  FALSE: (c: array[1..4] of char);
                  TRUE:  (i: integer);
            end;
   {
      Skip records on the tape.
   }
   begin {skip}
      junk.i := n;
      status := sys$qiow(0,tchan,IO$_SKIPRECORD,tapeiosb,
                         0,0,junk.c[1],0,0,0,0,0);
      if status <> 1 then
         begin
         writeln(' sys$qiow skiprecord status: ', status:8 hex);
         halt;
         end;
   end; {skip}

   procedure writeof;
   var
      status: integer;
      c: char;
   {
      Write an EOF mark on the tape.
   }
   begin {writeof}
      status := sys$qiow(0,tchan,IO$_WRITEOF,tapeiosb,
                         0,0,c,0,0,0,0,0);
      if status <> 1 then
         begin
         writeln(' sys$qiow writeof status: ', status:8 hex);
         halt;
         end;
   end; {writeof}

   procedure writetape(var b: array[integer] of char);
   var
      status: integer;
   {
      Write a block to the tape.
   }
   begin {write}
      status := sys$qiow(0,tchan,IO$_WRITELBLK,tapeiosb,
                         0,0,b[1],BLOCK,0,0,0,0);
      if status <> 1 then
         begin
         writeln(' sys$qiow write status: ', status:8 hex);
         halt;
         end;
      address := address+1;
   end; {writetape}

   procedure addbuf(c: char);
   {
      insert a character into the buffer.
      when the buffer reaches 512 characters, write it to tape.
   }
   begin {addbuf}
      if position <= BLOCK then
         begin
            buffer[position] := c;
            position := position+1;
         end
      else
         begin
         writeln(' addbuf lost block position.');
         halt;
         end;
      if position > BLOCK then
         begin
            writetape (buffer);
            position := 1;
            size := size + BLOCK;
            numblocks := numblocks + 1;              
         end;
   end; {addbuf}

   function readtape(var b: array[integer] of char): integer;
   var
      status: integer;
   {
      Read a block from tape.
   }
   begin {readtape}
      status := sys$qiow(0,tchan,IO$_READLBLK,tapeiosb,
                         0,0,b[1],BLOCK,0,0,0,0);
      if status <> 1 then
         begin
         writeln(' sys$qiow readvblk status: ', status:8 hex);
         halt;
         end;
      readtape := tapeiosb.count;
      address := address+1;
   end; {readtape}

   function getbuf: char;
   var
      i: integer;
   {
      get the next character from the buffer.
      when we run out of characters, read another block from tape.
   }
   begin {getbuf}
      if position > BLOCK then
         begin
            i := readtape(buffer);
            position := 1;
         end;
      if position <= size then
         begin
            getbuf := buffer[position];
            position := position+1;
         end
      else
         getbuf := chr(0);
      if position > BLOCK then
         size := size - BLOCK;
   end; {getbuf}

   function checksum(block: dir_ent): short;
   var
      check: short;
      i: integer;
   {
      Compute the checksum for the passed block (not including the
      checksum itself).
   }
   begin {checksum}
      check := 0;
      for i := 1 to 32 do
         check := check + block.words[i];
      checksum := check mod 65536
   end; {checksum}

   procedure readdir;
   var
      status, i: integer;
   {
      read the first 63 tape blocks.  Block 1 is the bootstrap block,
      2-63 are the tape directory (except for 'stp' format, which
      queezes as much out of a tape as possible by starting files
      in the first unused directory block if the directory is less
      than 62 blocks long).
   }
   begin {readdir}
      i := readtape(boot);
      for i:= 1 to DIRSIZ do
         begin
            if readtape(tapedir[i].blk) <> BLOCK then
               begin
               writeln(' error reading directory: block size = ', tapeiosb.count);
               halt;
               end;
         end;
      rewind;
   end; {readdir}

   procedure fixlong(var entry: dir_ent);
   var
      w: 0..65535;
   begin {fixlong}
      with entry do
         begin
            w:=words[21]; words[21]:=words[22]; words[22]:=w;
         end;
   end; {fixlong}

   procedure typedir(v: boolean);
   label 1;
   var
      i,j,k: integer;
      entries, nblocks: integer;
      last: 0..65535;
      param, ck: integer;
      cvt_time: systime;
      tp: ^string24;
   {
      Print a tape directory.  v tells us whether to just print filenames
      or a whole lot of other junk about the file.
   }
   begin {typedir}
      new(tp);
      entries := 0;
      last := 0;
      readdir;
      if v then {long form header}
       writeln('   mode    uid gid tapa    size     date       time     name');
      for i:=1 to DIRSIZ do
         for j:=1 to 8 do
            with tapedir[i].direct[j] do
               if words[1] = 0 then
                  goto 1
               else with dirent do
                  begin
                     ck := checksum(tapedir[i].direct[j]);
                     if ck <> 0 then
                        begin
                           writeln(ck:8 hex,' checksum error.')
                        end;
                     if old then
                        fixlong(tapedir[i].direct[j]);
                     entries := entries + 1;
                     size := size1 + (size0 * 65536);
                     nblocks := size div 512;
                     if size mod 512 <> 0 then
                        nblocks := nblocks + 1;
                     if tape_address >= last then
                        last := tape_address + nblocks - 1;
                     if v then {long form listing}
                        begin
                           for k := 8 downto 0 do
                              if k in mode then
                                 case k of
                                 0,3,6:
                                    write('x');
                                 1,4,7:
                                    write('w');
                                 2,5,8:
                                    write('r');
                                 end
                              else
                                 write('-');
                           write(' ');
                           param := uid; write(param:3); write(' ');
                           param := gid; write(param:3);
                           write(' ');
                           param := tape_address; write(param:4);
                           write(' ');
                           param := size1 + (size0 * 65536); write(param:8);
                           write(' ');
                           vmstime(time_modified, cvt_time);
                           pr_time.addr := tp;  pr_time.length := 24;
                           sys$asctim(param, pr_time, cvt_time, 0);
                           write(pr_time.addr^:pr_time.length);
                           write(' ':24-pr_time.length+1);
                        end;
                     prname(path_name);
                     writeln;
                  end;
1:
      if i > DIRSIZ then i := DIRSIZ;
      writeln(entries:4,' entries');
      param := last; writeln(param-i:4,' used'); writeln(param:4,' last');
      rewind;
   end; {typedir}

   procedure xtractfiles(v: Boolean);
   label
      1,2,3;
   var
      tpos: integer;
      i,j: integer;
      entries, nblocks: integer;
      last: 0..65535;
      param: integer;
      fname: filename;
{
   Extract the files from the tape, pausing for confirmation if wflg set,
   verbose if vflg set, binary if bflg.
   }
   begin {xtractfiles}
      entries := 0;
      readdir;
      for i:=1 to DIRSIZ do
         for j:=1 to 8 do
            with tapedir[i].direct[j] do
               if words[1] = 0 then
                  goto 3
               else with dirent do
                  begin
                     entries := entries+1;
                     size := size1 + (size0 * 65536);
                     nblocks := size div 512;
                     if size mod 512 <> 0 then
                        nblocks := nblocks + 1;
                     last := tape_address + nblocks -1;
                     param := vmsfile(path_name, fname);
                     if v or wflg then
                        begin write('x '); prname(path_name);
                           write(' => ',fname:param);
                           if v then
                              writeln
                           else
                              begin
                                 write (' '); readln(c);
                                 {if eoln then goto 2;}
                                 case c of
                                    'x','X':
                                       goto 3;
                                    'y','Y':
                                       goto 1;
                                    'b','B':
                                    begin
                                       bflg := TRUE;
                                       goto 1;
                                    end;
                                    't','T':
                                    begin
                                       bflg := FALSE;
                                       goto 1;
                                    end;
                                    otherwise
                                       goto 2
                                 end;
                              end;
                        end;
1:
                     while address < tape_address do
                        tpos := readtape(boot);
                     if bflg then
                        begin
                           setupfile(fname, param, 'BFIL');
                           open(bfil, 512, NEW, FIXED);
                           rewrite(bfil);
                           while address <= last do
                              begin
                                 param := readtape(buffer);
                                 bfil^ := buffer;
                                 put (bfil);
                              end;
                           close(bfil);
                        end
                     else
                        begin
                           setupfile(fname, param, 'XFIL');
                           open(xfil, NEW);
                           rewrite(xfil);
                           tpos := 0;
                           position := BLOCK + 1;
                           c := getbuf;
                           while c <> chr(0) do
                              begin
                                 if (c = chr(NEWLINE)) then
                                    begin
                                       writeln(xfil);
                                       tpos := 0;
                                    end
                                 else
                                    begin
                                       if tpos > LINELEN then
                                          begin
                                             writeln(xfil);
                                             tpos := 1;
                                          end
                                       else
                                          tpos := tpos + 1;
                                       write(xfil,c);
                                    end;
                                 c := getbuf;
                              end;
                           close(xfil);
                        end;
2:
                     while address <= last do
                        param := readtape(boot);
                  end;
3:
      rewind;
   end; {xtractfiles}

   function makedir: integer;
   label
      1;
   var
      fname: array[1..32] of char;
      size,entries: integer;
      i,j,k,l: integer;
      nblock: integer;
      cum_address: integer;

   {
      Create the first 63 tape blocks.  Block 1 is the bootstrap block,
      2-63 are the tape directory. 1 block for every 8 filename will be
      used.
   }

   begin {makedir}
      nblock := 0;
      cum_address := 63;
      entries := 0;
      getfname(names[entries+1].str);
      while (names[entries+1].str[1] <> ' ') and (entries <= 496) do
         begin
            i := (entries div 8) + 1;
            j := (entries mod 8) + 1;
            entries := entries + 1;
            with tapedir[i].direct[j].dirent do
               begin
                  names[entries].len := unixfile(names[entries].str,fname);
                  path_name := fname;
                  if vflg or wflg then
                     begin
                        write('r ');
                        write(names[entries].str:names[entries].len);
                        write(' => ');
                        prname(path_name);
                        if wflg then
                           begin
                              write(' ');
                              readln(c);
                              case c of
                              'B','b':
                                 bflg := TRUE;
                              'T','t':
                                 bflg := FALSE;
                              'N','n':
                                 begin
                                    entries := entries - 1;
                                    goto 1
                                 end;
                              'R','r',
                              'Y','y':
                                 ;
                              end
                           end
                        else
                           writeln
                     end;
                  names[entries].bin := bflg;
                  size := filesize(names[entries]);
                  mode := [2,5,8,4,7]; {-rw-rw-r--}
                  uid := 0; gid := 1;
                  size0 := size div 65536;
                  size1 := size mod 65536;
                  time_modified := unixtime(file_time);
                  tape_address := cum_address;
                  chksum := -checksum(tapedir[i].direct[j]);
               end;
            cum_address := cum_address + (size + 511) div 512;
1:
            getfname(names[entries+1].str);
         end;
      if j < 8 then
         for k := j + 1 to 8 do
            for l := 1 to 32 do
               tapedir[i].direct[k].words[l] := 0;
      for k := i+1 to DIRSIZ do
         for j := 1 to BLOCK do
            tapedir[k].blk[j] := chr(0);
      makedir := entries;
   end; {makedir}

   procedure createtape;
   var
      entries: integer;
      i,j,k,last: integer;
      fname: filename;

   {
      This procedure writes the VMS files into the tape after all filenames to
      be written should be given.
   }

   begin {createtape}
      entries := makedir;
      if entries > 0 then
         begin
            rewind;
            writetape(boot);
            for k := 1 to DIRSIZ do
               writetape(tapedir[k].blk);
            for k := 1 to entries do
               begin
                  if vflg then
                     writeln('r ',names[k].str:names[k].len);
                  if names[k].bin then
                     begin
                        setupfile(names[k].str,names[k].len,'BFIL');
                        open(bfil,512,OLD,FIXED);
                        reset(bfil);
                        get(bfil);
                        while not eof(bfil) do
                           begin
                              buffer := bfil^;
                              writetape(buffer);
                              get(bfil)
                           end;
                        close(bfil)
                     end
                  else
                     begin
                        setupfile(names[k].str, names[k].len, 'CFIL');
                        open(cfil, OLD);
                        reset(cfil);
                        while not eof(cfil) do
                           begin
                              read(cfil, c);
                              addbuf(c);
                              while eoln(cfil) and (not eof(cfil)) do
                                 begin
                                    addbuf(chr(NEWLINE));
                                    if not eof(cfil) then readln(cfil)
                                 end;
                           end;
                        while position > 1 do addbuf(chr(0));
                        close(cfil)
                     end
               end;
            writeof;
            writeof;
            writeln(entries:4,' entries');
            i := address - 1;
            writeln(i-DIRSIZ:4,' used');
            writeln(i:4,' last');
            rewind;
         end;
   end; {createtape}

   procedure init;
   var
      fp: ^string24;
      fd: timstr;

   procedure sys$bintim(var timbuf: timstr; var timaddr: systime); extern;

   procedure sys$cli(var reqdesc: clireqdesc); extern;

   begin {init}
   {get command line}
      getcmd.rqtype := CLI$K_GETCMD;
      sys$cli(getcmd);
   {get UNIX base time}
      new(fp); fp^ := unix_base;
      fd.length := 24;
      fd.addr := fp;
      sys$bintim(fd, base_diff);
   {get current VMS time}
      fp^ := today; 
      fd.length := 6; fd.addr := fp;
      sys$bintim(fd, file_time);
   end; {init}

begin {tp}
   init;
{  writeln(getcmd.rqdesc.addr^:getcmd.rqdesc.length); }
   i := 1;
   with getcmd.rqdesc do
   while i <= length do
      begin
         case addr^[i] of
         't','T':
            tflg := TRUE;
         'x','X':
            xflg := TRUE;
         'v','V':
            vflg := TRUE;
         'w','W':
            wflg := TRUE;
         'b','B':
            bflg := TRUE;
         'o','O':
            old := TRUE; {swap words of date}
         'c','C':
            cflg := TRUE;
         '0','1','2','3','4','5','6','7','8','9':
            tape[5] := addr^[i];
         end;
         i := i+1;
      end;
   setuptape;
   if tflg then
      begin
         if wflg or xflg or bflg or cflg then
            writeln('Bad usage.')
         else
            typedir(vflg);
      end
   else
   if xflg then
      begin
         if tflg or cflg then
            writeln('Bad usage.')
         else
            xtractfiles(vflg);
      end
   else
   if cflg then
      begin
         if xflg or tflg then
            writeln('Bad usage.')
         else
            createtape;
      end;
   writeln('End');
end. {tp}
