Power Programming/powerprogramming1994.iso/progtool/dskutl/reform12.arc/REFORM12.PAS

Pascal/Delphi Source File | 1987-05-23 | 42KB | 1,255 lines

PROGRAM reformat;
{
Program to reformat any disk attached to a Olivetti PC or compatible.
The progam will probably work well on any MS/PC-DOS machine running under
DOS 2.xx.  Fixed disks of all sizes.  [Toad Hall note:  not correct.]

Global types }

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;

  Boot       = RECORD
                 Jump:                  ARRAY[0..2] OF Byte;
                 OEM :                  ARRAY[0..7] OF CHAR;
                 sectorSize:            INTEGER;
                 clusterSize:           Byte;
                 reservedSectors:       INTEGER;
                 numberOfFats:          Byte;
                 rootDirSize,
                 totalSectors:          INTEGER;
                 mediaDescriptor:       Byte;
                 fatSize,
                 trackSize,
                 numberOfHeads,
                 numberOfHiddenSectors: INTEGER;
               END;

  IntArray   = ARRAY[0..32766] OF INTEGER;

  Buffer     = ARRAY[0..32766] OF Byte;

  longInteger      = ARRAY[0..1] OF INTEGER;

  DirectoryPointer = ^DirectoryEntry;

  DirectoryEntry   = RECORD
                       EntryName:          ARRAY[0..10] OF CHAR;
                       attribute:          Byte;
                       Reserved:           ARRAY[1..10] OF Byte;
                       timeLastUpdated:    INTEGER;
                       dateLastUpdated:    INTEGER;
                       startingCluster:    INTEGER;
                       fileSize:           longInteger;
                       newStartingCluster: INTEGER;
                       Next,
                       SubDirectory:       DirectoryPointer;
                     END;

  WorkString       = STRING[255];

CONST

  READONLY        = $01;
  HIDDENFILE      = $02;
  SYSTEMFILE      = $04;
  VOLUMELABEL     = $08;
  SUBDIRECTORY    = $10;
  ARCHIVE         = $20;

  NEVERUSED       = $00;
  ERASED          = $E5;

  FIXEDDISK       = $F8;
  DUAL8SECTOR     = $FF;
  SINGLE8SECTOR   = $FE;
  DUAL9SECTOR     = $FD;
  SINGLE9SECTOR   = $FC;

  Unused:          INTEGER = $0000;
  ReservedMinimum: INTEGER = $0FF0;
  ReservedMaximum: INTEGER = $0FF6;
  BadCluster:      INTEGER = $0FF7;
  LastMinimum:     INTEGER = $0FF8;
  LastMaximum:     INTEGER = $0FFF;
  lastNormal:      INTEGER = $0FFF;

VAR

{ Drive characteristics and constants communications block }

  DriveLetter:          CHAR;
  numberOfFats,
  media,
  defaultDrive,
  driveNumber:          Byte;
  freeClusters,
  totalDataClusters,
  firstDataSector,
  fatSize,
  firstFATsector,
  rootDirSize,
  directorySectors,
  firstDirectorySector,
  sectorSize,
  clusterSize:          INTEGER;

{ Global variables }

  Registers:            Regpack;
  oldFATindex,
  newFATindex,
  errors,
  lostClusters,
  totalFiles,
  hiddenFiles,
  inRootDirectory,
  inSubdirectories,
  nonContiguousFiles,
  subdirectories,
  movedClusters,
  clustersToMove,
  count:                INTEGER;
  SAVEaddress,
  DTAddress:           ^Buffer;
  PermutationAddress,
  NewFATAddress,
  OldFATAddress:       ^IntArray;
  RootDir:              DirectoryPointer;
  movedField,
  inputField,
  logField,
  warningField,
  errorField,
  disasterField:        longInteger;
  Anything,
  Instr:                CHAR;
  AlreadyWritten:       BOOLEAN;
  DiskLabel:            ARRAY[0..10] OF CHAR;

{$I REFORMAT.INC    Toad Hall Turbo Inline disk procedure Int2526}

PROCEDURE Beep;
  BEGIN
    WRITE(CHR(7));
  END;

PROCEDURE WriteLog(S: WorkString);
  VAR
    count: INTEGER;
  BEGIN
    GotoXY(logField[0], logField[1]);
    FOR count := logField[0] TO 79 DO WRITE(' ');
    GotoXY(logField[0], logField[1]);
    WRITE(S);
  END;  {of WriteLog}


PROCEDURE WriteWarning(S: WorkString);
  VAR
    count: INTEGER;
  BEGIN
    GotoXY(warningField[0], warningField[1]);
    FOR count := warningField[0] TO 79 DO WRITE(' ');
    GotoXY(warningField[0], warningField[1]);
    WRITE(S);
  END;  {of WriteWarning}


PROCEDURE WriteError(S: WorkString);
  VAR
    count: INTEGER;
  BEGIN
    GotoXY(errorField[0], errorField[1]);
    FOR count := errorField[0] TO 79 DO WRITE(' ');
    GotoXY(errorField[0], errorField[1]);
    WRITE(S);
  END;  {of WriteError}


PROCEDURE WriteDisaster(S: WorkString);
  VAR
    count: INTEGER;
  BEGIN
    GotoXY(disasterField[0], disasterField[1]);
    FOR count := disasterField[0] TO 79 DO WRITE(' ');
    GotoXY(disasterField[0], disasterField[1]);
    WRITE(S);
  END;  {of WriteDisaster}


PROCEDURE GetInput(VAR Instr: CHAR);
  VAR
    count: INTEGER;
  BEGIN
    GotoXY(inputField[0], inputField[1]);
    FOR count := inputField[0] TO 79 DO WRITE(' ');
    GotoXY(inputField[0], inputField[1]);
    Beep;
    READLN(Instr);
    Instr := Upcase(Instr);
  END;  {of GetInput}


