ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/TURBODS/CHECKDIR.LBR/CHECKDIR.MQD/CHECKDIR.MOD

Text File | 2000-06-30 | 20KB | 816 lines

MODULE CheckDir;

FROM SYSTEM IMPORT ADDRESS, ADR, ALLOCATE, DEALLOCATE, SIZE, TSIZE;

FROM TERM1  IMPORT Read, Write, WriteCard, WriteString, WriteLn;

IMPORT TERM1, TurboDOS;

TYPE BYTE       = CHAR;

CONST CPM       = FALSE;
      Debug     = FALSE;

TYPE DirFilePtr = POINTER TO RECORD
      FCB:        RECORD
        Drive:    BYTE;
        Name:     ARRAY[0.. 7] OF CHAR;
        Type:     ARRAY[0.. 2] OF CHAR;
        Filler:   ARRAY[1..20] OF CHAR;
        CurRec:   BYTE;
        RanRec:   RECORD
          Low:    CARDINAL;
          High:   BYTE;
        END;
      END;
      EntryNumb:  CARDINAL;
      MaxEntrys:  CARDINAL;
      DirNdx:     [0..3];
      DirBlock:   ARRAY[0..3] OF ARRAY[1..32] OF CHAR;
    END;

TYPE FileNamePtr= POINTER TO FileNameDef;
     FileNameDef= RECORD
       User:      BYTE;
       Name:      ARRAY[0..7] OF CHAR;
       Type:      ARRAY[0..2] OF CHAR;
     END;

     DirEntryDef= RECORD
       FileName:  FileNameDef;
       Filler:    ARRAY[0..3] OF BYTE;
       SectorGroup:ARRAY[1..8] OF CARDINAL;
     END;

     EntryPtr=    POINTER TO EntryDef;
     EntryDef=    RECORD
       FileName:  FileNameDef;
       Size:      CARDINAL;
       Left,
       Right:     EntryPtr;
     END;

     ErrNamePtr   = POINTER TO ErrNameDef;
     ErrNameDef   = RECORD
       FileName:    FileNameDef;
       Next:        ErrNamePtr;
     END;
     SecGrpErrors = SET OF (Duplicated, UnMarked);
     SecGrpErrPtr = POINTER TO SecGrpErrDef;
     SecGrpErrDef = RECORD
       SecGrpNumb:  CARDINAL;
       Errors:      SecGrpErrors;
       FileName:    ErrNamePtr;
       Left, Right: SecGrpErrPtr;
     END;

VAR BasePage[0000h]: TurboDOS.BasePageDef;
    SysRegs:      TurboDOS.CpuRegDef;

VAR SelectedDrive:CARDINAL;
    BlockSize:    CARDINAL;
    DirBlocks:    CARDINAL;
    MaxBlocks:    CARDINAL;

    UsedDE,
    UsedSG:       CARDINAL;

    SysSecGrpMap: POINTER TO ARRAY[0..4095] OF BITSET;
    SecGrpMap:    POINTER TO ARRAY[0..4095] OF BITSET;

    SGEHead,
    CurrSGE:      SecGrpErrPtr;

    EntryHead,
    CurrEntry:    EntryPtr;

    CurrUser:     CARDINAL;
    DispCount:    CARDINAL;

VAR DirFile:      DirFilePtr;
    DirEntry:     DirEntryDef;

PROCEDURE FillChar(PData : ADDRESS;
                   Len   : CARDINAL;
                   ch    : CHAR);

VAR c:            CARDINAL;
    Data:         POINTER TO CHAR;

BEGIN (* FillChar *)

  Data := PData;

  FOR c := 1 TO Len DO
      Data^ := ch;
      INC(Data);
  END;

END FillChar;

PROCEDURE Move(To, From : ADDRESS;
               Length   : CARDINAL);

TYPE ChrPtr     = POINTER TO CHAR;

VAR Aop, Bop:     ChrPtr;
    Count:        CARDINAL;

BEGIN (* Move *)

  Aop := To;
  Bop := From;

  FOR Count := 1 TO Length DO
      Aop^ := Bop^;
      INC(Aop);
      INC(Bop);
  END;

