program ar11 (input,output,afil,xfil,bfil);
{$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 }
   TAB = %x09;
   NEWLINE = %x0A;
   ESC = %x1B;

   {Conversion of UNIX time in seconds to VMS time in 100-nanoseconds}
   TIME_DIFF = 10000000;
   { data structure sizes }
   LINELEN = 133;
   ARBUFSIZ = 26;
   BLOCK = 512;
   { Archiver Magic Number }
   ARMAG = %o177545;

type
   filename = packed array[1..14] of char;
   string63 = packed array[1..63] of char;
   string24 = packed array[1..24] of char;
   string4 = packed array[1..4]  of char;
   textline = packed array[1..LINELEN] of char;
   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;
   ar_blk = array [1..BLOCK] of char;
   ar_head = packed record
                       name: array [1..14] of char;
                       date: integer;
                       uid,
                       gid: 0..255;
                       mode: packed set of 0..15;
                       size: integer;
             end;
   ar_ent = record
               case boolean of
                  FALSE: (chars: array [1..ARBUFSIZ] of char);
                  TRUE: (arent: ar_head);
            end;
   ar_mag = packed record
                      case Boolean of
                         FALSE: (chars: array [1..2] of char);
                         TRUE: (magic: 0..65535);
            end;

var
   xfil: text;
   afil: file of ar_blk;
   bfil: file of ar_blk;
   bflg: Boolean;
   arname: filename;
   arlen: integer;
   null: filename;
   flags: Boolean;
   line: textline;
   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;
   buffer: ar_blk;
   arbuf: ar_ent;
   position: integer;
   getcmd: clireqdesc;
   wflg: boolean;
   vflg: boolean;
   tflg: boolean;
   xflg: boolean;
   i: integer;
   c: char;