PROCEDURE GetInformation;
{ Ask DOS for information about the specified or default disk.
  If we have an error return code from DOS we assume that the disk
  specified was invalid. }
  VAR
    ValidDrive:  BOOLEAN;
    InLetter:    CHAR;
    Instr:       CHAR;
  BEGIN
{ get current disk: MS-DOS function call 19h
  information is returned in AL: 0 = A, 1 = B, etc.}

    WriteLog('Reading Disk Information');
    Registers.ah := $19;
    MSDos(Registers);
    defaultDrive := Registers.al;

    IF paramcount = 0
    THEN Instr   := CHR(65 + defaultDrive)
    ELSE Instr   := COPY(paramstr(1), 1, 1);

    ValidDrive   := FALSE;
    WITH Registers DO REPEAT
      IF ORD(Instr) < 64 THEN Instr := CHR($FF);
      DriveLetter := UpCase(Instr);
      driveNumber := ORD(DriveLetter) - 64;
      ah := $36;
      dl := driveNumber;
      MSDos(Registers);
      IF ax <> $ffff
      THEN BEGIN
        driveNumber          := PRED(driveNumber);
        freeClusters         := bx;
        totalDataClusters    := dx;
        sectorSize           := cx;
        clusterSize          := ax;
        firstFATsector       := 1;
        count                := ( totalDataClusters + 2 ) * 3 ;
        IF count MOD ( sectorSize ShR 1 ) = 0
        THEN fatSize         := count DIV ( sectorSize ShL 1 )
        ELSE fatSize         := count DIV ( sectorSize ShL 1 ) + 1;
        firstDirectorySector := SUCC(fatSize ShL 1);
        ValidDrive           := TRUE;
      END
      ELSE BEGIN
        WriteWarning('Invalid driveletter, enter new letter!');
        GetInput(Instr);
        WriteWarning(' ');
      END;
    UNTIL ValidDrive;
  END;  {of GetInformation}


FUNCTION CarryFlag: BOOLEAN;
  BEGIN
    CarryFlag := ( Registers.Flags AND $01 ) <> 0 ;
  END;  {of CarryFlag}


PROCEDURE ResetDisk;
  BEGIN
    Registers.ah := $0D;
    MSDos(Registers);
  END;  {of ResetDisk}


PROCEDURE ReadSectors(sectorNumber, numberOfSectors: INTEGER);
  BEGIN
    WITH Registers DO REPEAT
      al := driveNumber;
      cx := numberOfSectors;
      dx := sectorNumber;
      ds := Seg(DTAddress^);
      bx := Ofs(DTAddress^);
      Int2526($25);  {Toad Hall disk read}
      IF CarryFlag THEN BEGIN
        IF NOT AlreadyWritten
        THEN BEGIN
          WriteWarning('No data lost!');
          WriteError('Disk read error, enter A (abort), R (retry)?');
        END
        ELSE BEGIN
          WriteError('Probably loss of data!');
          WriteDisaster('Disk read error A(bort), R(etry), I(gnore)?');
        END;
        Instr := '?';
        REPEAT
          Getinput(Instr);
        UNTIL ( Instr IN ['A', 'R'] )
        OR (( Instr = 'I' ) AND AlreadyWritten );
        IF Instr = 'A'
        THEN BEGIN
          ClrScr;
          HALT;
        END
        ELSE BEGIN
          WriteError(' ');
          WriteWarning(' ');
          WriteDisaster(' ');
          IF Instr = 'I' THEN flags := 0;
       END; END;
    UNTIL NOT CarryFlag;
  END;  {of ReadSectors}


PROCEDURE WriteSectors(sectorNumber, numberOfSectors: INTEGER);
  BEGIN
    WITH Registers DO REPEAT
      al := driveNumber;
      cx := numberOfSectors;
      dx := sectorNumber;
      ds := Seg(DTAddress^);
      bx := Ofs(DTAddress^);
      int2526($26);  {Toad Hall write}
      IF CarryFlag
      THEN BEGIN
        IF NOT AlreadyWritten
        THEN BEGIN
          WriteWarning('No data lost!');
          WriteError('Disk write error, enter A (abort), R (retry)?');
        END
        ELSE BEGIN
          WriteError('Probably data lost!');
          WriteDisaster('Disk write error A(bort), R(etry), I(gnore)?');
        END;
        REPEAT
          Getinput(Instr);
        UNTIL ( Instr IN ['A', 'R'] )
        OR (( Instr = 'I' ) AND AlreadyWritten );
        IF Instr = 'A' THEN BEGIN
          ClrScr;
          HALT;
        END
        ELSE BEGIN
          WriteError(' ');
          WriteWarning(' ');
          WriteDisaster(' ');
          IF Instr = 'I' THEN flags := 0;
       END; END;
    UNTIL NOT CarryFlag;
    AlreadyWritten := TRUE;
  END;  {of WriteSectors}


PROCEDURE ReadCluster(clusterNumber: INTEGER);
  VAR
    sectorNumber: INTEGER;
  BEGIN
{ To get around Turbo's maxint, (in case of fixed disks of 20 MB the largest
  sectorNumber is greater than 32767) we split the following formula:

     sectorNumber := clusterSize * ( clusterNumber - 2 ) + firstDataSector;

  Multiplication does not return a correct value when sectorNumber becomes
  greater than maxint. Addition returns a word value (16 bits) that is the
  correct sectorNumber if interpreted as a non-signed integer.
  Since clusterSize is ALWAYS (PC-DOS TECH REF: chap Device Drivers,
  boot record layout) a power of 2, we may divide it by 2. }

    IF clusterSize < 2
    THEN sectorNumber := clusterNumber - 2 + firstDataSector
    ELSE sectorNumber := ( clusterSize ShR 1 ) * ( clusterNumber - 2 ) +
                         ( clusterSize ShR 1 ) * ( clusterNumber - 2 ) +
                         firstDataSector;
    ReadSectors(sectorNumber, clusterSize);
  END;  {of ReadCluster}


