PROGRAM ldir(cmd, input, output);
(* Replacement program, with enhancements etc. *)
(* By C.B. Falconer, 680 Hartford Tpk.,        *)
(*    Hamden, Conn. 06517                      *)
(* Intended to replace the original by Gary P. *)
(* Novosielski, but operate with the PascalP   *)
(* system, and port to other machines, such as *)
(* the HP3000.  Steps have been taken to insu- *)
(* late the library format from the native     *)
(* machine storage formats. Interactive use is *)
(* an enhancement, as is provision for a date  *)
(* modified entry in the library directory.    *)
(* The automatic disk system disk searches are *)
(* in effect.                                  *)

(* 1.9 - 86/2/23 Test for directory header was *)
(*       blank name, changed to location=0 for *)
(*       NULU compatibility.  Weakened test    *)
(*       for directory validity, for MSDOS     *)
(*       compatibility (some bad progs). cbf   *)
(* 1.8 - 85/10/16 - Provided RCPM constant for *)
(*       eliminating file redirection, when    *)
(*       used on RCPM systems.  Speed-up of    *)
(*       directory sort (previous was very     *)
(*       poor on pre-sorted directories).      *)
(* 1.7 - 84/12/06 - Removed restrictions on    *)
(*       chars in file names - up to system.   *)
(* 1.6 - 83/12/31 - Allowed for HP3000 user    *)
(*       interface (no cmd line).  Added a     *)
(*       default "unsorted" option             *)
(* 1.5 - 83/12/30 - Added -g sorting option    *)
(* 1.4 - 83/12/30 - Separated directory load   *)
(*       and directory sort, speedup disk opn  *)
(* 1.3 - 83/12/21 - Minor code compression.    *)
(* 1.2 - 83/12/20 - Re-organized to speed up.  *)
(*       directories sorted for display.       *)
(*       date command now "M", avoid conflicts *)
(* 1.1 - 83/12/12 - converted DR format date.  *)
(*       removed file error after not found.   *)

  CONST
    ver         = 'Ver. 1.9 ';  (* initial version 83/12/11 *)
    verbbs      = 'Ver. 1.9  (RCPM)';  (* when no re-direction etc. *)
    binrcdmax   = 63;
    fnmsize     = 28;
    notRCPM     = true;    (* false removes the help message on    *)
                           (* file re-direction.  Physical removal *)
                           (* depends on linking performed.        *)
  TYPE
    byte        = char;
    binfptr     = 0..binrcdmax;
    binfile     = FILE OF ARRAY[binfptr] OF byte;
    err         = (badcrc, notlib, cantfind, badoption, needlib);
    fname       = PACKED ARRAY[1..fnmsize] OF char;

    direntry    = RECORD
      status      : byte;
      name        : ARRAY[1..8] OF byte;
      ext         : ARRAY[1..3] OF byte;
      location,
      size,
      crcval,
      modified    : integer;
      spare       : ARRAY[1..12] OF byte;
      END; (* direntry *)

    dirptr      = ^dirchunk;
    dirchunk    = RECORD
      next,
      left,
      right       : dirptr;
      dir         : direntry;
      END; (* dirchunk *)

    sortkind    = (unsorted, byname, bygroup);

  VAR
    cmd         : text;               (* command line *)

    (* quasi constants *)
    fnchars     : SET OF char;  (* allowed in file names *)

  (* 1---------------1 *)

(*$i'skipblks.inc'*)
(*$i'skipto.inc'*)
(*$i'skprdrkt.inc'*)
(*$i'drtodate.inc'*)
(*$i'loaddir.inc'*)
(*$i'sortdir.inc'*)
  PROCEDURE signon;

    BEGIN (* signon *)
    write('LDIR (cmd, input, output); ');
    IF notRCPM THEN write(ver)
    ELSE write(verbbs);
    writeln(' (c) 1983, 1986 by C.B. Falconer');
    writeln(' Execute with "ldir {[options] [libfname]}"');
    writeln(' where {} shows a field that may be repeated and []');
    writeln(' enclose optional fields.  "options" is the character');
    writeln(' "-" followed by one or more of:');
    writeln('     n   sort by name          u   unsorted(default)');
    writeln('     g   sort by "typ"         m   date modified');
    writeln('     s   sectors of storage    k   kilobytes (size)');
    writeln('EXAMPLE:  B>ldir -m command');
    writeln('Commands may be placed on the command line or executed');
    writeln(' interactively on ">" prompt. "fname>" shows an open');
    writeln(' library, and -options will display its directory');
    IF notRCPM THEN BEGIN
      writeln('File redirection using "<", ">" is available');
      writeln('To list command.lbr on the lister, enter:');
      writeln('  B>ldir command >lst'); END
    ELSE writeln('You must be logged onto the drive/user area');
    writeln;
    END; (* signon *)

  (* 1---------------1 *)

  PROCEDURE docommands(VAR cf : text; interactive : boolean);

    TYPE
      option      = (bad, lopen, nosort, name, group,
                     sectors, kbytes, date);
      optionset   = SET OF option;

    VAR
      exit        : boolean;
      options     : optionset;
      libfile     : binfile;
      fnm         : fname;
      dircrc,
      crcwd       : integer;
      root        : dirptr;

    (* 2---------------2 *)

    PROCEDURE signal(x : err);

      BEGIN (* signal *)
      write('** ERROR ** ');
      CASE x OF
  badcrc:
        write('Bad directory CRC');
  notlib:
        write('Not a library: ', fnm);
  cantfind:
        write('Cannot find: ', fnm);
  badoption:
        write('Bad option');
  needlib:
        write('No library specified');
        END; (* case *)
      writeln;
      END; (* signal *)

    (* 2---------------2 *)

    PROCEDURE fill(VAR options : optionset; VAR cf : text);

      VAR
        o  : option;

      BEGIN (* fill *)
      IF cf^ = '-' THEN BEGIN
        get(cf); options := [];
        WHILE (cf^ <> ' ') DO BEGIN
          CASE cf^ OF
