PROGRAM lsetdate;

  CONST
    header     =
        'SETD01, by Brent B. Powers, based on LSETDATE by CB Falconer.';

    all        = '*.*';
    ovrwr      = '/O';
    binrcdmax  = 127;                  { 1 sector of file }
    fnmsize    = 12;                   { handles most systems }
    datelnsz   = 15;

  TYPE
    dateln     = string[datelnsz];
    fname      = string[fnmsize];
    err        = (needate, notlib, cantfind, crcerr);
    binchunkb    = array[0..binrcdmax] of byte;
    binchunkw    = array[0..63] of integer;
    binrecptr = ^binrecd;
    binrecd   = record
      next      : binrecptr;
      recd      : binchunkb;
    end; { binrecd }
    binrecptw = ^binrecdw;
    binrecdw  = record
      next      : binrecptw;
      recd      : binchunkw;
    end; { binrecw }

  VAR
    dateline   : dateln;
    libfile    : file;
    libfname   : fname;
    mdlname    : fname;
    size,                              { of directory }
    dircrc     : integer;              { extracted from dir[0] }
    minparam   : integer;
    root       : binrecptr;
    rootw      : binrecptw absolute root;
    crctbl     : array[0..512] of byte;
    ndate      : integer;
    europe     : boolean;
    overwrite  : boolean;

{$IDRDATE.INC} {  contains function drdate( dateline:dateln):integer;   }