PROCEDURE WriteCluster(clusterNumber: INTEGER);
  VAR
    sectorNumber: INTEGER;
  BEGIN
{ To get around Turbo's maxint, (in case of fixed disks of 20 MB the largest
  sectorNumber is greater than 32767) we split the following formula:

     sectorNumber := clusterSize * ( clusterNumber - 2 ) + firstDataSector;

  Multiplication does not return a correct value when sectorNumber becomes
  greater than maxint. Addition returns a word value (16 bits) that is the
  correct sectorNumber if interpreted as a non-signed integer.
  Since clusterSize is ALWAYS (PC-DOS TECH REF: chap Device Drivers,
  boot record layout) a power of 2, we may divide it by 2. }

    IF clusterSize < 2
    THEN sectorNumber := clusterNumber - 2 + firstDataSector
    ELSE sectorNumber := ( clusterSize ShR 1 ) * ( clusterNumber - 2 ) +
                         ( clusterSize ShR 1 ) * ( clusterNumber - 2 ) +
                         firstDataSector;
    WriteSectors(sectorNumber, clusterSize);
  END;  {of WriteCluster}


PROCEDURE ReadBootSector(VAR DTArea: Buffer);
{ Read the bootsector from disk. Use the information we find in it
  to set a number of variables in the communication block. If the
  information in the bootsector is inconsistent with the story DOS
  told us (GetInformation) we use the FAT identification byte for
  the setting of the variables. This will probably only occur in
  case we have a disk that was formatted under a pre DOS 2.0 version.}

  VAR
    FATidentification: Byte;
    Instr:             CHAR;
    BootInfo:          Boot Absolute DTArea;

  BEGIN
    WriteLog('Reading Bootsector.');
    ReadSectors(0, 1);
    IF        ( BootInfo.sectorSize      <> sectorSize )
       OR     ( BootInfo.clusterSize     <> clusterSize )
       OR     ( BootInfo.numberOfFats    =  0 )
       OR     ( BootInfo.rootDirSize     =  0 )
       OR     ( BootInfo.totalSectors    <  totalDataClusters * clusterSize )
       OR NOT ( BootInfo.mediaDescriptor IN [$F0..$FF] )
       OR     ( BootInfo.fatSize         <> fatSize )
    THEN BEGIN
      WriteWarning('Pre DOS 2.0 formatted disk, or incomplete bootsector.');
      ReadSectors(firstFATsector, 1);
      FATidentification := DTArea[0];
      numberOfFats      := 2;
      IF ( FATidentification = SINGLE8SECTOR )
      OR ( FATidentification = SINGLE9SECTOR )
      THEN rootDirSize  := 64
      { Not Single Sided }
      ELSE IF ( FATidentification = DUAL8SECTOR )
      OR ( FATidentification = DUAL9SECTOR )
      THEN rootDirSize  := 112
      ELSE IF FATidentification = FIXEDDISK
      THEN BEGIN  {Fixed Disk}
        WriteError('Fixed Disk: cannot compute size.');
        WriteDisaster('Press enter to return to DOS.');
        GetInput(Instr);
        ClrScr;
        HALT;
      END
      ELSE BEGIN
        WriteError('Unknown Disk Type (FAT id byte).');
        WriteDisaster('Press enter to return to DOS.');
        GetInput(Instr);
        ClrScr;
        HALT;
      END;
      firstDataSector   := numberOfFats * fatSize +
                           rootDirSize  * 32 DIV sectorSize + 1;
      media             := FATidentification;

    END
    ELSE BEGIN
      numberOfFats    := BootInfo.numberOfFats;
      IF numberOfFats <> 2
      THEN firstDirectorySector := SUCC(fatSize * numberOfFats);
      rootDirSize     := BootInfo.rootDirSize;
      firstDataSector := numberOfFats * fatSize +
                         rootDirSize  * 32 DIV sectorSize + 1;
      media           := BootInfo.mediaDescriptor;
    END;
  END;  {of ReadBootSector}


PROCEDURE ReadFat(VAR unscrambledFAT: IntArray; VAR scrambledFAT: Buffer);
  { Read and unscramble the FAT. Only the first FAT is processed.}
  VAR
    i, temp:     INTEGER;
  BEGIN
    WriteLog('Reading and unscrambling FAT.');
    ReadSectors(firstFATsector, fatSize);
    FOR i := 0 TO SUCC(totalDataClusters) DO BEGIN
      Move( scrambledFAT[3 * i ShR 1], temp, 2);
      IF ODD(i) THEN temp := temp ShR 4 ELSE temp := temp AND $0FFF;
      unscrambledFAT[i] := temp;
    END;
  END;  {of ReadFat}


PROCEDURE WriteFat(VAR unscrambledFAT: IntArray; VAR scrambledFAT: Buffer);
{ Write the FAT back to the disk. The FAT has to be scrambled before
  writing. FAT entries on disk are 12 bits long. Because there are mostly
  2 versions of the fat on disk, we write both fats simultaneously.}
  VAR
    i,
    temp1,
    temp2:          INTEGER;
  BEGIN
    WriteLog('Writing FAT.');
    FOR i := 0 TO totalDataClusters + 1 DO BEGIN
      temp1 := unscrambledFAT[i];
      Move( scrambledFAT[3 * i ShR 1], temp2, 2);
      IF ODD(i) THEN temp1 := (temp2 AND $000F) OR (temp1 ShL 4)
                ELSE temp1 := (temp2 AND $F000) OR temp1;
      Move( temp1, scrambledFAT[3 * i ShR 1], 2);
    END;
    WriteSectors(firstFATsector, fatSize);
    WriteSectors(firstFATsector + fatSize, fatSize);
  END;  {of WriteFat}


