{
 DIRCHK4.PAS  7-4-86  Turbo Pascal 3.01A

 RBBS Directory check program. This program compares the RBBS DIR
 files with the contents of one or more disk drives and lists all
 files which are not found in either the DIRS or the disk drives.

 Up to 6 drives can be selected for the test and up to 6 drive/file
 masks for the DIR files. Path names are not allowed. The program
 will handle upto 3000 disk files and 100 DIR files. Output can be
 sent to screen, printer, or disk file. A complete merged and sorted
 directory file can also be output.

 This program works with MS-DOS (or PC-DOS) version 2 and later.

             Copyright 1986 by David W. Carroll
               All commercial rights reserved.

This program and some 1200+ other Turbo programs are available on:
            The High Sierra RBBS-PC
                209-296-3534
}

PROGRAM Dirchk4;

  CONST
    Getdta = $1A;
    Get1stdir = $11;
    Getnextdir = $12;
    Parsename = $29;
    Maxfiles = 3000;
    Skiplines = 4;
    Maxlines = 55;

  TYPE
    Regpack =
      RECORD
        CASE Integer OF
          1:
            (Ax, Bx, Cx, Dx, Bp, Si, Di, Ds, Es, Flags: Integer);
          2:
            (Al, Ah, Bl, Bh, Cl, Ch, Dl, Dh: Byte)
      END;

    Fcbarray = ARRAY [0..36] OF Char;
    Strtype = STRING [12];
    Strtype1 = STRING [20];
    Comstr = STRING [80];
    Item =
      RECORD
        Fil: Strtype;
        Dr, Stat: Integer;
      END;
    Arrytype = ARRAY [1..Maxfiles] OF Item;
    Index = 1..Maxfiles;
    Datetimetype = STRING [8];

  VAR
    Filearray: Arrytype;
    Fileindex: Integer;
    Ch, Inch: Char;
    Buffer, Buffer1: Comstr;
    Filestr, Filename: Strtype;
    Dfcb, Dta, Dta2: Fcbarray;
    Quit: Boolean;
    Loc, Status: Integer;
    Done, Printout, Fileout, Eraselist: Boolean;
    Ind, I, Dirs, Bbsdirs: Integer;
    Drive, Bbsdir: ARRAY [1..6] OF Strtype1;
    Dirarray: ARRAY [1..100] OF Strtype1;
    Dup, Dirindex: Integer;
    Line, Extra, Miss: Integer;
    Outfile: Text;
    Outfname: Strtype1;
    Listsort, Ok: Boolean;
    Str4, Str5: Comstr;
    T1, T2, T3, T4, T5: STRING [5];
    Time1, Date1: Datetimetype;


  FUNCTION Date: Datetimetype;
   { returns current date in form '08/31/84'. }

    VAR
      Reg: Regpack;
      Y, M, D, W: Datetimetype;
      I: Integer;

    BEGIN
      Reg.Ah := $2A;
      Msdos(Reg);
      Str(Reg.Cx: 4, Y);
      Delete(Y, 1, 2);
      Str(Hi(Reg.Dx): 2, M);
      Str(Lo(Reg.Dx): 2, D);
      W := M + '/' + D + '/' + Y;
      FOR I := 1 TO Length(W) DO
        IF W[I] = ' ' THEN
          W[I] := '0';
      Date := W
    END;


  FUNCTION Time: Datetimetype;
   { returns current time in form '08:13:59'. }

    VAR
      Reg: Regpack;
      H, M, S, W: Datetimetype;
      I: Integer;

    BEGIN
      Reg.Ah := $2C;
      Msdos(Reg);
      Str(Hi(Reg.Cx): 2, H);
      Str(Lo(Reg.Cx): 2, M);
      Str(Hi(Reg.Dx): 2, S);
      W := H + ':' + M + ':' + S;
      FOR I := 1 TO Length(W) DO
        IF W[I] = ' ' THEN
          W[I] := '0';
      Time := W;
    END;


  PROCEDURE Uppercase(VAR Str: Comstr);

    VAR
      Indx, Len: Integer;

    BEGIN
      Len := Length(Str);
      FOR Indx := 1 TO Len DO
        Str[Indx] := Upcase(Str[Indx]);
    END;


  PROCEDURE Chkpage(N: Integer);
    BEGIN
      Line := Line + 1;
      IF Line > Maxlines - N THEN
        BEGIN
          Line := 0;
          Write(Lst, Chr(12));
        END;

    END;


  PROCEDURE Writeblank;
    BEGIN
      Writeln;
      IF Fileout THEN
        Writeln(Outfile);
      IF Printout THEN
        Writeln(Lst);
    END;


  PROCEDURE Writemess(Message: Comstr);
    BEGIN
      Writeln(Message);
      IF Fileout THEN
        Writeln(Outfile, Message);
      IF Printout THEN
        BEGIN
          Writeln(Lst, Message);
          Chkpage(2);
        END;
    END;


  PROCEDURE Writehead(Message: Comstr);

    VAR
      I: Integer;
    BEGIN
      Chkpage(4);
      Writeblank;
      Writemess(Message);
      FOR I := 1 TO 79 DO
        BEGIN
          Write('=');
          IF Fileout THEN
            Write(Outfile, '=');
          IF Printout THEN
            Write(Lst, '=');
        END;
      Writeblank;
    END;


  PROCEDURE Quicksort1(VAR A: Arrytype;
                       N: Integer);

   { Non-recursive quicksort with optimized stack from Wirth }

    CONST
      M = 15;                           { log2 n, max n = 32767 }

    VAR
      I, J, L, R: Index;
      X: Strtype;
      W: Item;
      S, Maxs: 0..M;
      Stack: ARRAY [1..M] OF
          RECORD
            L, R: Index;
          END;

    BEGIN
      Maxs := 0;
      S := 1;
      Stack[1].L := 1;
      Stack[1].R := N;
      REPEAT
        L := Stack[S].L;
        R := Stack[S].R;
        S := S - 1;
        REPEAT
          I := L;
          J := R;
          X := A[(L + R) DIV 2].Fil;
          REPEAT
            WHILE A[I].Fil < X DO
              I := I + 1;
            WHILE X < A[J].Fil DO
              J := J - 1;
            IF I <= J THEN
              BEGIN
                W := A[I];
                A[I] := A[J];
                A[J] := W;
                I := I + 1;
                J := J - 1;
              END;
          UNTIL I > J;

          IF J - L < R - I THEN
            BEGIN
              IF I < R THEN
                BEGIN
                  S := S + 1;
                  Stack[S].L := I;
                  Stack[S].R := R;
                  IF S > Maxs THEN
                    Maxs := S;
                END;
              R := J;
            END
          ELSE
            BEGIN
              IF L < J THEN
                BEGIN
                  S := S + 1;
                  Stack[S].L := L;
                  Stack[S].R := J;
                  IF S > Maxs THEN
                    Maxs := S;
                END;
              L := I;
            END;

        UNTIL L >= R;
      UNTIL S = 0;
      { Writeln('Max stack: ', Maxs);}
    END;


  FUNCTION Binsearch(Str1: Strtype;
                     Maxitems: Integer;
                     VAR Found, Nomatch: Boolean): Integer;

    VAR
      Max, Min, Test, Index: Integer;

    BEGIN
      Max := Maxitems;
      Min := 1;
      Test := 1;
      Nomatch := False;
      Found := False;
      Index := (Min + Max) DIV 2;
      WHILE (NOT Found) AND (NOT Nomatch) DO
        BEGIN
          IF Filearray[Index].Fil = Str1 THEN
            BEGIN
              Found := True;
              Binsearch := Index;
            END;
          IF Filearray[Index].Fil < Str1 THEN
            BEGIN
              Test := Test + 1;
              Min := Index + 1;
              Index := (Min + Max) DIV 2;
            END;
          IF Filearray[Index].Fil > Str1 THEN
            BEGIN
              Test := Test + 1;
              Max := Index - 1;
              Index := (Min + Max) DIV 2;
            END;
          IF Min > Max THEN
            Nomatch := True;
        END;
    END;


  PROCEDURE Setdta(Num: Byte); {set Disk Transfer Address}

    VAR
      Regs: Regpack;

    BEGIN
      WITH Regs DO
        BEGIN
          Ah := Getdta;
          CASE Num OF
            1:
              BEGIN
                Ds := Seg(Dta);
                Dx := Ofs(Dta);
              END;
            2:
              BEGIN
                Ds := Seg(Dta2);
                Dx := Ofs(Dta2);
              END;
            END;
          Msdos(Regs)
        END

    END; {setDTA}


  PROCEDURE Calldir(Calltype: Byte;
                    VAR Errflag: Byte);

    VAR
      Regs: Regpack;

    BEGIN
      WITH Regs DO
        BEGIN
          Ah := Calltype;
          Cx := 0;
          Ds := Seg(Dfcb);
          Dx := Ofs(Dfcb);
          Msdos(Regs);
          Errflag := Al
        END

    END; {calldir}


  PROCEDURE Parse(VAR Errflag: Byte);

    VAR
      Regs: Regpack;
    BEGIN
      WITH Regs DO
        BEGIN
          Ah := Parsename;
          Ds := Seg(Buffer[1]);
          Si := Ofs(Buffer[1]);
          Es := Seg(Dfcb);
          Di := Ofs(Dfcb);
          Al := $0F;
          Msdos(Regs);
          Errflag := Al;
        END;

    END; {parse}


  PROCEDURE Find(Func: Integer);

    CONST
      Space = ' ';
      Period = '.';

    VAR
      I, Err: Byte;

    BEGIN
      FOR I := 0 TO 36 DO
        Dfcb[I] := Chr(0);
      Writeln;
      Parse(Err);
      Setdta(1); { set 1st DTA for get func.}
      Calldir(Get1stdir, Err); { get first entry matching mask }
      WHILE Err = 0 DO
        BEGIN
          Filename := '';
          CASE Func OF
            1:
              FOR I := 1 TO 11 DO
                BEGIN
                  Filename := Filename + Dta[I];
                  IF I = 8 THEN
                    Filename := Filename + Space;
                END;
            2:
              FOR I := 1 TO 11 DO
                BEGIN
                  IF Dta[I] <> Space THEN
                    Filename := Filename + Dta[I];
                  IF I = 8 THEN
                    Filename := Filename + Period;
                END;
            END;
          Setdta(2); { set 2nd DTA for file processing }

          CASE Func OF
            1:
              BEGIN
                Fileindex := Fileindex + 1;
                Filearray[Fileindex].Fil := Filename;
                Filearray[Fileindex].Dr := Ind;
              END;
            2:
              BEGIN
                Dirindex := Dirindex + 1;
                Dirarray[Dirindex] := Buffer1 + Filename
              END;
            END;

          IF Err = 0 THEN
            BEGIN
              Setdta(1);
              Calldir(Getnextdir, Err); { get next entry }
            END;
        END;
      Writeln;
    END; {find}


  PROCEDURE Dirtest(Fname: Strtype1);

    VAR
      Infname: Strtype;
      Infile: Text;
      Str1: Comstr;
      Str2, Str3: Strtype;
      I, N, Indx: Integer;
      Fnd, Nomat: Boolean;


    PROCEDURE Open_File;

      CONST
        Bell = 07;

      VAR
        Goodfile: Boolean;

      BEGIN
        Infname := Fname;
        Assign(Infile, Infname);
        {$I-}
        Reset(Infile) {$I+} ;
        Goodfile := (Ioresult = 0);
        IF NOT Goodfile THEN
          BEGIN
            Write(Chr(Bell));
            Writeln('FILE ', Infname, ' NOT FOUND');
            Delay(2000)
          END;
      END;

    BEGIN
      Writehead('Files missing from ' + Fname);
      Open_File;
      I := 0;
      WHILE NOT Eof(Infile) AND (I < Skiplines) DO
        BEGIN
          Readln(Infile, Str1);
          I := I + 1;
        END;
      WHILE NOT Eof(Infile) DO
        BEGIN
          Str1 := '';
          Str2 := '';
          Str3 := '';
          Readln(Infile, Str1);
          Uppercase(Str1);
          IF (Str1[1] IN
             ['A'..'Z', '0'..'9', '$', '!', '-', '_', '&', '#', '@', '%',
             '(', ')', '`', '''', '{', '}']) AND (Str1[21] IN ['0'..'9']) AND
             (Str1[31] IN ['0'..'9']) THEN
            BEGIN
              Str2 := Copy(Str1, 1, 12);
              WHILE Str2[Length(Str2)] = ' ' DO
                Delete(Str2, Length(Str2), 1);
              IF Pos('.', Str2) > 0 THEN
                BEGIN
                  FOR I := 1 TO Length(Str2) DO
                    BEGIN
                      IF Str2[I] = '.' THEN
                        BEGIN
                          FOR N := I TO 9 DO
                            Str3 := Str3 + ' ';
                        END
                      ELSE
                        Str3 := Str3 + Str2[I];
                    END;
                  FOR I := Length(Str3) TO 12 DO
                    Str3 := Str3 + ' ';
                END
              ELSE
                BEGIN
                  Str3 := Str2;
                  FOR I := Length(Str3) TO 12 DO
                    Str3 := Str3 + ' ';
                END;
              Indx := Binsearch(Str3, Fileindex, Fnd, Nomat);
              IF Fnd THEN
                BEGIN
                  Filearray[Indx].Stat := Filearray[Indx].Stat + 1;
                END;
              IF Nomat THEN
                BEGIN
                  Writemess(Str1);
                  Miss := Miss + 1;
                END;
            END;
        END;
      Close(Infile);
    END;


  PROCEDURE Init;
    BEGIN
      Clrscr;
      Quit := False;
      Done := False;
      Fileindex := 0;
      Dirindex := 0;
      Dup := 0;
      Extra := 0;
      Miss := 0;
      Date1 := Date;
      Time1 := Time;
      FOR I := 1 TO Maxfiles DO
        BEGIN
          Filearray[I].Dr := 0;
          Filearray[I].Stat := 0;
        END;
    END;


  PROCEDURE Setup;
    BEGIN
      Writeln('Enter up to 6 drives to search for files.');
      Writeln('ENTER when done');
      Writeln;
      FOR I := 1 TO 6 DO
        Drive[I] := '';
      Dirs := 0;
      WHILE (Dirs < 6) AND NOT Done DO
        BEGIN
          Dirs := Dirs + 1;
          Write('Enter drive to search: ');
          Readln(Str4);
          Uppercase(Str4);
          IF (Pos(':', Str4) = 0) AND (Length(Str4) > 0) THEN
            Str4 := Str4 + ':';
          Drive[Dirs] := Str4;
          Done := Drive[Dirs] = '';
        END;
      Dirs := Dirs - 1;
      Writeln;
      Writeln(
            'Enter up to 6 drives with file mask to search for BBS DIR files.'
              );
      Writeln('Like: "C:??.DIR".  Wildcards ok. ENTER when done');
      Writeln;
      Done := False;
      FOR I := 1 TO 6 DO
        Bbsdir[I] := '';
      Bbsdirs := 0;
      WHILE (Bbsdirs < 6) AND NOT Done DO
        BEGIN
          Bbsdirs := Bbsdirs + 1;
          Write('Enter drive and file mask: ');
          Readln(Str5);
          Uppercase(Str5);
          Bbsdir[Bbsdirs] := Str5;
          Done := Bbsdir[Bbsdirs] = '';
        END;
      Bbsdirs := Bbsdirs - 1;
      Writeln;
      Write('Output to printer? (Y/N) ');
      REPEAT
        Read(Kbd, Ch);
        Ch := Upcase(Ch);
      UNTIL Ch IN ['Y', 'N'];
      Writeln(Ch);
      Printout := Ch = 'Y';
      Writeln;
      Write('Output to file? (Y/N) ');
      REPEAT
        Read(Kbd, Ch);
        Ch := Upcase(Ch);
      UNTIL Ch IN ['Y', 'N'];
      Writeln(Ch);
      Fileout := Ch = 'Y';
      IF Fileout THEN
        BEGIN
          Writeln;
          Write('Enter output file name: ');
          Readln(Outfname);
          Assign(Outfile, Outfname);
          {$I-}
          Reset(Outfile);
          {$I+}
          Ok := Ioresult <> 0;
          IF NOT Ok THEN
            BEGIN
              Write(^G'File Exists - OVERWRITE? (Y/N) ');
              REPEAT
                Read(Kbd, Ch);
                Ch := Upcase(Ch);
              UNTIL Ch IN ['Y', 'N'];
              Writeln(Ch);
              Ok := Ch = 'Y';
            END;
          IF Ok THEN
            Rewrite(Outfile);
        END;
      Writeln;
{    Write('Erase listings not found? (Y/N) ');
    REPEAT
      Read(Kbd, Ch);
      Ch := Upcase(Ch);
    UNTIL Ch IN ['Y', 'N'];
    Writeln(Ch);
    Eraselist := Ch = 'Y';
 }
      Write('List sorted directory? (Y/N) ');
      REPEAT
        Read(Kbd, Ch);
        Ch := Upcase(Ch);
      UNTIL Ch IN ['Y', 'N'];
      Writeln(Ch);
      Listsort := Ch = 'Y';

    END;


  PROCEDURE Process;
    BEGIN
      FOR Ind := 1 TO Dirs DO
        BEGIN
          Buffer := Drive[Ind] + '*.*';
          Buffer1 := Drive[Ind];
          Find(1);
        END;
      FOR I := 1 TO Bbsdirs DO
        BEGIN
          Buffer := Bbsdir[I];
          Buffer1 := Copy(Bbsdir[I], 1, Pos(':', Bbsdir[I]));
          Find(2);
        END;

      Writeln;
      Quicksort1(Filearray, Fileindex);

      IF Listsort THEN
        BEGIN
          Writehead('Sorted Merged Directory as of  ' + Date1 + '  ' + Time1);
          FOR I := 1 TO Fileindex DO
            Writemess(Drive[Filearray[I].dr]+Filearray[I].Fil);
        END;
      Writeln;

      FOR I := 1 TO Dirindex DO
        Dirtest(Dirarray[I]);

      Writehead('Duplicate files as of  ' + Date1 + '  ' + Time1);

      FOR I := 1 TO Fileindex - 1 DO
        IF Filearray[I].Fil = Filearray[I + 1].Fil THEN
          BEGIN
            Dup := Dup + 1;
            Writemess(Drive[Filearray[I].Dr] + Filearray[I].Fil);
          END;
      Writeblank;

      Writehead('Files not included in DIRs as of  ' + Date1 + '  ' + Time1);

      FOR I := 1 TO Fileindex DO
        IF Filearray[I].Stat = 0 THEN
          BEGIN
            Extra := Extra + 1;
            Writemess(Drive[Filearray[I].Dr] + Filearray[I].Fil);
          END;

      Writeblank;
      Str(Fileindex, T1);
      Str(Dirindex, T2);
      Str(Dup, T3);
      Str(Miss, T4);
      Str(Extra, T5);
      Writemess(T1 + ' files found.');
      Writemess(T2 + ' dirs found.');
      Writemess(T3 + ' duplicate files found.');
      Writemess(T4 + ' missing files (in DIRs, not on disk).');
      Writemess(T5 + ' extra files found (on disk, not in DIRs).');
      Writeblank;
      IF Fileout THEN
        Close(Outfile);
    END;

  BEGIN { DIRCHK4.PAS }
    Init;
    Writeln('RBBS-PC Directory check program version 4.0 of 7-4-86');
    Writeln('Copyright 1986 by David W. Carroll');
    Writeln('All commercial rights reserved');
    Writeln;
    Writeln;
    Setup;
    Writeln;
    Process;
    Writeln(' - done - ');
  END. { DIRCHK4.PAS }