{$ICRC.INC}    {  contains procedure crcinit;                           }
               {      and procedure crc(a:integer;var crcword:integer); }


  procedure help;

    begin { help }
      writeln;
      writeln(header);
      writeln('Examples :');
      writeln('       B>SETD libraryname MM/DD/YY');
      writeln('             sets all undated files in library');
      writeln;
      writeln('       B>SETD lbrname MM/DD/YY modulename');
      writeln('             sets selected, undated files');
      writeln;
      writeln('       B>SETD lbrname MM/DD/YY /O');
      writeln('             sets ALL files, dated or not, and');
      writeln;
      writeln('       B>SETD lbrname MM/DD/YY modulename /O');
      writeln('             sets selected files, date or not.');
      writeln('    Wildcards accepted. *.* equivalent to no entry');
      writeln('    MM/DD/YY is the date to be set.  Mandatory if the');
      writeln('    system does not supply the current date, otherwise');
      writeln('    overrides system date. The date may also be entered');
      writeln('    as EDD/MM/YY. Date separator may also be a ''\'' or ''-''.');
    end; { help }

  procedure signal(x : err);
    var a : char;

    begin { signal }
      write('*** ERROR *** ');
      case x of
        crcerr:   begin
                    writeln('CRC directory error, bad library: ', libfname);
                    write(chr(7), '^C aborts, <ret> continues');
                    read(kbd,a);
                    if a = ^C then
                      halt;
                  end;

        notlib:   write('Not a library: ', libfname);

        cantfind: write('Can''t find ', libfname);

        needate:  write('No system date or invalid date format');

      end;
      writeln;
      if x <> crcerr then
        help;
    end; { signal }

  function chkdate(var f):boolean;
    const valchar : string[13] = '0123456789/-\';
    var i  : integer;
        st : string[255] absolute f;
        l  : byte absolute f;
        eur : boolean;
    begin
      if UpCase(st[i]) = 'E' then
        begin
          i := 1;
          eur := true;
        end else begin
          i := 0;
          eur := false;
        end;
      repeat
        i := succ(i);
      until (i=l) or (pos(st[i],valchar)=0);
      if i = l then
        begin
          chkdate := true;
          europe := eur;
          if europe then
            delete(st,1,1);
        end else
          chkdate := false;
    end;

  procedure cap(var f);
    var
      i  : integer;
      st : string[255] absolute f;
    begin
      for i := 1 to ord(st[0]) do
        st[i] := UpCase(st[i]);
    end;

  procedure setdate(f : fname; var d : dateln);

    var
      da,mo: integer;
      d1 : dateln;
      dl : char;

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

      var
        i,j: integer;
        st : string[3];

      begin { getfield }
        st := copy(f,1,2);
        val(st,i,j);
        if (j = 0) and (i >= min) and (I <= max) then
          begin
            getfield := true;
            d1 := d1+st+delimiter;
            delete(f,1,3);
          end
        else
          getfield := false;
      end; { getfield }

    begin { setdate }
      if pos('/',f)>0 then
        dl := '/'
      else if pos('-',f)>0 then
        dl := '-'
      else
        dl := '\';
      f := f + ' ';
      d := '00/00/00 '; { default for error }
      d1[0] := #0;
      if europe then
        begin
          mo := 31;
          da := 12;
        end else begin
          mo := 12;
          da := 31;
        end;
      if getfield(1, mo, dl) then
        if getfield(1, da, dl) then
          if getfield(0, 99, ' ') then
            d := d1;
    end; { setdate }

  function verify(var size, dircrc : integer) : boolean;

    begin { verify }
      size := rootw^.recd[7];
      verify := (root^.recd[0] = 0) and (root^.recd[1] < 127) and
                (size > 0) and (size < 8192) and (rootw^.recd[6] = 0);
      dircrc := rootw^.recd[8];
      rootw^.recd[8] := 0;  { for dir crc calc. }
    end; { verify }

  procedure revise(dateline : dateln; size : integer);

    type
      mnametype = array[1..11] of char;

    var
      current   : binrecptr;
      currentw  : binrecptw absolute current;
      i, crcwd  : integer;
      mname     : mnametype;

    procedure getchunk;

      var
        i     : integer;

      begin { getchunk }
        new(current^.next);
        current := current^.next;
        BlockRead(libfile,current^.recd,1);
      end; { getchunk }

    procedure setupdate;

      procedure chkmatchat(ix : integer);
      { implements wild card matching against current^.recd[ix] }

        var
          i   : integer;
          iy  : integer;
        begin { chkmatchat }
          iy := ix*16;
          ix := iy*2;
          if current^.recd[ix] = 0 then begin { live entry }
            i := 0;
            repeat
              i := succ(i);
            until  (i=11)
               or  (   (current^.recd[i+ix] <> ord(mname[i]))
                   and (mname[i] <> '?'));
            if i = 11 then { match, update the date }
              if (currentw^.recd[iy+9] = 0) or overwrite then
              currentw^.recd[iy+9] := ndate;
          end;
        end; { chkmatchat }

      procedure chknodateat(ix : integer);
      { implements setting of any unset dates current^.recd[ix] }
        var iy : integer;


        begin { chknodateat }
          iy := ix*16;
          if (current^.recd[iy*2] = 0) then
            if (currentw^.recd[iy + 9] = 0) or overwrite then
              currentw^.recd[iy+9] := ndate;
        end; { chknodateat }

      begin { setupdate }
        if mdlname = all then
          begin { all undated }
            chknodateat(0);
            chknodateat(1);
            chknodateat(2);
            chknodateat(3);
          end
        else
          begin               { update the specific entry }
            chkmatchat(0);
            chkmatchat(1);
            chkmatchat(2);
            chkmatchat(3);
          end;
      end; { setupdate }

    procedure putchunk;
      begin { putchunk }
        BlockWrite(libfile,current^.recd,1);
        current := current^.next;
      end; { putchunk }

    procedure standardize(var mdlname : fname; var mname : mnametype);
    { input wild string format to directory format }

      var
        i, j     : integer;

      begin { standardize }
        Cap(mdlname);
        i := 1;
        j := 1;
        fillchar(mname,12,' ');
        mname[0] := #11;
        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 }

    begin { revise }
      standardize(mdlname, mname); { to the directory format }
      ndate := drdate(dateline);
      current := root;
      crcwd := 0;
      for i := 1 to pred(size) do
        getchunk; { get the whole directory into memory }
      current^.next := nil;
      current := root;
      repeat
        for i := 0 to binrcdmax do
          crc(current^.recd[i], crcwd);
        setupdate;
        current := current^.next;
      until current = nil;
      if (crcwd <> dircrc) and (dircrc <> 0) then
        signal(crcerr);
      current := root;
      crcwd := 0;
      repeat
        for i := 0 to binrcdmax do
          crc(current^.recd[i], crcwd);
        current := current^.next;
      until current = nil;
      seek(libfile, 0);
      rootw^.recd[8] := crcwd;
      current := root;
      while current <> nil do
        putchunk;
      close(libfile);
    end; { revise }

  procedure initialize;

    begin { initialize }
      dateline := paramstr(paramcount);
      cap(dateline);
      overwrite := dateline = ovrwr;

      { with system clock   }
      {     minparam := 1;   }
      {     dater(dateline); }

      { without system clock }
      minparam := 2;
      dateline := '00/00/00';

{     If you can get the date from your system, the routine to do that  }
{     should be coded as procedure dater(var dl : dateln);              }

      crcinit;
    end; { initialize }

  begin { lsetdate }
    initialize;
    if paramcount < minparam then
      help
    else begin
      if pos('.',paramstr(1)) = 0 then { set default .lbr }
        libfname := paramstr(1)+'.LBR '
      else
        libfname := paramstr(1);
      assign(libfile,libfname);
      {$I-}
      reset(libfile);
      {$I+}
      if IOResult=0 then
        begin
          new(root); { file was found, make sure it is a library. }
          BlockRead(libfile,root^.recd,1);
          if verify(size, dircrc) then
            begin
            { whether or not there is a system clock, they may have entered }
            { the date. Check if paramstr(2) is a date }
              mdlname := paramstr(2);
              if chkdate(mdlname) then
                begin
                  setdate(mdlname, dateline);
                  mdlname := paramstr(3) { paramstr2 was date }
                end;
              if (mdlname = ovrwr) or (mdlname[0] = #0) then
                mdlname := all;
              if dateline = '00/00/00' then
                signal(needate)
              else
                revise(dateline, size)
          end else
            signal(notlib);
        end else
          signal(cantfind);
    end;
  end. { lsetdate }