PROCEDURE ReadSubdirectory(VAR DTArea:      Buffer;
                           VAR FATarea:     INTArray;
                           VAR SubRoot:     DirectoryPointer;
                           startingCluster: INTEGER);
{ Link subdirectory entries in a list. Build a tree (by calling this
  routine recursively) if a subdirectory is found.}
  VAR
    clusterNumber,
    dirIndex:      INTEGER;
    Present:       DirectoryPointer;
    EndSearch:     BOOLEAN;
  BEGIN
    subdirectories := SUCC(subdirectories);
    clusterNumber  := startingCluster;
    SubRoot        := NIL;
    EndSearch      := FALSE;
    REPEAT
      ReadCluster(clusterNumber);
      dirIndex     := 0;
      REPEAT
        IF NOT ( DTArea[dirIndex] IN [NEVERUSED, ERASED] )
        THEN BEGIN
          IF SubRoot = NIL THEN BEGIN
            NEW(SubRoot);
            Present := SubRoot;
          END
          ELSE BEGIN
            NEW(Present^.Next);
            Present := Present^.Next;
          END;
          Move(DTArea[dirIndex], Present^, 32);
          IF ( Present^.attribute = SUBDIRECTORY ) AND
             ( Present^.EntryName[0] <> '.' )
          THEN BEGIN
            ReadSubdirectory(DTArea, FATarea, Present^.SubDirectory,
                             Present^.startingCluster);
            Readcluster(clusterNumber);
          END
          ELSE BEGIN
            Present^.SubDirectory := NIL;
            IF Present^.Entryname[0] <> '.'
            THEN BEGIN
              totalFiles            := SUCC(totalFiles);
              inSubdirectories      := SUCC(inSubdirectories);
              IF ( Present^.attribute AND HIDDENFILE ) <> 0
              THEN hiddenFiles := SUCC(hiddenFiles);
            END;
          END;
        END
        ELSE IF DTArea[dirIndex] = NEVERUSED
        THEN EndSearch := TRUE;
        dirIndex := dirIndex + 32;
      UNTIL    ( dirIndex >= sectorSize * clusterSize)
      OR ( EndSearch );
      clusterNumber :=  FATarea[clusterNumber];
    UNTIL ( clusterNumber >= ReservedMinimum ) OR EndSearch;
    IF Present <> NIL THEN Present^.Next := NIL;
  END;  {of ReadSubdirectory}


PROCEDURE ReadDirectories(VAR DTArea: Buffer);
{ Read the Rootdirectory and whenever an entry for a subdirectory is
  found call ReadSubdirectory. Link all directory entries dynamically
  in a linked list. This list is actually a tree, because the lists
  for subdirectories are linked to this list.}

  VAR
    EndSearch:     BOOLEAN;
    sectorNumber,
    dirIndex:      INTEGER;
    Present:       DirectoryPointer;
  BEGIN
    WriteLog('Reading Directory and Subdirectories.');
    sectorNumber := firstDirectorySector;
    RootDir      := NIL;
    EndSearch    := FALSE;
    REPEAT
      dirIndex := 0;
      ReadSectors(sectorNumber, 1);
      REPEAT
        IF NOT ( DTArea[dirIndex] IN [NEVERUSED, ERASED] )
        THEN BEGIN
          IF RootDir = NIL THEN BEGIN
            NEW(RootDir);
            Present := RootDir;
          END
          ELSE BEGIN
            NEW(Present^.Next);
            Present := Present^.Next;
          END;
          Move(DTArea[dirIndex], Present^, 32);
          IF ( Present^.attribute = SUBDIRECTORY ) AND
             ( Present^.EntryName[0] <> '.' )
          THEN BEGIN
            ReadSubdirectory(DTArea, OldFATaddress^,
                             Present^.SubDirectory,
                             Present^.startingCluster);
            ReadSectors(sectorNumber, 1);
          END
          ELSE BEGIN
            Present^.SubDirectory := NIL;
            IF ( Present^.attribute    <> VOLUMELABEL ) AND
               ( Present^.Entryname[0] <> '.'         )
            THEN BEGIN
              totalFiles            := SUCC(totalFiles);
              inRootDirectory       := SUCC(inRootDirectory);
              IF ( Present^.attribute AND HIDDENFILE ) <> 0
              THEN hiddenFiles := SUCC(hiddenFiles);
            END;
          END;
        END
        ELSE IF DTArea[dirIndex] = NEVERUSED
        THEN EndSearch := TRUE;
        dirIndex := dirIndex + 32;
      UNTIL ( dirIndex >= sectorSize ) OR EndSearch;
      sectorNumber := SUCC(sectorNumber);
    UNTIL ( sectorNumber = firstDataSector ) OR EndSearch;
    IF Present <> NIL THEN Present^.Next := NIL;
  END;  {of ReadDirectories}


PROCEDURE RemakeFAT(VAR oldFATarea, newFATarea, permutation: IntArray;
                    Root: DirectoryPointer; parent, thisDir: INTEGER);