END Move;

PROCEDURE EndJob;

BEGIN (* EndJob *);

  HALT;

END EndJob;

PROCEDURE DisplayMessage(Message : ARRAY OF CHAR);

BEGIN (* DisplayMessage *)

  IF Debug
     THEN WriteString(Message); WriteLn;
  END;

END DisplayMessage;

PROCEDURE GetDriveToCheck() : CARDINAL;

VAR CDrive:       CHAR;
    c:            CARDINAL;

  PROCEDURE UserInpDrive() : CARDINAL;

  VAR Drive:      CARDINAL;

  BEGIN (* UserInpDrive *)

    WriteLn;
    WriteString('Enter the drive to check [A -> P] ');

    LOOP Read(CDrive);
         IF       CDrive = ' '
            THEN EndJob;
            ELSE IF (CAP(CDrive) >= 'A') AND
                    (CAP(CDrive) <= 'P')
                    THEN Drive := ORD(CAP(CDrive)) - ORD('A');
                         EXIT;
                    ELSE  Write(CHR(07h));
                 END;
         END;
    END;

    Write(CDrive); WriteLn;

    RETURN Drive;

  END UserInpDrive;

  PROCEDURE CmdLineDrive() : CARDINAL;

  BEGIN (* CmdLineDrive *)

    WITH BasePage.SysBuffer.CommandLine DO
         c := 0;
         WHILE (Data[c] # 0C)     AND
               (c <= ORD(Length)) DO
               CDrive := Data[c];
               IF (CAP(CDrive) >= 'A') AND
                  (CAP(CDrive) <= 'P')
                  THEN RETURN ORD(CAP(CDrive)) - ORD('A');
                  ELSE INC(c);
               END;
         END;
         RETURN UserInpDrive();
    END;

  END CmdLineDrive;

BEGIN (* GetDriveToCheck *)

  IF ORD(BasePage.SysBuffer.CommandLine.Length) > 0
     THEN RETURN CmdLineDrive();
     ELSE RETURN UserInpDrive();
  END;

END GetDriveToCheck;


PROCEDURE OpenDir(VAR DirFile : DirFilePtr;
                      DirDrive: CARDINAL)   : BOOLEAN;

BEGIN (* OpenDir *)

  NEW(DirFile);

  FillChar(ADDRESS(DirFile), SIZE(DirFile^), CHR(0));

  WITH DirFile^ DO
       WITH SysRegs DO
            RegC := CHR(19);
            RegE := CHR(DirDrive);
            TurboDOS.TBDOS(SysRegs);
            DirBlocks := ORD(RegC);
            MaxBlocks := RegHL;
            BlockSize := ORD(BITSET(ORD(AF)) * {0..2});
       END;
       IF       BlockSize = 3 THEN BlockSize :=  32;
          ELSIF BlockSize = 4 THEN BlockSize :=  64;
          ELSIF BlockSize = 5 THEN BlockSize := 128;
          ELSIF BlockSize = 6 THEN BlockSize := 256;
          ELSIF BlockSize = 7 THEN BlockSize := 512;
       END;
       MaxEntrys := DirBlocks * BlockSize;
       FCB.Drive := CHR(DirDrive + 1);
       FCB.Name := '$       ';
       FCB.Type := 'DIR';
       WITH SysRegs DO
            RegBC := 15;
            RegDE := ADR(FCB);
            TurboDOS.CBDOS(SysRegs);
            RegBC := 26;
            RegDE := ADR(DirBlock);
            TurboDOS.CBDOS(SysRegs);
            RegBC := 20;
            RegDE := ADR(FCB);
            TurboDOS.CBDOS(SysRegs);
       END;
       BlockSize := BlockSize * 32;
       DirNdx := 0;
  END;

  RETURN TRUE;

END OpenDir;

PROCEDURE CloseDir(VAR DirFile : DirFilePtr) : BOOLEAN;

BEGIN (* CloseDir *)

  WITH DirFile^ DO
       WITH SysRegs DO
            RegBC := 16;
            RegDE := ADR(FCB);
            TurboDOS.CBDOS(SysRegs);
       END;
  END;

  RETURN TRUE;

END CloseDir;

PROCEDURE GetDirEntry(VAR DirFile      : DirFilePtr;
                          DirEntryNumb : CARDINAL;
                          DirEntry     : ADDRESS)  : BOOLEAN;

VAR RecNo:        CARDINAL;

BEGIN (* GetDirEntry *)

  IF DirEntryNumb < DirFile^.MaxEntrys
     THEN WITH DirFile^ DO
               RecNo  := DirEntryNumb DIV 4;
               IF RecNo # FCB.RanRec.Low
                  THEN FCB.RanRec.Low := RecNo;
                       WITH SysRegs DO
                            RegBC := 26;
                            RegDE := ADR(DirBlock);
                            TurboDOS.CBDOS(SysRegs);
                            RegBC := 33;
                            RegDE := ADR(FCB);
                            TurboDOS.CBDOS(SysRegs);
                       END;
               END;
               DirNdx := DirEntryNumb MOD 4;
               Move(DirEntry, ADR(DirBlock[DirNdx]), 32);
               EntryNumb := DirEntryNumb;
          END;
          RETURN TRUE;
     ELSE RETURN FALSE;
  END;

END GetDirEntry;

PROCEDURE GetFirstDirEntry(VAR DirFile  : DirFilePtr;
                               DirEntry : ADDRESS)  : BOOLEAN;

BEGIN (* GetFirstDirEntry *)

  RETURN GetDirEntry(DirFile, 0, DirEntry);

END GetFirstDirEntry;

PROCEDURE GetNextDirEntry(VAR DirFile  : DirFilePtr;
                              DirEntry : ADDRESS)  : BOOLEAN;

BEGIN (* GetNextDirEntry *)

  RETURN GetDirEntry(DirFile, DirFile^.EntryNumb + 1, DirEntry);

END GetNextDirEntry;

PROCEDURE BuildSysSecGrpMap;

VAR c, c1, c2:    CARDINAL;
    AllocMap:     ARRAY[1..15] OF BITSET;

BEGIN (* BuildSysSecGrpMap *)

  DisplayMessage('Entering BuildSysSecGrpMap');

  FOR c := 0 TO 4095 DO
     SysSecGrpMap^[c] := {};
        SecGrpMap^[c] := {};
  END;

  c1 := MaxBlocks DIV 16;

  IF MaxBlocks # (c1 * 16)
     THEN INC(c1);
  END;

  FOR c := 0 TO (c1 - 1) DO
     SysSecGrpMap^[c] := {};
        SecGrpMap^[c] := {};
  END;

  IF GetFirstDirEntry(DirFile, ADR(DirEntry))
     THEN Move(ADR(AllocMap[ 1]), ADR(DirEntry.FileName.Name), 14);
          Move(ADR(AllocMap[ 8]), ADR(DirEntry.SectorGroup), 16);
          c2 := 15; (* Force us by the Volume Label Entry *)
          FOR c := 0 TO (c1 - 1) DO
              INC(c2);
              IF c2 > 15
                 THEN IF GetNextDirEntry(DirFile, ADR(DirEntry))
                         THEN Move(ADR(AllocMap[ 1]), ADR(DirEntry.FileName.Name), 14);
                              Move(ADR(AllocMap[ 8]), ADR(DirEntry.SectorGroup), 16);
                         ELSE FillChar(ADR(AllocMap), SIZE(AllocMap), CHR(0));
                      END;
                      c2 := 1;
              END;
              SysSecGrpMap^[c] := AllocMap[c2];
          END;
  END;

  DisplayMessage('Leaving BuildSysSecGrpMap');

END BuildSysSecGrpMap;

(*
PROCEDURE CompareEntry(VAR AParm, BParm : EntryPtr;
                           Length       : CARDINAL) : INTEGER;

VAR AOP, BOP:     POINTER TO CHAR;
    c:            CARDINAL;

BEGIN (* CompareEntry *)

  AOP := ADDRESS(AParm);
  BOP := ADDRESS(BParm);

  c := 0;

  WHILE c < Length DO
        IF       AOP^ < BOP^ THEN RETURN -1;
           ELSIF AOP^ > BOP^ THEN RETURN  1;
           ELSE INC(AOP);
                INC(BOP);
                INC(c);
        END;
  END;

  RETURN 0;

END CompareEntry;

PROCEDURE InsertEntry(VAR Base, Test : EntryPtr);

BEGIN (* InsertEntry *)

  IF Base = NIL
     THEN Base := Test;
     ELSE CASE CompareEntry(Base, Test, 1 + 8 + 3) OF
            -1 : InsertEntry(Base^.Right, Test);
          |  0 : Base^.Size := Base^.Size + Test^.Size;
                 DISPOSE(Test);
          |  1 : InsertEntry(Base^.Left, Test);
          END;
  END;

END InsertEntry;

PROCEDURE ListEntrys(VAR Entry : EntryPtr);

BEGIN (* ListEntrys *)

  IF Entry # NIL
     THEN ListEntrys(Entry^.Left);
          WITH Entry^.FileName DO
               IF CurrUser # ORD(User)
                  THEN WriteLn;
                       CurrUser  := ORD(User);
                       DispCount := 0;
               END;
               IF DispCount = 3
                  THEN WriteLn;
                       DispCount := 0;
               END;
               WriteCard(ORD(User), 2); Write(':');
               WriteString(Name);       Write('.');
               WriteString(Type);
               WriteCard(Entry^.Size * BlockSize, 6);
               WriteString('k   ');
               INC(DispCount);
          END;
          ListEntrys(Entry^.Right);
  END;

END ListEntrys;
*)

PROCEDURE SortSecGrpErr(VAR Base, Temp : SecGrpErrPtr);

BEGIN (* SortSecGrpErr *)

  IF Base = NIL
     THEN Base := Temp;
     ELSIF Base^.SecGrpNumb < Temp^.SecGrpNumb
           THEN SortSecGrpErr(Base^.Right, Temp);
     ELSIF Base^.SecGrpNumb > Temp^.SecGrpNumb
           THEN SortSecGrpErr(Base^.Left, Temp);
     ELSE Base^.Errors := Base^.Errors + Temp^.Errors;
          DISPOSE(Temp);
  END;

END SortSecGrpErr;

PROCEDURE ListSecGrpErrors(VAR Entry : SecGrpErrPtr);

VAR Count:        CARDINAL;
    TempName:     ErrNamePtr;

BEGIN (* ListSecGrpErrors *)

  IF Entry # NIL
     THEN ListSecGrpErrors(Entry^.Left);
          WriteCard(Entry^.SecGrpNumb, 5);
          IF Duplicated IN Entry^.Errors
             THEN WriteString(' Duplicated');
          END;
          IF UnMarked IN Entry^.Errors
             THEN WriteString(' UnMarked');
          END;
          IF Entry^.FileName = NIL
             THEN WriteLn;
             ELSE Count := 1;
                  TempName := Entry^.FileName;
                  WHILE TempName # NIL DO
                        WITH TempName^.FileName DO
                             WriteCard(ORD(User), 3); Write(':');
                             WriteString(Name);       Write('.');
                             WriteString(Type);
                        END;
                        INC(Count);
                        IF Count = 4
                           THEN WriteLn;
                          WriteString('     ');
                                Count := 0;
                        END;
                        TempName := TempName^.Next;
                  END;
                  IF Count # 0
                     THEN WriteLn;
                  END;
          END;
          ListSecGrpErrors(Entry^.Right);
  END;

END ListSecGrpErrors;

PROCEDURE ProcessSecGrpErrors;

  PROCEDURE ProcessDirEntry(VAR DirEntry : DirEntryDef);

  VAR c:    CARDINAL;

    PROCEDURE CheckSectorGroup(VAR SectorGroup : CARDINAL);

    VAR SGETemp:    SecGrpErrPtr;
        NamePtr,
        TempName:    ErrNamePtr;

      PROCEDURE ChkSecGrp(VAR Base : SecGrpErrPtr;
                          VAR SGN  : CARDINAL) : SecGrpErrPtr;

      BEGIN (* ChkSecGrp *)

        IF Base = NIL
           THEN RETURN Base;
           ELSIF Base^.SecGrpNumb < SGN
                 THEN RETURN ChkSecGrp(Base^.Right, SGN);
           ELSIF Base^.SecGrpNumb > SGN
                 THEN RETURN ChkSecGrp(Base^.Left, SGN);
                 ELSE RETURN Base;
        END;

      END ChkSecGrp;

    BEGIN (* CheckSectorGroup *)

      SGETemp := ChkSecGrp(SGEHead, SectorGroup);

      IF SGETemp # NIL
         THEN NEW(NamePtr);
              NamePtr^.FileName := DirEntry.FileName;
              NamePtr^.Next     := NIL;
              IF SGETemp^.FileName = NIL
                 THEN SGETemp^.FileName := NamePtr;
                 ELSE TempName := SGETemp^.FileName;
                      WHILE TempName^.Next # NIL DO
                            TempName := TempName^.Next;
                      END;
                      TempName^.Next := NamePtr;
              END;
      END;

    END CheckSectorGroup;

  BEGIN (* ProcessDirEntry *)

    WITH DirEntry DO
         IF FileName.User < CHR(32)
            THEN c := 1;
                 WHILE (c < 9)              AND
                       (SectorGroup[c] > 0) DO
                       CheckSectorGroup(SectorGroup[c]);
                       INC(c);
                 END;
         END;
    END;

  END ProcessDirEntry;

BEGIN (* ProcessSecGrpErrors *)

  IF GetFirstDirEntry(DirFile, ADR(DirEntry))
     THEN REPEAT ProcessDirEntry(DirEntry);
          UNTIL  NOT GetNextDirEntry(DirFile, ADR(DirEntry));
  END;

  ListSecGrpErrors(SGEHead);

END ProcessSecGrpErrors;

PROCEDURE CheckSecGrpAllocation;

VAR Plus, Minus:  CARDINAL;
    c, cmax:      CARDINAL;

  PROCEDURE CheckBits(VAR a, b  : BITSET;
                          COUNT : CARDINAL);

  VAR c1:    CARDINAL;

    PROCEDURE ReportType1;

    BEGIN (* ReportType1 *)

      WriteString('Sector Group');
      WriteCard((c * 16) + c1 + 1, 6);
      WriteString(' Allocated but not within any extent');
      WriteLn;

      INC(Plus);

    END ReportType1;

    PROCEDURE ReportType2;

    VAR Temp:       SecGrpErrPtr;

    BEGIN (* ReportType2 *)

      WriteString('Sector Group');
      WriteCard((c * 16) + c1, 5);
      WriteString(' within an extent but not Allocated');
      WriteLn;

      INC(Minus);

      NEW(Temp);

      WITH Temp^ DO
         SecGrpNumb := (c * 16) + c1;
         Errors     := SecGrpErrors{UnMarked};
         FileName   := NIL;
         Left       := NIL;
         Right      := NIL;
      END;

      SortSecGrpErr(SGEHead, Temp);

    END ReportType2;

  BEGIN (* CheckBits *)

     FOR c1 := 0 TO COUNT DO
         IF c1 IN a
            THEN  IF NOT (c1 IN b)
                     THEN ReportType1;
                  END;
            ELSIF c1 IN b
                  THEN ReportType2;
         END;
     END;

  END CheckBits;

BEGIN (* CheckSecGrpAllocation *)

  Plus := 0;
  Minus := 0;

  c := 0; cmax := MaxBlocks DIV 16;

  LOOP IF c < cmax (* This will keep it relative to zero *)
          THEN IF CARDINAL(SysSecGrpMap^[c]) # CARDINAL(SecGrpMap^[c])
                  THEN CheckBits(SysSecGrpMap^[c], SecGrpMap^[c], 15);
               END;
               INC(c);
          ELSE EXIT;
       END;
  END;

  IF (MaxBlocks MOD 16) # 0 (* This will pick up any dangling bits *)
     THEN CheckBits(SysSecGrpMap^[c], SecGrpMap^[c], ((MaxBlocks MOD 16) - 1));
  END;

  IF Plus > 0
     THEN WriteString('Disk will GAIN');
          WriteCard(Plus, 6);
          WriteString(' Sector Groups');
          WriteLn;
  END;

  IF Minus > 0
     THEN WriteString('Disk will LOSE');
          WriteCard(Minus, 6);
          WriteString(' Sector Groups');
          WriteLn;
  END;


END CheckSecGrpAllocation;

PROCEDURE ProcessDirEntry(DirEntry : DirEntryDef);

VAR c,
    SecGrpNdx,
    SecGrpBit:    CARDINAL;
    Test:         EntryPtr;

  PROCEDURE ReportDuplicated;

  VAR Temp:       SecGrpErrPtr;

  BEGIN (* ReportDuplicated *)

    WITH DirEntry DO
         WriteString('Duplicate Sector Group Found');
         WriteCard(SectorGroup[c],6);
         WriteCard(ORD(FileName.User), 3);
         WriteString(':');
         WriteString(FileName.Name);
         WriteString('.');
         WriteString(FileName.Type);
         WriteLn;
    END;

    NEW(Temp);

    WITH Temp^ DO
       SecGrpNumb := DirEntry.SectorGroup[c];
       Errors     := SecGrpErrors{Duplicated};
       FileName   := NIL;
       Left       := NIL;
       Right      := NIL;
    END;

    SortSecGrpErr(SGEHead, Temp);

  END ReportDuplicated;

BEGIN (* ProcessDirEntry *)

  DisplayMessage('Entering ProcessDirEntry');

  IF ORD(DirEntry.FileName.User) < 32
     THEN WITH DirEntry DO
(*
               INC(UsedDE);
               NEW(Test);
               WITH Test^ DO
                    FileName := DirEntry.FileName;
                    Size := 0;
                    Left := NIL;
                    Right := NIL;
               END;
*)
               c := 1;
               WHILE (c <= 8)             AND
                     (SectorGroup[c] > 0) DO
                     INC(Test^.Size);
                     SecGrpNdx := SectorGroup[c] DIV 16;
                     SecGrpBit := SectorGroup[c] MOD 16;
                     IF SecGrpBit IN SecGrpMap^[SecGrpNdx]
                        THEN ReportDuplicated;
                        ELSE INCL(SecGrpMap^[SecGrpNdx], SecGrpBit);
                     END;
                     INC(UsedSG);
                     INC(c);
               END;
(*
               InsertEntry(EntryHead, Test);
*)
          END;
  END;

  DisplayMessage('Leaving ProcessDirEntry');

END ProcessDirEntry;

PROCEDURE DoProcess;

VAR c, c1, c2,
    cmax:         CARDINAL;

BEGIN (* DoProcess *)

  DisplayMessage('Entering DoProcess');

  ALLOCATE(SysSecGrpMap, MaxBlocks + DirBlocks + 1);
  ALLOCATE(   SecGrpMap, MaxBlocks + DirBlocks + 1);

  BuildSysSecGrpMap;

  EntryHead := NIL;
  SGEHead   := NIL;

  FOR c := 0 TO (DirBlocks - 1) DO
      INCL(SecGrpMap^[(c DIV 16)], (c MOD 16));
  END;

  IF GetFirstDirEntry(DirFile, ADR(DirEntry))
     THEN REPEAT ProcessDirEntry(DirEntry);
          UNTIL  NOT GetNextDirEntry(DirFile, ADR(DirEntry));
  END;

  CheckSecGrpAllocation;

(*
  IF EntryHead # NIL
     THEN CurrUser  := 32;
          DispCount := 0;
          BlockSize := BlockSize DIV 1024;
          ListEntrys(EntryHead);
  END;
*)

  IF SGEHead = NIL
     THEN WriteString('Disk Allocation Map, and Directory are OK');
          WriteLn;
     ELSE ProcessSecGrpErrors;
  END;

  WriteLn;

  DisplayMessage('Leaving DoProcess');

END DoProcess;

BEGIN (* CheckDir *)

  SelectedDrive := GetDriveToCheck();

  IF OpenDir(DirFile, SelectedDrive)
     THEN DoProcess;
          IF NOT CloseDir(DirFile)
             THEN HALT;
          END;
  END;

END CheckDir.