'S','s':    o := sectors;
'K','k':    o := kbytes;
'M','m':    o := date;
'N','n':    o := name;
'G','g':    o := group;
'U','u':    o := nosort;
(*$s-*)   OTHERWISE o := bad; END; (*$s+ case *)
          options := options + [o]; get(cf); END;
        END;
      END; (* fill *)

    (* 2---------------2 *)

    PROCEDURE open;

      VAR
        i          : integer;

      BEGIN (* open *)
      IF NOT ((name IN options) OR (group IN options)) THEN
        options := options + [nosort];
      IF root <> NIL THEN BEGIN
        release(root); root := NIL; END;
      i := 1;
      IF cf^ IN fnchars THEN
        REPEAT
          IF i < fnmsize THEN BEGIN
            read(cf, fnm[i]); i := succ(i); END
          ELSE get(cf);
        UNTIL NOT (cf^ IN fnchars)
      ELSE BEGIN
(*$s-*) fnm[1 FOR 7] := 'LIBRARY'; i := 8; END; (*$s+*)
      FOR i := i TO fnmsize DO fnm[i] := ' ';
      skipto(' ', cf);
{}    IF scanfor('.', fnm[1], fnmsize) = 0 THEN BEGIN
        (* no ".", force .LBR extension *)
{}      i := scanfor(' ', fnm[1], fnmsize);
        IF i < fnmsize - 5 THEN
(*$s-*)   fnm[i FOR 5] := '.LBR '; END;
      IF exists(libfile, fnm) THEN BEGIN
(*$s+*) filename(libfile, fnm) (* to standardize on system format *);
        crcwd := 0;
        IF loaddir(libfile, root, dircrc, crcwd) THEN BEGIN
          IF (dircrc <> 0) AND (dircrc <> crcwd) THEN signal(badcrc);
          options := options - [lopen]; END
        ELSE BEGIN
          signal(notlib);
          close(libfile); (* prevent display *) END;
        END
      ELSE signal(cantfind);
      END; (* open *)

    (* 2---------------2 *)

    PROCEDURE display(VAR options : optionset);

      CONST
        scrnsize     = 80;
        scrnlns      = 20;
        maxhead      = 40;

      VAR
        hlgh,
        i, j,
        itemsfree,
        itemsonline,
        itemsrejected,
        itemsput,
        linesput,
        perline      : integer;
        hd           : PACKED ARRAY[1..maxhead] OF char;
        dateline     : PACKED ARRAY[1..15] OF char;
        displayroot  : dirptr;

      (* 3---------------3 *)

      PROCEDURE writedate(modified : integer);
      (* Convert Digital Research Format to real life *)

        VAR
          year, month, day : integer;

        (* 4-----------------4 *)

        PROCEDURE leadingzeros(i : integer); (* range 0..99 only *)

          BEGIN (* leadingzeroes *)
          IF i < 10 THEN write('0');
          write(i : 1);
          END; (* leadingzeroes *)

        (* 4-----------------4 *)

        BEGIN (* writedate *)
        drtodate(modified, year, month, day);
        write(' ');
        leadingzeroes(year MOD 100); write('/');
        leadingzeroes(month); write('/');
        leadingzeroes(day);
        END; (* writedate *)

      (* 3---------------3 *)

      PROCEDURE putitem(d : dirptr);

        BEGIN (* putitem *)
        WITH d^.dir DO BEGIN
          IF (status = chr(0)) AND (location <> 0) THEN BEGIN
            IF itemsonline = 0 THEN BEGIN
              IF interactive AND (linesput = scrnlns) THEN BEGIN
                prompt('<cr>'); linesput := 0; readln; END
              ELSE BEGIN
                writeln; linesput := succ(linesput); END;
              END
            ELSE write(' | ');
            write(name, '.', ext);
            IF sectors IN options THEN write(size : 8);
            IF kbytes IN options THEN write((size + 7) DIV 8 : 7);
            IF date IN options THEN
              IF modified <= 0 THEN write('unknown' : 9)
              ELSE writedate(modified);
            itemsput := succ(itemsput);
            itemsonline := succ(itemsonline) MOD perline; END
          ELSE IF status = chr(255) THEN
            itemsfree := succ(itemsfree)
          ELSE IF status <> chr(0) THEN (* eliminate dir entry *)
            itemsrejected := succ(itemsrejected); END;
        END; (* putitem *)

      (* 3---------------3 *)

      PROCEDURE showdir(root : dirptr);

        BEGIN (* showdir *)
        IF root <> NIL THEN BEGIN
          showdir(root^.left);
          putitem(root);
          showdir(root^.right); END;
        END; (* showdir *)

      (* 3---------------3 *)

      BEGIN (* display *)
      dater(dateline);
      writeln(dateline, 'Library ', fnm);
      FOR hlgh := 1 TO maxhead DO hd[hlgh] := ' ';
      hlgh := 1;