{ This procedure is called recursively.
  From the OldFAT and the directory entries we construct a NewFAT and
  a permutation. The permutation is used by DoIt for moving the
  clusters. This routine is called one extra time for the chain of
  the empty clusters by LinkFreeDataClusters.
  Recursion is used whenever we find an entry for a subdirectory, in
  the following way: first call this routine for the remainder of the
  current directory, second for the subdirectory.
  The function newFATindex is used to prevent accidental use of clusters
  that were marked as bad or reserved clusters.}

  FUNCTION nextFATindex: INTEGER;
    VAR
      temp: INTEGER;
    BEGIN
      temp := SUCC(newFATindex);
      WHILE ( oldFATarea[temp] >= ReservedMinimum ) AND
            ( oldFATarea[temp] <= BadCluster      ) AND
            ( temp <= SUCC(totalDataClusters) )
      DO BEGIN
        newFATarea[temp] := oldFATarea[temp];
        temp             := SUCC(temp);
      END;
      nextFATindex := temp;
    END;  {of nextFATindex}

  VAR
    Present: DirectoryPointer;
    Split:   BOOLEAN;
    temp:    INTEGER;
  BEGIN
    IF newFATindex = 1 THEN newFATindex := nextFATindex;
    Present := Root;
    Split   := FALSE;
    WHILE ( Present <> NIL ) AND NOT Split DO BEGIN
      IF ( Present^.attribute <> VOLUMELABEL ) AND
         ( Present^.startingCluster <> 0 ) AND
         ( Present^.Entryname[0] <> '.')
      THEN BEGIN
        IF Present^.SubDirectory <> NIL
        THEN BEGIN
          Split := TRUE;
          RemakeFAT(oldFATarea, newFATarea, permutation,
                    Present^.Next, parent, thisDir);
        END;
        oldFATindex                 := Present^.startingCluster;
        Present^.newStartingCluster := newFATindex;
        permutation[newFATindex]    := oldFATindex;
        WHILE oldFATarea[oldFATindex] < LastMinimum DO BEGIN
          temp                     := nextFATindex;
          newFATarea[newFATindex]  := temp;
          newFATindex              := temp;
          oldFATindex              := oldFATarea[oldFATindex];
          permutation[newFATindex] := oldFATindex;
        END;
        newFATarea[newFATindex] := lastNormal;
        newFATindex             := nextFATindex;
        IF Split THEN
          RemakeFAT(oldFATarea, newFATarea, permutation,
                    Present^.SubDirectory, thisDir,
                    Present^.newStartingCluster);
     END
     ELSE BEGIN
       IF ( Present^.EntryName[0] = '.'  ) AND
          ( Present^.EntryName[1] = '.'  )
       THEN Present^.newStartingCluster := parent
       ELSE IF Present^.EntryName[0] = '.'
       THEN Present^.newStartingCluster := thisDir
       ELSE BEGIN
         Present^.newStartingCluster := 0;
         IF Present^.attribute = VOLUMELABEL
         THEN FOR count := 0 TO 10 DO
           DiskLabel[count] := Present^.EntryName[count];
       END;
     END;
     Present := Present^.Next;
   END;
 END;  {of RemakeFAT}


PROCEDURE LinkFreeClusters(VAR oldFATarea, newFATarea: IntArray);
{ Link Free clusters in a chain, pointed to by Empty^.
  Use RemakeFAT to fill permutation, but clean NewFAT after
  this. This procedure will ensure that permutation is a
  proper permutation, without double entries which might
  cause DoIt to loop indefinitely or destroy our disk. }

  VAR
    count,
    next,
    previous: INTEGER;
    Empty:    DirectoryPointer;

  BEGIN
    NEW(Empty);
    Empty^.next            := NIL;
    Empty^.subDirectory    := NIL;
    Empty^.Entryname[0]    := 'X';
    Empty^.attribute       := HIDDENFILE;
    Empty^.startingCluster := 0;
    count                  := 2;
    WHILE ( count <= totalDataClusters + 1 ) AND
          ( oldFATarea[count] <> 0         )
    DO count := SUCC(count);
    IF count <= SUCC(totalDataClusters)
    THEN BEGIN
      Empty^.startingCluster := count;
      previous               := count;
      WHILE count < SUCC(totalDataClusters)
      DO BEGIN
        count := SUCC(count);
        IF oldFATarea[count] = 0
        THEN BEGIN
          oldFATarea[previous] := count;
          previous             := count;
        END;
      END;
      oldFATarea[previous] := lastNormal;
    END;
    IF Empty^.startingCluster <> 0
    THEN BEGIN
      RemakeFAT(oldFATarea, newFATarea,
                PermutationAddress^, Empty, 0, 0);
      Next := Empty^.newStartingCluster;
      WHILE next <> lastNormal
      DO BEGIN
        previous             := next;
        next                 := newFATarea[previous];
        newFATarea[previous] := 0;
      END;
    END;
  END;  {of LinkFreeClusters}


PROCEDURE  WriteSubdirectory(VAR DTArea: Buffer; VAR oldFATarea: IntArray;
                             Root: DirectoryPointer; start: INTEGER);

{ Write subdirectories back to disk. Erased entries are removed
  from the subdirectories. The subdirectories are written to their
  old locations, because DoIt will take care of moving the clusters
  to their new places. No effort is done to truncate a subdirectory
  which would be longer than needed after removal of erased entries.
  We will however set all remaining entries to 'NEVERUSED'.
  This routine is used recursively.}

  VAR
    start1,
    clusterNumber,
    dirIndex:      INTEGER;
    Present:       DirectoryPointer;

  BEGIN
    Present       := Root;
    clusterNumber := start;
    WHILE Present <> NIL
    DO BEGIN
      dirIndex := 0;
      FillChar(DTArea, clusterSize * sectorSize, $00);
      REPEAT
        start1 := Present^.startingCluster;
        Present^.startingCluster := Present^.newStartingCluster;
        Move(Present^, DTArea[dirIndex], 32);
        IF ( Present^.attribute = SUBDIRECTORY ) AND
           ( Present^.EntryName[0] <> '.' )
        THEN BEGIN
          WriteCluster(clusterNumber);
          WriteSubdirectory(DTArea, oldFATarea,
                            Present^.SubDirectory, start1);
          ReadCluster(clusterNumber);
        END;
        Present  := Present^.Next;
        dirIndex := dirIndex + 32;
      UNTIL ( dirIndex >= clusterSize * sectorSize ) OR ( Present = NIL );
      WriteCluster(clusterNumber);
      clusterNumber := oldFATarea[clusterNumber];
    END;
    IF clusterNumber < LastMinimum
    THEN BEGIN
      FillChar(DTArea, sectorSize * clusterSize, $00);
      WHILE clusterNumber < LastMinimum
      DO BEGIN
        WriteCluster(clusterNumber);
        clusterNumber := oldFATarea[clusterNumber];
      END;
    END;
  END;  {of WriteSubdirectories}


PROCEDURE WriteDirectories(VAR DTArea: Buffer);

