PROGRAM lsetdate(cmd, input, output);
(* An adjunct to Gary P. Novosielski's library system     *)
(* To set "modified" dates in  libraries.  This will set  *)
(* those dates that are found to be zero, i.e. unknown,   *)
(* entries, including deleted but not free entries, or    *)
(* the entries for a specified module sub-set.  Directory *)
(* entry itself is specifically included, although LU     *)
(* itself discards that entry on any re-organization.     *)
(* LU 3.0 and later, also NULU 1.5 up, preserve dates on  *)
(* a re-organization. LU zeroes new entries, NULU doesn't *)
(*                                                        *)
(* Calling sequence:                                      *)
(* B>runpcd lsetdate libraryname date module              *)
(*   with date and module optional.  If omitted the date  *)
(* will be extracted from the system, if available, and   *)
(* if not available simply exit with an error message. If *)
(* module is omitted all undated entries are dated.  The  *)
(* format for date is "yy/mm/dd" with two digits per item.*)
(* yy < 66 is treated as 21st century. 67..77 reset date. *)

(* 1.2 - 86/2/26 Fixed requirement for blank after date.  *)
(* 1.1 - 86/2/24 Added third parameter to individually    *)
(*       select library components to date.  This caters  *)
(*       to NULU which does not clear dates. Weakened the *)
(*       library validity test to cater to some MSDOS     *)
(*       programs, which do not blank the dir[0] name.    *)
(*       Will now only update active (not deleted) entry. *)
(* 1.0 - 83/12/14 - C.B. Falconer - initial version.      *)

(*$n-,d- 84/12/04 removed run-time checks, no change. cbf *)

  CONST
    header     =
        'LSETDATE Ver. 1.2 Copyright (c) 1983, 1986 by C.B. Falconer';
    binrcdmax  = 63;
    fnmsize    = 28;                   (* handles most systems *)
    datelnsz   = 15;

  TYPE
    byte       = char;                 (* 0..255 packed *)
    hexdig     = 0..15;
    dateln     = PACKED ARRAY[1..datelnsz] OF char;
    fname      = PACKED ARRAY[1..fnmsize] OF char;
    binfptr    = 0..binrcdmax;
    binfile    = FILE OF ARRAY[binfptr] OF byte;
    err        = (needate, notlib, cantfind, crcerr);

  VAR
    dateline   : dateln;
    cmd        : text;
    libfile    : binfile;
    libfname   : fname;
    mdlname    : fname;
    digits     : SET OF '0'..'9';
    size,                              (* of directory *)
    dircrc     : integer;              (* extracted from dir[0] *)

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

(*$i'skipblks.inc'*)
(*$i'skipto.inc'*)
(*$i'skprdrkt.inc'*)
(*$i'drdate.inc'*)
(*$i'setname.inc'*)
  PROCEDURE help;

    BEGIN (* help *)
    writeln;
    writeln(header);
    writeln('To set module modified dates in LU libraries for');
    writeln('all modules not already dated:');
    writeln('  B>lsetdate libraryname YY/MM/DD');
    writeln('To unconditionally redate individual modules use:');
    writeln('  B>lsetdate lbrname YY/MM/DD modulename');
    writeln('Wildcards accepted. *.* equivalent to no entry');
    writeln('YY/MM/DD is the date to be set.  Mandatory if the');
    writeln('system does not supply the current date, otherwise');
    writeln('overrides system date.');
    END; (* help *)

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

  PROCEDURE signal(x : err);

    LABEL 1;

    BEGIN (* signal *)
    write('*** ERROR *** ');
    CASE x OF
crcerr:
      BEGIN
      writeln('CRC directory error, bad library: ', libfname);
      prompt(chr(7), '^C aborts, <ret> continues');
      readln; GOTO 1;
      END;
notlib:
      write('Not a library: ', libfname);
cantfind:
      write('Can''t find ', libfname);
needate:
      write('No system date or invalid date format');
      END;
    writeln; help;
1:  END; (* signal *)

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

  PROCEDURE setdate(VAR f : text; VAR d : dateln);

    VAR
      i  : integer;
      d1 : dateln;

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

    FUNCTION getfield(min, max : integer; delimiter : char) : boolean;

      VAR
        j  : integer;

      BEGIN (* getfield *)
      getfield := false;
      FOR j := 0 TO 2 DO 
        IF eoln(f) THEN d1[i + j] := ' '
        ELSE read(f, d1[i + j]);
      IF (d1[i + 2] = delimiter) AND
         (d1[i] IN digits) AND (d1[succ(i)] IN digits) THEN BEGIN
        j := 10*(ord(d1[i]) - ord('0')) + ord(d1[succ(i)]) - ord('0');
        IF (j >= min) AND (j <= max) THEN getfield := true; END;
      i := i + 3;
      END; (* getfield *)

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

    BEGIN (* setdate *)
    i := 1; d := '00/00/00  0:00 '; (* default for error *)
    IF getfield(0, 99, '/') THEN
      IF getfield(1, 12, '/') THEN
        IF getfield(1, 31, ' ') THEN d := d1;
    END; (* setdate *)

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

  FUNCTION verify(VAR l : binfile;
                  VAR size, dircrc : integer) : boolean;
  (* l just opened, so l^ holds initial record *)
  (* This code is NOT portable across 16 bit   *)
  (* systems.  See LDIR for suitable coding.   *)
  (* Should test for blank name but some MSDOS *)
  (* programs put the library name there.      *)

    BEGIN (* ferify *)
    size := mergebytes(ord(l^[15]), ord(l^[14]));
    verify := (l^[0] = chr(0)) AND (l^[1] < chr(127)) AND
              (size > 0) AND (size < 8192) AND
              (mergebytes(ord(l^[13]), ord(l^[12])) = 0);
    dircrc := mergebytes(ord(l^[17]), ord(l^[16]));
    l^[17] := chr(0); l^[16] := chr(0); (* for dir crc calc. *)
    END; (* verify *)

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

  PROCEDURE revise(VAR l : binfile; dateline : dateln;
                   size : integer);
    CONST
      debug     = true;

    TYPE
      mnametype = PACKED ARRAY[1..11] OF char;
      binchunk  = ARRAY[binfptr] OF byte;
      binrecptr = ^binrecd;
      binrecd   = RECORD
        next      : binrecptr;
        recd      : binchunk;
        END; (* binrecd *)

    VAR
      current,
      root      : binrecptr;
      i, hi, lo,
      crcwd     : integer;
      mname     : mnametype;

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

    PROCEDURE storechunk;

      VAR
        i     : integer;

      BEGIN (* storechunk *)
      new(current^.next); current := current^.next;
      current^.recd := l^; get(l);
      FOR i := 0 TO binrcdmax DO crc(current^.recd[i], crcwd);
      END; (* storechunk *)

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

    PROCEDURE setupdate;

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

      PROCEDURE installdateat(ix : integer);

        BEGIN (* installdateat *)
        l^[ix + 19] := chr(hi); l^[ix + 18] := chr(lo);
        END; (* installdateat *)

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

      PROCEDURE chkmatchat(ix : integer);
      (* implements wild card matching against l^[ix] *)

        LABEL 1;

        VAR
          i   : integer;

        BEGIN (* chkmatchat *)
        IF l^[ix] = chr(0) THEN BEGIN (* live entry *)
          FOR i := 1 TO 11 DO
            IF (l^[i + ix] <> mname[i]) AND (mname[i] <> '?') THEN
               GOTO 1; (* no match *)
          (* match, update the date *)
          installdateat(ix); END;
   1:   END; (* chkmatchat *)

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

      PROCEDURE chknodateat(ix : integer);
      (* implements setting of any unset dates l^[ix] *)

        BEGIN (* chknodateat *)
        IF (l^[ix] = chr(0)) AND
           (l^[ix + 19] = chr(0)) AND (l^[ix + 18] = chr(0)) THEN
          installdateat(ix);
        END; (* chknodateat *)

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

      BEGIN (* setupdate *)
(*$s-*)
      IF mdlname[1 FOR 3] = '*.*' THEN BEGIN (* all undated *)
(*$s+*) chknodateat(0); chknodateat(32); END
      ELSE BEGIN               (* update the specific entry *)
        chkmatchat(0); chkmatchat(32); END;
      END; (* setupdate *)

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

    PROCEDURE putchunk;

      VAR
        i     : integer;

      BEGIN (* putchunk *)
      l^ := current^.recd; setupdate;
      FOR i := 0 TO binrcdmax DO crc(l^[i], crcwd);
      put(l); current := current^.next;
      END; (* putchunk *)

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

    PROCEDURE standardize(VAR mdlname : fname; VAR mname : mnametype);
    (* input wild string format to directory format *)

      VAR
        i, j     : integer;

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

      FUNCTION upshift(VAR ch : char) : char;

        BEGIN (* upshift *)
        IF ch IN ['a'..'z'] THEN ch := chr(ord(ch) - 32);
        upshift := ch;
        END; (* upshift *)

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

      BEGIN (* standardize *)
      i := 0;
      REPEAT
        i := succ(i);
      UNTIL upshift(mdlname[i]) = ' ';
      i := 1; j := 1; mname := '           ';

      WHILE (i <= 8) AND NOT (mdlname[i] IN [' ', '.', '*']) DO BEGIN
        mname[j] := mdlname[i]; i := succ(i); j := succ(j); END;
      IF mdlname[i] = '*' THEN BEGIN
        FOR j := j TO 8 DO mname[j] := '?';
        i := succ(i); END;

      WHILE NOT (mdlname[i] IN [' ', '.']) DO i := succ(i);

      IF mdlname[i] = '.' THEN BEGIN
        i := succ(i); j := 9;
        WHILE (j <= 11) AND NOT (mdlname[i] IN [' ', '*']) DO BEGIN
          mname[j] := mdlname[i]; i := succ(i); j := succ(j); END;
        IF mdlname[i] = '*' THEN
          FOR j := j TO 11 DO mname[j] := '?'; END;
      END; (* standardize *)

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

    BEGIN (* revise *)
    standardize(mdlname, mname); (* to the directory format *)
    new(root); current := root; current^.recd := l^; get(l);
    crcwd := 0; splitbytes(drdate(dateline), hi, lo);
    FOR i := 0 TO binrcdmax DO crc(current^.recd[i], crcwd);
    FOR i := 2 TO 2*size DO storechunk; (* the whole directory *)
    IF (crcwd <> dircrc) AND (dircrc <> 0) THEN signal(crcerr);
    current^.next := NIL; current := root^.next;
    l^ := root^.recd; setupdate; crcwd := 0; root^.recd := l^;
    FOR i := 0 TO binrcdmax DO crc(root^.recd[i], crcwd);
    update(l); reposition(l, 1);
    WHILE current <> NIL DO putchunk;
    reposition(l, 0); l^ := root^.recd;
    splitbytes(crcwd, hi, lo);
    l^[16] := chr(lo); l^[17] := chr(hi); (* revised CRC *)
    put(l);
    END; (* revise *)

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

  PROCEDURE initialize;

    BEGIN (* initialize *)
    reset(cmd); skipredirection(cmd);
    dater(dateline); (* 00/00/00 if no system date available *)
    digits := ['0'..'9'];
(*$s-*)
    mdlname[1 FOR 4] := '*.* ';
(*$s+*)
    END; (* initialize *)

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

  BEGIN (* lsetdate *)
  initialize;
  IF eoln(cmd) OR eof(cmd) THEN help
  ELSE BEGIN
    setname(cmd, libfname); skipredirection(cmd);
(*$s-*)
    IF scanfor('.', libfname, fnmsize) = 0 THEN (* set default .LBR *)
      libfname[scanfor(' ', libfname, fnmsize) FOR 5] := '.LBR ';
    IF exists(libfile, libfname) THEN BEGIN
(*$s+*)
      filename(libfile, libfname); (* system standard name *)
      IF verify(libfile, size, dircrc) THEN BEGIN
        IF NOT (eoln(cmd) OR eof(cmd)) THEN BEGIN 
          IF cmd^ IN digits THEN setdate(cmd, dateline);
          skipredirection(cmd);
          IF NOT eoln(cmd) OR eof(cmd) THEN setname(cmd, mdlname); END;
(*$s-*) IF dateline[1 FOR 8] = '00/00/00' THEN signal(needate)
(*$s+*) ELSE revise(libfile, dateline, size) (* at last *); END
      ELSE signal(notlib); END
    ELSE signal(cantfind); END;
  END. (* lsetdate *)