value
   line := (LINELEN of ' ');
   buffer := (BLOCK of ' ');
   null := '_NLA0:        ';
   arname := 'CONT.A        ';
   arlen := 6;
   flags := TRUE;   {Initially reading flags from the command line}
   unix_base := '1-JAN-1970 00:00:00.00  ';
   off_time := (TIME_DIFF, 0);
   position := 1;
   bflg := FALSE;
   wflg := FALSE;
   vflg := FALSE;
   tflg := FALSE;
   xflg := 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 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}
   end; {unixtime}

   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}

   function vmsfile(name: array[integer] of char; var fname: filename): integer;
   label
      1;
   var
      len,lastdot: 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 := 0;
      lastdot := 0;
      while (name[i] <> chr(0)) and (i <= upper(name)) do
         case name[i] of
            '/':
               begin
                  i := i + 1;
                  len := 0;
               end;
            '.':
               begin
                  if lastdot <> 0 then
                     begin
                        for j := lastdot to len - 1 do
                           fname[j] := fname[j+1];
                        len := len - 1;
                     end;
                  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) and (len > 9) then
         len := 9;
      if lastdot > 0 then
         while len - lastdot > 3 do
            len := len - 1;
      vmsfile:=len;
   end; {vmsfile}

   procedure addbuf(c: char);
   {
      insert a character into the buffer.
      when the buffer reaches 512 characters, write it to the archive.
   }
   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
            write (afil,buffer);
            position := 1;
         end;
   end; {addbuf}

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

   function getaf: Boolean;
   var
      magic: ar_mag;
   {
      Open an archive file and see if the Magic Number is correct.
   }
   begin {getaf}
      open(afil, OLD, FIXED);
      reset(afil);
      position := BLOCK + 1;
      magic.chars[1] := getbuf;
      magic.chars[2] := getbuf;
      if magic.magic = ARMAG then
         begin
            getaf := TRUE;
         end
      else
         begin
            close(afil);
            getaf := FALSE;
         end;
   end; {getaf}

   procedure fixlong;
   begin {fixlong}
      with arbuf do
         begin
         {swap words in size}
            c:=chars[25]; chars[25]:=chars[23]; chars[23]:=c;
            c:=chars[26]; chars[26]:=chars[24]; chars[24]:=c;
         {swap words in date}
            c:=chars[17]; chars[17]:=chars[15]; chars[15]:=c;
            c:=chars[18]; chars[18]:=chars[16]; chars[16]:=c;
         end;
   end; {fixlong}

   function getdir: Boolean;
   begin {getdir}
      if not eof(afil) then
         begin
            for i := 1 to ARBUFSIZ do
               arbuf.chars[i] := getbuf;
            fixlong;
            if (arbuf.chars[1] <> chr(0)) and (arbuf.arent.size > 0) then
               getdir := TRUE
            else
               getdir := FALSE;
         end
      else
         getdir := FALSE;
   end; {getdir}

   procedure typedir(v: boolean);
   var
      i,j,k: integer;
      param: integer;
      cvt_time: systime;
      tp: ^string24;
   {
      Print a archive directory.  v tells us whether to just print filenames
      or a whole lot of other junk about the file.
   }
   begin {typedir}
      new(tp);
      if v then {long form header}
       writeln('   mode    uid gid    size     date       time     name');
      if getaf then
         while getdir do
            with arbuf.arent do
               begin
                  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(' ');
                        write(size:8);
                        write(' ');
                        vmstime(date, 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(name);
                  writeln;
                  if odd(size) then
                     size := size + 1;
                  while (size > 0) and not eof(afil) do
                     begin
                        size := size - 1;
                        c := getbuf;
                     end;
               end;
   end; {typedir}

   procedure xtractfiles(v: Boolean);
   label
      1,3;
   var
      tpos: integer;
      i,j: integer;
      param: integer;
      fname: filename;
      buf: ar_blk;
   begin {xtractfiles}
      if getaf then
         while getdir do
            with arbuf.arent do
                  begin
                     param := vmsfile(name, fname);
                     if v or wflg then
                        begin write('x '); prname(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':
                                    begin
                                       bflg := FALSE;
                                       goto 1;
                                    end;
                                    'b','B':
                                    begin
                                       bflg := TRUE;
                                       goto 1;
                                    end;
                                    otherwise
                                    begin
                                       for i := 1 to 6 do
                                          fname[i] := null[i];
                                       param := 6;
                                    end;
                                 end;
                              end;
                        end;
1:
                     if bflg then
                        begin
                           setupfile(fname, param, 'BFIL');
                           open(bfil, 512, NEW, FIXED);
                           rewrite(bfil);
                           while size > 0 do
                              begin
                                 if size > BLOCK then
                                    j := BLOCK
                                 else
                                    begin
                                       if odd(size) then
                                          size := size + 1;
                                       j := size;
                                    end;
                                 for i := 1 to j do
                                    buf[i] := getbuf;
                                 if j < BLOCK then
                                    for i := j+1 to BLOCK do
                                       buf[i] := chr(0);
                                 write(bfil,buf);
                                 size := size - j;
                              end;
                           close(bfil);
                        end
                     else
                        begin
                           setupfile(fname, param, 'XFIL');
                           open(xfil, NEW);
                           rewrite(xfil);
                           tpos := 0;
                           for i := size downto 1 do
                              begin
                                 c := getbuf;
                                 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;
                              end;
                           if odd(size) then
                              c := getbuf;
                           close(xfil);
                        end;
                  end;
3:
   end; {xtractfiles}

   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);
   end; {init}

begin {ar11}
   init;
{  writeln(getcmd.rqdesc.addr^:getcmd.rqdesc.length); }
   i := 1;
   with getcmd.rqdesc do
   while i <= length do
      begin
         if flags then
            case addr^[i] of
            't','T':
               tflg := TRUE;
            'x','X':
               xflg := TRUE;
            'v','V':
               vflg := TRUE;
            'w','W':
               wflg := TRUE;
            'b','B':
               bflg := TRUE;
            ' ':
               begin
                  arlen := 0;
                  flags := FALSE; {start looking for file names}
               end;
            end
         else
            begin
               arlen := arlen + 1;
               arname[arlen] := addr^[i];
            end;
         i := i+1;
      end;
   setupfile(arname,arlen,'AFIL');
   if tflg then
      begin
         if wflg or xflg or bflg then
            writeln('Bad usage.')
         else
            typedir(vflg);
      end
   else
   if xflg then
      begin
         if tflg then
            writeln('Bad usage.')
         else
            xtractfiles(vflg);
      end;
   writeln('End');
end. {ar11}