(*$s-*)
      hd[hlgh FOR 4] := 'Name';
      hd[hlgh + 9 FOR 3] := 'Typ'; hlgh := hlgh + 13;
      IF sectors IN options THEN BEGIN
        hd[hlgh FOR 7] := 'Sectors'; hlgh := hlgh + 8; END;
      IF kbytes IN options THEN BEGIN
        hd[hlgh FOR 6] := 'Kbytes'; hlgh := hlgh + 7; END;
      IF date IN options THEN BEGIN
        hd[hlgh FOR 8] := 'Modified'; hlgh := hlgh + 9; END;
(*$s+*)
      perline := (scrnsize + 2) DIV succ(hlgh);
      hlgh := hlgh - 2; (* started at 1 and final blank allocated *)
      write(hd : hlgh);
      FOR i := 2 TO perline DO write(' ' : 3, hd : hlgh);
      writeln;
      FOR j := 1 TO hlgh DO write('-');
      FOR i := 2 TO perline DO BEGIN
        write(' ' : 3);
        FOR j := 1 TO hlgh DO write('-'); END;
      (* first output item does the writeln *)
      itemsput := 0; itemsrejected := 0; itemsfree := 0;
      itemsonline := 0; linesput := 2;
      IF group IN options THEN BEGIN
        sortdir(root, bygroup, displayroot);
        options := options - [group, name, nosort]; END;
      IF name IN options THEN BEGIN
        sortdir(root, byname, displayroot);
        options := options - [name, nosort]; END;
      IF nosort IN options THEN BEGIN
        sortdir(root, unsorted, displayroot);
        options := options - [nosort]; END;
      showdir(displayroot); writeln;
      writeln(itemsput : 1, ' entries, ',
              itemsrejected : 1, ' inactive, ',
              itemsfree : 1, ' free entries');
      writeln;
      END; (* display *)

    (* 2---------------2 *)

    BEGIN (* docommands *)
    root := NIL; options := [lopen]; fnm[1] := ' ';
    REPEAT
      IF interactive THEN BEGIN
        IF status(libfile) <> 0 THEN
          write(fnm : pred(scanfor(' ', fnm, fnmsize)))
        ELSE write('?');
        prompt('>'); END;
      skipredirection(cf);
      exit := eoln(cf) OR eof(cf);
      IF NOT exit THEN BEGIN
        IF cf^ = '-' THEN fill(options, {from} cf)
        ELSE options := [lopen, nosort];
        skipredirection(cf);
        IF cf^ IN fnchars THEN options := options + [lopen];
        IF bad IN options THEN BEGIN
          signal(badoption);
          options := options - [bad];
          IF interactive THEN readln
          ELSE exit := true; END
        ELSE BEGIN
          IF (lopen IN options) THEN open
          ELSE IF status(libfile) = 0 THEN signal(needlib);
          exit := (status(libfile) = 0);
          IF interactive THEN readln;
          IF exit THEN BEGIN
            IF interactive THEN exit := false; (* only  null line *)
            options := options + [lopen]; END
          ELSE display({libfile directory} options); END;
        END;
    UNTIL exit;
    END; (* docommands *)

  (* 1---------------1 *)

  BEGIN (* ldir *)
  fnchars := [succ(' ')..'~']      (* ascii coding dependant *)
      -  ['=', ',', '_', '.', ',', ';', '<', '>', '[', ']'];
  IF exists(cmd) THEN BEGIN
    skipredirection(cmd);
    IF NOT eoln(cmd) THEN docommands(cmd, false)
    ELSE BEGIN
      signon; docommands(input, true); END;
    END
  ELSE BEGIN
    signon; docommands(input, true); END;
  END. (* ldir *)