{ Write rootdirectory back to disk. Erased entries are removed
  from the directory. When we find a subdirectory entry, we first
  process this subdirectory by calling WriteSubdirectories,
  before we proceed with the root. All entries that are no in use
  are set to 'NEVERUSED'.}

  VAR
    start,
    sectorNumber,
    dirIndex:      INTEGER;
    Present:       DirectoryPointer;
  BEGIN
    WriteLog('Writing new Directory and Subdirectories.');
    sectorNumber := firstDirectorySector;
    Present      := RootDir;
    WHILE Present <> NIL
    DO BEGIN
      dirIndex := 0;
      FillChar(DTArea, sectorSize, $00);
      REPEAT
        start := Present^.startingCluster;
        Present^.startingCluster := Present^.newStartingCluster;
        Move(Present^, DTArea[dirIndex], 32);
        IF ( Present^.attribute = SUBDIRECTORY ) AND
           ( Present^.EntryName[0] <> '.' )
        THEN BEGIN
          WriteSectors(sectorNumber, 1);
          WriteSubdirectory(DTArea, OldFATaddress^,
                            Present^.SubDirectory, start);
          ReadSectors(sectorNumber, 1);
        END;
        Present  := Present^.Next;
        dirIndex := dirIndex + 32;
      UNTIL ( dirIndex >= sectorSize ) OR ( Present = NIL );
      WriteSectors(sectorNumber, 1);
      sectorNumber := SUCC(sectorNumber);
    END;
    IF sectorNumber < firstDataSector
    THEN BEGIN
      FillChar(DTArea, sectorSize, $00);
      WHILE sectorNumber < firstDataSector
      DO BEGIN
        WriteSectors(sectorNumber, 1);
        sectorNumber := SUCC(sectorNumber);
      END;
    END;
  END;  {of WriteDirectories}


PROCEDURE DoIt(VAR permutation: IntArray; VAR DTArea, SaveArea: Buffer);

{ DoIt. This routine performs the actual reformating of the disk.
  The array permutation contains in every location  [i] (starting
  from 2) which cluster has to be moved to cluster location i.
  Because we have a real permutation, this permutation can be
  parsed into a number of cyclical permutations. We start at the
  first cyclic permutation that is not identity. We save the first
  cluster of this cyclical permutation, proceed through the cyclical
  permutation, moving one cluster at a time, until we finish the
  cycle. We than write the saved cluster to disk.}

  VAR
    prior,
    next,
    lastStart: INTEGER;
  BEGIN
    WriteLog('Reformatting......');
    lastStart := 2;
    WHILE lastStart <= SUCC(totalDataClusters)
    DO BEGIN
      IF lastStart = permutation[lastStart]
      THEN lastStart := SUCC(lastStart)
      ELSE BEGIN
        ReadCluster(lastStart);
        Move(DTArea, SaveArea, sectorSize * clusterSize);
        prior := lastStart;
        next  := permutation[lastStart];
        REPEAT
          ReadCluster(next);
          WriteCluster(prior);
          movedClusters      := SUCC(movedClusters);
          GotoXY(movedField[0], movedField[1]);
          WRITE(movedClusters:10);
          permutation[prior] := prior;
          prior              := next;
          next               := permutation[next];
        UNTIL next = lastStart;
        Move(SaveArea, DTArea, sectorSize * clusterSize);
        WriteCluster(prior);
        movedClusters      := SUCC(movedClusters);
        GotoXY(movedField[0], movedField[1]);
        WRITE(movedClusters:10);
        permutation[prior] := prior;
      END;
    END;
    WriteLog(' ');
  END;  {of Doit}


PROCEDURE InitScreen;
  VAR
    row,
    column: INTEGER;
    S : STRING[80];
  BEGIN
    NormVideo;
    ClrScr;
    S[0] := #77;             {force length}
    FillChar(S[1],77,#205);  {horizontal line}
    row := 2;
    WRITE(#201, S, #187);
    WRITE(#186); GotoXY(80, row);  WRITE(#186);
    GotoXY(17, row); WRITE('REFORMAT: an original JOS disk tool. Ver: 1.21TH');
    FillChar(S[1],77,#196);  {horizontal line}

    row := SUCC(row); GotoXY(1, row);
    WRITE(#199, S, #182);
    FOR row := 4 TO 15 DO BEGIN
      WRITE(#186); GotoXY(80, row);  WRITE(#186);
    END;
    WRITE(#199, S, #182);
    WRITE(#186);  GotoXY(80, 17);  WRITE(#186);
    WRITE(#199, S, #182);
    FOR row := 19 TO 23 DO BEGIN
      WRITE(#186);  GotoXY(80, row);  WRITE(#186);
    END;
    WRITE(#200, S, #188);
    GotoXY(05, 19); WRITE('User Input Field :');
    GotoXY(05, 20); WRITE('Activity Logging :');
    GotoXY(05, 21); WRITE('Warning  Messages:');
    GotoXY(05, 22); WRITE('Error    Messages:');
    GotoXY(05, 23); WRITE('Disaster Messages:');
    inputField[0]    := 24;
    inputField[1]    := 19;
    logField[0]      := 24;
    logField[1]      := 20;
    warningField[0]  := 24;
    warningField[1]  := 21;
    errorField[0]    := 24;
    errorField[1]    := 22;
    disasterField[0] := 24;
    disasterField[1] := 23;
  END;  {of InitScreen}


PROCEDURE CheckSubdirectory(VAR FAT: IntArray;
                            Root: DirectoryPointer; parent, thisDir: INTEGER);

{ This procedure is called recursively.
  The SubDirectories are checked here. No attempt is made
  to correct any errors found. If any errors are found, a message
  is issued and the program stops. The users must first run CHKDSK from
  DOS before we accept the disk. }

  VAR
    Present: DirectoryPointer;
    prior,
    next:    INTEGER;
  BEGIN
    Present := Root;
    WHILE ( Present <> NIL ) AND ( errors = 0 ) BEGIN
      IF ( Present^.attribute <> VOLUMELABEL ) AND
         ( Present^.startingCluster <> 0 ) AND
         ( Present^.Entryname[0] <> '.')
      THEN BEGIN
        next  := Present^.startingCluster;
        count := 0;
        REPEAT;
          IF ( next > SUCC(totalDataClusters) )
          OR ( next < 1 )
          THEN errors := SUCC(errors)
          ELSE BEGIN
            prior      := next;
            next       := FAT[prior];
            FAT[prior] := 0;
            IF next <> SUCC(prior) THEN count := SUCC(count);
          END;
        UNTIL ( next >= LastMinimum ) OR ( errors <> 0 );
        IF count > 1 THEN nonContiguousFiles := SUCC(nonContiguousFiles);
        IF Present^.SubDirectory <> NIL
        THEN CheckSubdirectory(FAT, Present^.SubDirectory,
                               thisDir, Present^.startingCluster);
      END
      ELSE BEGIN
        IF ( Present^.EntryName[0] = '.' ) AND
           ( Present^.EntryName[1] = '.' )
        THEN IF Present^.startingCluster <> parent
             THEN errors := SUCC(errors)
             ELSE
        ELSE IF Present^.EntryName[0] = '.'
        THEN IF Present^.startingCluster <> thisDir
             THEN errors := SUCC(errors)
             ELSE
        ELSE IF Present^.startingCluster <> 0
        THEN errors := SUCC(errors);
      END;
      Present := Present^.next;
    END;
  END;  {of CheckSubdirectory}


PROCEDURE CheckDisk(VAR FAT: IntArray; Root: DirectoryPointer);

{ The FAT and the Directories are checked here. No attempt is made
  to correct any errors found. If any errors are found, a message
  is issued and the program stops. The users must first run CHKDSK from
  DOS before we accept the disk.                                        }

  BEGIN
    WriteLog('Checking FAT....');
    CheckSubdirectory(FAT, Root, 0, 0);
    FOR count := 2 TO totalDataClusters + 1 DO
      IF ( FAT[count] <> 0 ) AND
         ( ( FAT[count] < ReservedMinimum ) OR
           ( FAT[count] > BadCluster      ) )
      THEN lostClusters := SUCC(lostClusters);
    IF errors <> 0
    THEN BEGIN
      WriteError('Crosslinked clusters found. Run CHKDSK first.');
      WriteWarning('Press Enter to return to DOS.');
      GetInput(Instr);
      ClrScr;
      HALT;
    END
    ELSE IF lostClusters <> 0
    THEN BEGIN
      WriteError('Lost clusters found. Run CHKDSK first.');
      WriteWarning('Press Enter to return to DOS.');
      GetInput(Instr);
      ClrScr;
      HALT;
    END;
  END;  {of CheckDisk}


PROCEDURE CountClustersToMove(VAR permutation: IntArray);
  BEGIN
    FOR count := 2 TO SUCC(totalDataClusters)
    DO IF permutation[count] <> count
    THEN clustersToMove := SUCC(clustersToMove);
  END;  {of CountClustersToMove}


PROCEDURE InitCounters;
  BEGIN
    oldFATindex         := 0;
    newFATindex         := 1;
    errors              := 0;
    lostClusters        := 0;
    totalFiles          := 0;
    hiddenFiles         := 0;
    inRootDirectory     := 0;
    inSubdirectories    := 0;
    nonContiguousFiles  := 0;
    subdirectories      := 0;
    movedClusters       := 0;
    clustersToMove      := 0;
    count               := 0;
    AlreadyWritten      := FALSE;
    DiskLabel           := '           ';
  END;  {of InitCounters}


PROCEDURE WriteStatistics;
  VAR
    row: INTEGER;
  BEGIN
    IF nonContiguousFiles = 0 THEN clustersToMove := 0;
    row := 5;
    IF DiskLabel <> '           '
    THEN BEGIN
      GotoXY(18, row); WRITE('Volume Label is . . . . . :   ', DiskLabel);
      row := SUCC(row);
    END;
    GotoXY(18, row); WRITE(     'Total # of files. . . . . :', totalFiles:10);
    IF hiddenFiles <> 0
    THEN             WRITE(' (hidden:', hiddenFiles:3,')');
    row := SUCC(row);
    IF subdirectories = 0
    THEN BEGIN
      GotoXY(18, row); WRITE('All files in Rootdirectory.');
    END
    ELSE BEGIN
      GotoXY(18, row); WRITE('  in Root directory . . . :',
                                inRootDirectory:10);
      row := SUCC(row);
      GotoXY(18, row); WRITE('  in ', subdirectories:3, ' Subdirectories . :',
                                inSubDirectories:10);
    END;
    row := SUCC(row);
    GotoXY(18, row);      WRITE('# of noncontiguous files. :',
                                 nonContiguousFiles:10);
    row := SUCC(row);
    GotoXY(18, row);      WRITE('# of clusters to be moved :',
                                 clustersToMove:10);
    row := SUCC(row);
    GotoXY(18, row);      WRITE('# of clusters moved . . . :',
                                 movedClusters:10);
    movedField[0] := 45;
    movedField[1] := row;
    row := row + 2;
    GotoXY(05, row);      WRITE('clusterSize . . :', clusterSize:06,
                                ' sectors.');
    GotoXY(45, row);      WRITE('sectorSize. . . :', sectorSize:06,
                                ' bytes.');
    row := SUCC(row);
    GotoXY(05, row);      WRITE('Total data space:', totalDataClusters:6,
                                ' clusters.');
    GotoXY(45, row);      WRITE('DOS space . . . :', firstDataSector:6,
                                ' sectors.');
    row := SUCC(row);
    GotoXY(05, row);      WRITE('Free data space :', freeClusters:6,
                                ' clusters.');
    GotoXY(45, row);      WRITE('Disk type . . . :');
    CASE media OF
      $F8:   { FIXEDDISK    }   WRITE(' Fixed Disk');
      $FE:   { SINGLE8SECTOR}   WRITE(' 1 sided / 8 sect');
      $FF:   { DUAL8SECTOR  }   WRITE(' 2 sided / 8 sect');
      $FC:   { SINGLE9SECTOR}   WRITE(' 1 sided / 9 sect');
      $FD:   { DUAL9SECTOR  }   WRITE(' 2 sided / 9 sect');
    END;  {case}
  END;  {of WriteStatistics}


PROCEDURE WriteDoc;
  BEGIN
    ClrScr;
    WRITELN;
    WRITELN('           REFORMAT: an original JOS disk tool.');
    WRITELN;
    WRITELN('                Public Domain Software.');
    WRITELN;
    WRITELN('Makes all files  on a floppy or  fixed disk contiguous  again,');
    WRITELN('improving  disk  performance  dramatically. Either fixed disks');
    WRITELN('or diskettes.                               Requires DOS 2.xx.');
    WRITELN('Register at the following address to be on my mailing list for');
    WRITELN('updates:');
    WRITELN;
    WRITELN('                   Jos Wennmacker');
    WRITELN('                   Universitair Rekencentrum');
    WRITELN('                   Geert Grooteplein Zuid 41');
    WRITELN('                   NL-6525 GA Nijmegen');
    WRITELN('                   The Netherlands');
    WRITELN;
    WRITELN;
    WRITELN;
    WRITELN('Also comments, bugs etc are expected at one of these addresses.');
    WRITELN;
    WRITELN('       Press enter to see next page');
    READLN;
    ClrScr;
    WRITELN;
    WRITELN('           REFORMAT: an original JOS disk tool.');
    WRITELN('                Version 1.21TH, 860502');
    WRITELN('                Public Domain Software.');
    WRITELN;
    WRITELN;
    WRITELN('Use: Reformat [d:]');
    WRITELN;
    WRITELN('where d: is an optional driveletter. Ommiting d: will select the');
    WRITELN('default  drive.  This  program  works for  both fixed  disks and');
    WRITELN('floppies.');
    WRITELN;
    WRITELN('*  WARNING * WARNING * WARNING * WARNING * WARNING * WARNING  **');
    WRITELN;
    WRITELN('NEVER use  this  program  on a disk that  contains * PROTECTED *');
    WRITELN('software. You might find these  programs turned into an  illegal');
    WRITELN('copy or even end up with a scrambled disk!!!!!!');
    WRITELN('Always *UNINSTALL* this kind of software before using REFORMAT!!');
    WRITELN('The program will  prompt you to confirm  this in case of a fixed');
    WRITELN('disk.');
    WRITELN;
  END;  {of WriteDoc}


BEGIN  {main}
  IF paramcount <> 0
  THEN IF COPY(paramstr(1), 1, 1) = '?'
       THEN BEGIN
            WriteDoc;
            HALT;
       END
       ELSE BEGIN
            IF ( paramcount > 1 )
            OR ( LENGTH(paramstr(1)) > 2 )
            OR ( (LENGTH(paramstr(1)) = 2 ) AND
                 (COPY(paramstr(1), 2, 1) <> ':') )
            THEN BEGIN
                 WRITELN;
                 WRITELN('Invalid parameter: REFORMAT [d:] or ?.');
                 HALT;
       END; END;
  InitCounters;
  InitScreen;
  GetInformation;
  IF clusterSize < fatSize
  THEN GetMem(DTAddress, sectorSize * fatSize)
  ELSE GetMem(DTAddress, sectorSize * clusterSize);
  GetMem(SAVEaddress, sectorSize * clusterSize);
  GetMem(PermutationAddress, totalDataClusters ShL 1 + 4);
  GetMem(OldFATaddress, totalDataClusters ShL 1 + 4);
  GetMem(NewFATaddress, totalDataClusters ShL 1 + 4);
  ReadBootSector(DTAddress^);
  ReadFat(OldFATaddress^, DTAddress^);
  ReadDirectories(DTAddress^);
  Move(OldFATaddress^, NewFATaddress^, totalDataClusters ShL 1 + 4);
  CheckDisk(NewFATaddress^, RootDir);
  FillChar(NewFATaddress^, totalDataClusters ShL 1 + 4, 0);
  FOR count := 0 TO SUCC(totalDataClusters) DO
  PermutationAddress^[count] := count;
  Move(OldFATaddress^, NewFATaddress^, 4);
  RemakeFAT(OldFATaddress^, NewFATaddress^,
            PermutationAddress^, RootDir, 0, 0);
  LinkFreeClusters(OldFATaddress^, NewFATaddress^);
  CountClustersToMove(PermutationAddress^);
  WriteStatistics;
  IF nonContiguousFiles <> 0
  THEN BEGIN
    IF media = FIXEDDISK
    THEN BEGIN
      GotoXY(05, 17);
      WRITE ('Fixed disk: did you uninstall all protected software? ',
             'Continue (Y/N)?');
      Instr := 'Q';
      WHILE NOT ( Instr IN ['Y', 'N'] )
      DO GetInput(Instr);
      IF Instr = 'N' THEN BEGIN
        WriteWarning('Press Enter to return to DOS.');
        GetInput(Instr);
        ClrScr;
        HALT;
      END;
    END;
    ResetDisk;
    WriteFAT(NewFATaddress^, DTAddress^);
    WriteDirectories(DTAddress^);
    DoIt(PermutationAddress^, DTAddress^, SAVEaddress^);
    ResetDisk;
    WriteLog('Done ! Press Enter-Key to return to DOS.');
  END
  ELSE BEGIN
    WriteWarning('All files are contiguous. Nothing to be done!');
    WriteLog('Press Enter-Key to return to DOS.');
  END;
  GetInput(Anything);
  ClrScr;
END.