Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/SFMSRC.ARC/SFMDOS.INC

Text File | 1987-11-15 | 44.9 KB | 1,574 lines

{                         Super File Manager

                              SFMDOS.INC

                          by David Steiner
                             2035 J Apt. 6
                             Lincoln, NE



   Procedures put in this include file are mostly lower level DOS
     calls and the like.  Very few of them perform any actual input or
     output, the major exception being the CopyEntries procedure.

     Most of the very low level routines are functions of type integer.
     These functions will return the error code specified by the Int24Result
     function found in sfmOTHER.inc or an error code that is specific to
     the DOS function used.  These error codes are standard for DOS except
     they have had their high bit set so the ErrorMessage procedure will
     know which error message to print.
     If this code is not 0 (no error) it may then be passed on the the
     ErrorMessage routine to let the user know what happened.

   In the interest of consistency, procedures I have written accept drive
     numbers according to A=1, B=2, etc.  DOS, however, is not always so
     helpful and within my procedures the drive specifier passed must often
     be altered by one.  Please keep this in mind when making changes.
     I rather unfortunately wiped out my hard disk's FAT once when I was
     making some relatively minor changes to the directory update functions.

}

procedure LoadSectors( drv, start, sectors : integer; DTA : Addr_T );
  {
  DOS interrupt $25 performs an absolute disk read.  We are forced
    to use inline code because DOS leaves a copy of the flags register
    on the stack after it returns control.  Because of this 'garbage'
    left on the stack the Turbo procedure Intr will bomb when it attempts
    to return control.
  }
begin
  drv := drv - 1;
  Inline(
    $06                    {        PUSH    ES ; DOS interrupt $25 will     }
    /$1E                   {        PUSH    DS ;   scramble all registers   }
    /$56                   {        PUSH    SI ;   so we'd best save all    }
    /$55                   {        PUSH    BP                              }
    /$52                   {        PUSH    DX                              }
    /$51                   {        PUSH    CX                              }
    /$53                   {        PUSH    BX                              }
    /$50                   {        PUSH    AX                              }
                           {        ;                                       }
    /$8B/$96/>START        {        MOV     DX,>start[BP]                   }
    /$8B/$8E/>SECTORS      {        MOV     CX,>sectors[BP]                 }
    /$C5/$9E/>DTA          {        LDS     BX,>dta[BP]                     }
    /$8A/$86/>DRV          {        MOV     AL,>drv[BP]                     }
    /$CD/$25               {        INT     $25 ; DOS - Absolute Disk Read  }
    /$58                   {        POP     AX  ; Pop copy of flags left    }
                           {        ;               on stack by INT $25     }
    /$58                   {        POP     AX                              }
    /$5B                   {        POP     BX                              }
    /$59                   {        POP     CX                              }
    /$5A                   {        POP     DX                              }
    /$5D                   {        POP     BP                              }
    /$5E                   {        POP     SI                              }
    /$1F                   {        POP     DS                              }
    /$07                   {        POP     ES                              }
  );
end;

procedure WriteSectors( drv, start, sectors : integer; DTA : Addr_T );
  {
  Again we must use inline code for DOS interrupt $26 for the same
    reasons as above.
  }
begin
  drv := drv - 1;
  Inline(
    $06                    {        PUSH    ES ; Be careful,Int $26 destroys }
    /$1E                   {        PUSH    DS ;   the contents of all regs. }
    /$56                   {        PUSH    SI                               }
    /$55                   {        PUSH    BP                               }
    /$52                   {        PUSH    DX                               }
    /$51                   {        PUSH    CX                               }
    /$53                   {        PUSH    BX                               }
    /$50                   {        PUSH    AX                               }
                           {        ;                                        }
    /$8B/$96/>START        {        MOV     DX,[BP+>START]                   }
    /$8B/$8E/>SECTORS      {        MOV     CX,[BP+>SECTORS]                 }
    /$C5/$9E/>DTA          {        LDS     BX,[BP+>DTA]                     }
    /$8A/$86/>DRV          {        MOV     AL,[BP+>DRV]                     }
    /$CD/$26               {        INT     $26  ; DOS - Absolute Disk Write }
    /$58                   {        POP     AX   ; Pop copy of flags left    }
                           {        ;                on stack by int $26     }
    /$58                   {        POP     AX                               }
    /$5B                   {        POP     BX                               }
    /$59                   {        POP     CX                               }
    /$5A                   {        POP     DX                               }
    /$5D                   {        POP     BP                               }
    /$5E                   {        POP     SI                               }
    /$1F                   {        POP     DS                               }
    /$07                   {        POP     ES                               }
  );
end;

function RealToInt( r : real ) : integer;
var
  i : integer;
begin
  if r  > 32768.0 then r := r - 65536.0;
  if r <> 32768.0 then i := trunc( r )
  else                 i := $8000;
  RealToInt := i;
end;

procedure SetDTA( DTA : Addr_T );
  {
  When using the older DOS function requests we must first
    specify the Disk Transfer Address.
  }
var
  Regs : reg_T;
begin
  with Regs do
  begin
    AH := $1A;               { DOS function $1A - Set Disk Transfer Address }
    DS := seg( DTA^ );
    DX := ofs( DTA^ );
    MsDos( Regs );
  end;
end;

procedure GetTable( drv : integer; var DiskTable : DskTblptr );
  {
  This DOS function returns the address of a very useful table of
    information.  In many cases this is the only place I know of
    to get the information reliably.  See the type declaration
    DiskTable_T in the sfmVARS.inc file.
  }
var
  Regs : reg_T;
begin
  with Regs do
  begin
    AH := $32;    { DOS function $32 - Get Address of Device Parameter Table }
    DL := drv;
    MsDos( Regs );
    DiskTable := ptr( DS,BX );
  end;
end;

procedure LoadFAT( DiskTable : DskTblptr; var FAT : Addr_T );
  {
  Using the information in the DiskTable we can now load
    in the File Allocation Table for use in the advanced functions,
    or for loading a subdirectory.
  }
var
  amt, sect : integer;
begin
  release( HeapStart );
  with DiskTable^ do
  begin
    amt := FATSIZE * SECTORSIZE;
    if MemoryAvail < amt then
      AbortProgram( 'LoadFAT :',
                    '',
                    '   Insufficient memory to load FAT.',
                    ''
                  );
    sect := ROOTSECTOR - FATSIZE * NFATS;
    getmem( FAT, amt );
    LoadSectors( DRIVE1+1, sect, FATSIZE, FAT );
  end;
end;

procedure FlushBuffers;
  {
  Make a DOS call to flush all info in the diskette
    buffers so the disks are updated correctly.
    This is done mostly to make sure the FAT and
    directory sectors are written back to disk after
    alterations are made and also to ensure that they
    are then forced to be reloaded from disk later.
  }
var
  Regs         : reg_T;
begin
  Regs.AH := $0D;                   { DOS function $0D - Reset the Disk }
  MsDos( Regs );
end;

procedure SaveFAT( DiskTable : DskTblptr; FAT : Addr_T );
  {
  Writes the FAT back to disk after changes have been made.
    Only done when clearing a disk or specifically told to
    by the Update disk menu option.
  }
var
  i, sect : integer;
begin
  with DiskTable^ do
  begin
    for i := NFATS downto 1 do
    begin
      sect := ROOTSECTOR - FATSIZE * i;
      WriteSectors( DRIVE1+1, sect, FATSIZE, FAT );
    end;
  end;
  FlushBuffers;
end;

function FATentry( Esize : real; clust : integer; FAT : Addr_T ) : integer;
  {
  Returns the entry in the FAT for the cluster specified.
    This can be a little tricky since DOS saves space by
    using only one and a half bytes for each entry whenever
    a disk has fewer than 4098 clusters.
    In order to make it easier for other parts of the program
    we will convert any 1.5 byte entries that correspond to
    special values to a 2 byte format.
    (i.e. $FF0 through $FFF become $FFF0 through $FFFF )
  }
var
  offset, contents : integer;
  address          : Addr_T;
begin
  offset  := RealToInt( Esize * clust );
  address := ptr( seg(FAT^), ofs(FAT^) + offset );
  contents := address^;
  if Esize = 1.5 then
  begin
    if clust mod 2 = 0 then
      contents := contents AND $0FFF
    else
      contents := contents SHR 4;
    if (contents >= $FF0) and (contents <= $FFF) then
      contents := contents OR $F000;
  end;
  FATentry := contents;
end;

procedure WriteFATentry( Esize:real; clust, newvalue:integer; FAT:Addr_T );
  {
  Writes the new value to the cluster entry specified, taking
    into account the entry size for the FAT.
  }
var
  offset  : integer;
  address : Addr_T;
begin
  offset  := RealToInt( Esize * clust );
  address := ptr( seg(FAT^), ofs(FAT^) + offset );
  if Esize = 2 then
    address^ := newvalue
  else
  begin
    if clust mod 2 = 0 then
      address^ := (address^ AND $F000) OR (newvalue AND $0FFF)
    else
      address^ := (address^ AND $000F) OR (newvalue SHL 4);
  end;
end;

function ClustersInChain( w, start : integer; FAT : Addr_T ) : integer;
  {
  Given the starting cluster we can then follow the chain untill
    it terminates.  Having done this we can return the number of
    clusters we found.  This is used mostly for determining how
    many clusters need to be loaded for a specific subdirectory.
  }
var
  Ncl, cl : integer;
begin
  Ncl := 0;
  cl  := start;
  repeat
    Ncl := Ncl + 1;
    cl  := FATentry( FATbytes[w], cl, FAT );
  until (cl = $0000) or ( (cl >= $FFF0) and (cl <= $FFFF) );
  if (cl >= $FFF0) and (cl <= $FFF7) then
    AbortProgram( 'ClustersInChain:',
                  '',
                  '  Invalid cluster number in chain,',
                  '  File Allocation Table may be damaged.' );
  ClustersInChain := Ncl;
end;

function GetCurDrive : integer;
  {
  Simply returns the current drive number (1 = A, 2 = B, etc.).
  }
var
  Regs : reg_T;
begin
  with Regs do
  begin
    AH := $19;                   { DOS function $19 - Look Up Current Disk }
    MsDos( Regs );
    GetCurDrive := AL + 1;
  end;
end;

function GetCurDir( drv : integer; var path : str80 ) : integer;
  {
  Returns the current path name on the drive specified and
    performs the trapping described at the top of this file.
  }
var
  tstr : str80;
  i    : integer;
begin
  {$I-}
  GetDir( drv, tstr );
  {$I+}
  i := Int24result;
  if i = 0 then path := tstr;
  GetCurDir := i;
end;

function ChangeCurDir( var path : str80 ) : integer;
 {
 Changes the current directory to that specified and also
   changes the string input to the standard format used by DOS.
 }
var
  i : integer;
begin
  {$I-}
  chdir( path );
  {$I+}
  i := Int24result;
  if i = 0 then
    i := GetCurDir( GetCurDrive, path );
  ChangeCurDir := i;
end;

function StartClust( w : integer ) : integer;
  {
  Returns the number of the first cluster of the directory
    specified by Path[w].  This is done by using the old DOS
    functions to find the '.' directory entry.
    Since this is an old DOS function call we must first set
    up a File Control Block to perform the disk access.
    Idea sparked by an article written by Ted Mirecki, contributing
    editor for PC Tech Journal.
  }
var
  FCBin  : ExtFCB_T;
  Regs   : reg_T;
  FCBout : Entry_T;
  header : array[1..8] of byte;
  err    : integer;
begin
  err := ChangeCurDir( Path[w] );
  fillchar( FCBin.Name[1], 11, ' ' );
  FCBin.Drive    := Drive[w];
  FCBin.ExtFlag  := $FF;      { Tells DOS this is an extended FCB }
  FCBin.Name[1]  := '.';
  FCBin.FileAttr := Dbit;     { Looking for directory entry }
  SetDTA( addr( header ) );
  with Regs do
  begin
    AH := $11;              { DOS function $11 - Find First Matching File }
    DS := seg( FCBin );
    DX := ofs( FCBin );
    MsDos( Regs );
  end;
  StartClust := FCBout.Cluster;
end;

procedure LoadSubDir( w : integer );
  {
  Performs the necessary setup for loading a subdirectory from
    the disk.  Once we know where it starts and how long it is
    we can load the directory very quickly with a couple of
    calls to LoadSectors.
  }
var
  i, j, Ncl, sect, clust : integer;
  FAT : Addr_T;
begin
  NoSave[w] := false;
  clust := StartClust( w );
  LoadFAT( DiskTable[w], FAT );
  Ncl := ClustersInChain( w, clust, FAT );
  with DiskTable[w]^ do
    MaxEntry[w] := Ncl * (CLUSTERSIZE+1) * (SECTORSIZE div sizeof(Entry_T));
  if MaxEntry[w] > MaxFiles then
  begin
    MaxEntry[w] := MaxFiles;
    NoSave[w] := true;
    MaxFileMessage;
    with DiskTable[w]^ do
      Ncl := (MaxEntry[w]*sizeof(Entry_T)) div ((CLUSTERSIZE+1)*SECTORSIZE);
  end;
  for i := 1 to Ncl do
  begin
    with DiskTable[w]^ do
    begin
      j := ( (i-1) * (SECTORSIZE div sizeof(Entry_T)) * (CLUSTERSIZE+1) ) + 1;
      sect := ( (clust-2) * (CLUSTERSIZE+1) ) + DATASECTOR;
      LoadSectors( Drive[w], sect, CLUSTERSIZE+1, addr(Entry[w][j] ) );
    end;
    if i <> Ncl then clust := FATentry( FATbytes[w], clust, FAT );
  end;
end;

procedure SaveSubDir( w : integer );
  {
  Performs the inverse of LoadSubDir.
  }
var
  i, j, Ncl, sect, clust : integer;
  FAT : Addr_T;
begin
  clust := StartClust( w );
  LoadFAT( DiskTable[w], FAT );
  Ncl := ClustersInChain( w, clust, FAT );
  for i := 1 to Ncl do
  begin
    with DiskTable[w]^ do
    begin
      j := ( (i-1) * (SECTORSIZE div sizeof(Entry_T)) * (CLUSTERSIZE+1) ) + 1;
      sect := ( (clust-2) * (CLUSTERSIZE+1) ) + DATASECTOR;
      WriteSectors( Drive[w], sect, CLUSTERSIZE+1, addr( Entry[w][j] ) );
    end;
    if i <> Ncl then clust := FATentry( FATbytes[w], clust, FAT );
  end;
  FlushBuffers;
end;

procedure LoadRoot( w : integer );
  {
  If it happens to be the root directory we can load even faster.
    We already know where to start and how long it is and better
    yet all the clusters are together.  We can load the entire
    directory in one call to LoadSectors.
  }
var
  nsects : integer;
begin
  with DiskTable[w]^ do
  begin
    if ROOTENTRIES <= MaxFiles then
    begin
      nsects      := DATASECTOR - ROOTSECTOR;
      MaxEntry[w] := ROOTENTRIES;
      NoSave[w]   := false;
    end
    else
    begin
      nsects := (MaxFiles * sizeof(Entry_T)) div SECTORSIZE;
      MaxEntry[w] := MaxFiles;
      NoSave[w] := true;
      MaxFileMessage;
    end;
    LoadSectors( Drive[w], ROOTSECTOR, nsects, addr( Entry[w] ) );
  end;
end;

procedure SaveRoot( w : integer );
  {
  This procedure isn't as bad as you might have thought.
  }
var
  nsects : integer;
begin
  with DiskTable[w]^ do
  begin
    nsects := DATASECTOR - ROOTSECTOR;
    WriteSectors( Drive[w], ROOTSECTOR, nsects, addr( Entry[w] ) );
  end;
  FlushBuffers;
end;

procedure LoadDir( w : integer );
  {
  Determines which of the above load routines need to be called
    and updates the screen.
    It also checks to see that the drive is not a substituted or
    assigned drive since these are more trouble to support than
    they are worth and can be accessed normally anyway.
  }
begin
  GetTable( Drive[w], DiskTable[w] );
  if Drive[w] <> DiskTable[w]^.DRIVE1 + 1 then
  begin
    Wind( 3 );
    clrscr;
    writeln;
    Disp( NATTR, ' Error: ' );
    Disp( HATTR, 'Assigned or substituted drives are not supported.' );
    writeln;
    Disp( HATTR, '        Directory was not loaded' );
    writeln;
    gotoxy( 9, wherey );
    wait;
  end
  else
  begin
    if DiskTable[w]^.MAXCLUSTER <= 4097 then
      FATbytes[w] := 1.5
    else
      FATbytes[w] := 2.0;
    if ord( Path[w][0] ) = 3 then
      LoadRoot( w )
    else
      LoadSubDir( w );
    fillchar( Marked[w], sizeof( MarkedArr_T ), 0 );
    Loaded[w] := true;
    DirSize[w] := TallySizes( w );
    while (Entry[w][MaxEntry[w]].Name[1] = NulChar) and (MaxEntry[w] <> 0) do
      MaxEntry[w] := MaxEntry[w] - 1;
    HomeKey( w );
    Saved[w] := true;
  end;
end;

function FreeDisk( drv : integer ) : real;
  {
  Reads the amount of disk space on the drive.
  }
var
  Regs : reg_T;
begin
  Wind( 3 );
  clrscr;
  writeln;
  Disp( NATTR, ' Reading disk free space...' );
  writeln;
  with Regs do
  begin
    AH := $36;                     { DOS function $36 - Get Disk Free Space }
    DL := drv;
    {$I-}
    MsDos( Regs );
    {$I+}
    if Int24result <> 0 then
      FreeDisk := 0.0
    else
      FreeDisk := 1.0 * AX * BX * CX;
  end;
end;

procedure ReLoadDir( w, menu : integer );
  {
  Forces a full reload on the current path for the window.
    If this can't be found it switches to the root directory and
    tries again.
  }
var
  i : integer;
begin
  Wind( 3 );
  clrscr;
  writeln;
  i := ChangeCurDir( Path[w] );
  if i <> 0 then
    Path[w] := copy( Path[w], 1, 3 );
  i := ChangeCurDir( Path[w] );
  if i <> 0 then
    ErrorMessage( i )
  else
  begin
    DiskFree[w] := FreeDisk( Drive[w] );
    LoadDir( w );
    if menu = 2 then
    begin
      LoadFAT( DiskTable[w], FATptr );
      FATsaved := true;
    end;
  end;
end;

function DeleteFile( fname : str80 ) : integer;
  {
  Removes the specified file from disk.
  }
var
  Regs : reg_T;
  tstr : str80;
  i    : integer;
begin
  tstr := fname + #00;
  with Regs do
  begin
    AH := $41;                         { DOS function $41 - Delete a File }
    DS := seg( tstr[1] );
    DX := ofs( tstr[1] );
    {$I-}
    MsDos( Regs );
    {$I+}
    i := Int24result;
    if i = 0 then
      if (Flags AND $01) <> 0 then i := (AX SHL 8) OR $8000;
  end;
  DeleteFile := i;
end;

function RenameFile( oldname, newname : str80 ) : integer;
  {
  Changes the files name to the new one specified.
    Note that if the paths are different DOS will actually
    delete the file's entry from the old directory and put it
    in the new one as long as both paths are on the same disk.
  }
var
  oldn, newn : str80;
  Regs       : reg_T;
  i          : integer;
begin
  oldn := oldname + #00;
  newn := newname + #00;
  with Regs do
  begin
    AH := $56;                          { DOS function $56 - Rename a File }
    DS := seg( oldn[1] );
    DX := ofs( oldn[1] );
    ES := seg( newn[1] );
    DI := ofs( newn[1] );
    {$I-}
    MsDos( Regs );
    {$I+}
    i := Int24result;
    if i = 0 then
      if (Flags AND $01) <> 0 then i := (AX SHL 8) OR $8000;
  end;
  RenameFile := i;
end;

function ParseFileName( s : str80; address : Addr_T ) : boolean;
  {
  Why write our own file name parser when DOS will do it for us?
    This includes expanding wildcards.
    We do, however, have to save space for an archaic FCB.
  }
var
  FCB  : FCB_T;
  Regs : reg_T;
  tstr : str80;
begin
  tstr := s + #00;
  with Regs do
  begin
    AH := $29;                     { DOS function $29 - Parse a File Name }
    AL := $01;                     { $01 - skip blanks at start. }
    DS := seg( tstr[1] );
    SI := ofs( tstr[1] );
    ES := seg( FCB );
    DI := ofs( FCB );
    MsDos( Regs );
    if AL = $FF then
      ParseFileName := false
    else
    begin
      move( FCB.Name[1], address^, 11 );
      ParseFileName := true;
    end;
  end;
end;

function RemDir( dname : str80 ) : integer;
  {
  Deletes the directory specified from disk.
  }
var
  Regs : reg_T;
  tstr : str80;
  i    : integer;
begin
  tstr := dname + #00;
  with Regs do
  begin
    AH := $3A;                        { DOS function $3A - Remove Directory }
    DS := seg( tstr[1] );
    DX := ofs( tstr[1] );
    {$I-}
    MsDos( Regs );
    {$I+}
    i := Int24result;
    if i = 0 then
      if (Flags AND $01) <> 0 then i := (AX SHL 8) OR $8000;
  end;
  RemDir := i;
end;

procedure CloseFile( var handle : integer );
  {
  Closes the handle and then sets it to zero.
  }
var
  Regs : reg_T;
begin
  Regs.AH := $3E;                  { DOS function $3E - Close a File Handle }
  Regs.BX := handle;
  MsDos( Regs );
  handle := 0;
end;

function OpenFile( fname : str80; var handle : integer ) : integer;
  {
  Opens a file just for reading and returns the handle assigned to it.
  }
var
  tstr : str80;
  Regs : reg_T;
  i    : integer;
begin
  tstr := fname + #00;
  with Regs do
  begin
    Ah := $3D;                             { DOS function $3D - Open a File }
    AL := $00;                             { $00 - just for reading }
    DS := seg( tstr[1] );
    DX := ofs( tstr[1] );
    {$I-}
    MsDos( Regs );
    {$I+}
    i := int24result;
    if i = 0 then
    begin
      if (Flags AND $01) <> 0 then
      begin
        i := (AX SHL 8) OR $8000;
        handle := 0;
      end
      else
        handle := AX;
    end
    else
    begin            { If there was an Int24 error then we make sure }
      handle := AX;  {    the file handle is closed.                 }
      if ((Flags AND $01) = 0) then CloseFile (handle)
      else                          handle := 0;
    end;
  end;
  OpenFile := i;
end;

function CreateFile( fname:str80; attr:integer; var handle:integer ):integer;
  {
  Makes the file specified no matter what, unless there is already
    a file of that name with the read-only attribute set.
    It also returns the new files handle.
  }
var
  Regs : reg_T;
  tstr : str80;
  i    : integer;
begin
  tstr := fname + #00;
  with Regs do
  begin
    AH := $3C;                            { DOS function $3C - Create a File }
    DS := seg( tstr[1] );
    DX := ofs( tstr[1] );
    CL := attr;
    {$I-}
    MsDos( Regs );
    {$I+}
    i := Int24result;
    if (i = 0) then
    begin
      if ((Flags AND $01) <> 0) then
      begin
        i := (AX SHL 8) OR $8000;
        handle := 0;
      end
      else
        handle := AX;
    end
    else
    begin
      handle := AX;
      if ((Flags AND $01) = 0) then CloseFile( handle )
      else                          handle := 0;
    end;
  end;
  CreateFile := i;
end;

procedure ReadFrom( handle : integer; address : Addr_T; amt : integer );
  {
  Read from an open file handle to memory.
  }
var
  Regs : reg_T;
begin
  with Regs do
  begin
    AH := $3F;              { DOS function $3F - Read From a File or Device }
    BX := handle;
    CX := amt;
    DS := seg( address^ );
    DX := ofs( address^ );
    MsDos( Regs );
  end;
end;

function WriteTo( handle:integer; address:Addr_T; amt:integer ) : boolean;
  {
  Write to a handle from memory.
  }
var
  Regs : reg_T;
  i    : integer;
begin
  with Regs do
  begin
    AH := $40;               { DOS function $40 - Write to a File or Device }
    BX := handle;
    CX := amt;
    DS := seg( address^ );
    DX := ofs( address^ );
    {$I-}
    MsDos( Regs );
    {$I+}
    i := Int24result;
    WriteTo := (AX = amt) and (i = 0);
  end;
end;

function ChangeFileTime( fname : str80; newt, newd : integer ) : integer;
  {
  Sets the file's time to the same as specified in the original's
    directory entry.  Used by the copy routine since a mere copy
    does not deserve to have its time changed.
  }
var
  Regs      : reg_T;
  tstr      : str80;
  i, handle : integer;
begin
  i := OpenFile( fname, handle );
  if i = 0 then
  begin
    with Regs do
    begin
      AH := $57;          { DOS function $57 - Get or Set File's Date & Time }
      AL := $01;          { $01 - Set }
      BX := handle;
      CX := newt;
      DX := newd;
      MsDos( Regs );
    end;
    CloseFile( handle );
  end;
  ChangeFileTime := i;
end;

function MakDir( dname : str80 ) : integer;
  {
  Will create the path specified.
  }
var
  Regs : reg_T;
  tstr : str80;
  i    : integer;
begin
  tstr := dname + #00;
  with Regs do
  begin
    AH := $39;                   { DOS function $39 - Create Subdirectory }
    DS := seg( tstr[1] );
    DX := ofs( tstr[1] );
    {$I-}
    MsDos( Regs );
    {$I+}
    i := Int24result;
    if i = 0 then
      if (Flags AND $01) <> 0 then i := (AX SHL 8) OR $8000;
  end;
  MakDir := i;
end;

function ChangeAttr( fname : str80; attr : byte ) : integer;
  {
  Changes the file's attribute byte to that specified.
  }
var
  Regs : reg_T;
  tstr : str80;
  i    : integer;
begin
  tstr := fname + #00;
  with Regs do
  begin
    AH := $43;               { DOS function $43 - Get or Set File Attributes }
    AL := $01;               { $01 - set }
    CX := attr;
    DS := seg( tstr[1] );
    DX := ofs( tstr[1] );
    {$I-}
    MsDos( Regs );
    {$I+}
    i := Int24result;
    if i = 0 then
      if (Flags AND $01) <> 0 then i := (AX SHL 8) OR $8000;
  end;
  ChangeAttr := i;
end;

procedure GoDir( var w : integer; loadw : integer );
  {
  Will read the current entry in the window and then attempt to
    change to that path if it is a directory.
  }
var
  tstr    : str80;
  i, tdrv : integer;
begin
  if CurEntry[w] <> 0 then
  begin
    if (Entry[w][CurEntry[w]].Attr AND Dbit) <> 0 then
    begin
      tstr := ConvertName( Entry[w][CurEntry[w]] );
      Wind( 3 );
      clrscr;
      writeln;
      Disp( NATTR, ' Changing to ' );
      Disp( HATTR, tstr );
      writeln;
      i := ChangeCurDir( Path[w] );
      i := ChangeCurDir( tstr );
      if (i <> 0) then
        ErrorMessage( i )
      else if (tstr = Path[3-loadw]) then
        DupPathMessage
      else
      begin
        Path[loadw] := tstr;
        HelpScreen[loadw] := false;
        tdrv := GetCurDrive;
        if (Drive[3-loadw] = tdrv) and Loaded[3-loadw] then
          DiskFree[loadw] := DiskFree[3-loadw]
        else
          if (Drive[loadw] <> tdrv) or not Loaded[loadw] then
            DiskFree[loadw] := FreeDisk( tdrv );
        Drive[loadw] := tdrv;
        LoadDir( loadw );
        w := loadw;
      end;
    end;
  end;
end;

procedure ClearFAT( drv : integer; disktable : DskTblptr );
  {
  Will just zero out the File Allocation Table and root directory
    on the disk specified.  Much quicker than deleting them all.
    Since we cannot verify the disk without potential compatibility
    problems we will trust that the old FAT has the diskette's
    bad sectors marked appropriately.
  }
var
  FATbytes     : real;
  i, amt, sect : integer;
  buffer       : Addr_T;
begin
  release( HeapStart );
  with disktable^ do
  begin
    if MAXCLUSTER <= 4097 then
      FATbytes := 1.5
    else
      FATbytes := 2.0;
    if FATSIZE < DATASECTOR - ROOTSECTOR then
      amt := (DATASECTOR-ROOTSECTOR)
    else
      amt := FATSIZE;
    amt := amt * SECTORSIZE;
    if MemoryAvail < amt then
      AbortProgram( 'ClearFAT :',
                    '',
                    '   Insufficient memory for temporary buffer.',
                    ''
                  );
    getmem( buffer, amt );
    fillchar( buffer^, amt, 0 );
    WriteSectors( drv, ROOTSECTOR, DATASECTOR-ROOTSECTOR, buffer );

    LoadSectors( drv, ROOTSECTOR - NFATS * FATSIZE, FATSIZE, buffer );
    for i := 2 to MAXCLUSTER-1 do
      if FATentry( FATbytes, i, buffer ) <> $FFF7 then
        WriteFATentry( FATbytes, i, 0, buffer );

    SaveFAT( DiskTable, buffer );    { Buffers are flushed here }
  end;
end;

function ChangeCopyDisk( w:integer; dest:str80; var split:boolean ) : str80;
  {
  Changing disks in the middle of a copy is no small matter.
    Note that the flag Split is set to true if the user Clears
    the disk before continuing.  This happens because the ClearFAT
    procedure must use the same area of memory as the copy buffer
    and we must force a reload.
  }
var
  tstr      : str80;
  err,
  drv       : integer;
  disktable : DskTblptr;
begin
  repeat
    tstr := dest;
    writeln;
    Disp( NATTR, ' Insert new disk in drive ' + copy(dest,1,2) + ' and ' );
    wait;
    writeln;
    if ord( tstr[0] ) <> 3 then
      if ChangeCurDir( tstr ) <> 0 then
        tstr := copy( tstr, 1, 3 );
    err := ChangeCurDir( tstr );
    if err <> 0 then
    begin
      ErrorMessage( err );
      tstr := '';
    end
    else
    begin
      if (w <> 0) then
      begin
        Path[w] := tstr;
        ReloadDir( w, 1 );
      end;
      Wind( 3 );
      clrscr;
      writeln;
      Disp( NATTR, ' Do you wish to CLEAR this disk' );
      if YorN( false ) then
      begin
        tstr  := copy( dest, 1, 3 );
        split := true;
        drv   := GetCurDrive;
        GetTable( drv, disktable );
        ClearFAT( drv, disktable );
      end;
      writeln;
      if (ord( dest[0] ) <> 3) and (ord( tstr[0] ) = 3) then
      begin
        writeln;
        Disp( NATTR, ' Attempt to create ' + dest );
        if not YorN( false ) then
          tstr := copy( dest, 1, 3 )
        else
        begin
          tstr := dest;
          err  := MakDir( tstr );
          if err <> 0 then
          begin
            ErrorMessage( err );
            tstr := '';
          end;
        end;
      end;
    end;
  until tstr <> '';
  if (w <> 0) then Path[w] := tstr;
  if ord( tstr[0] ) <> 3 then tstr := tstr + '\';
  ChangeCopyDisk := tstr;
end;

procedure CopyEntries( w : integer; dest : str80; wflag : boolean );
  {
  This is a very important routine.  It will read as many
    'marked' files into memory as it can fit before writing them
    back out.  This means that unless you load a bunch of resident
    programs first, you should be able to hold an entire floppy
    in memory on a 640K system with room to spare.
    It also allows you to change disks if you happen to fill one up.
  }
const
  MaxBuf  = 100;
  MaxSize = 65520.0;  { Largest buffer possible (almost one segment)  }
                      {   don't go bigger since 65536.0 as an integer }
                      {   converts to 0 (not a good thing).           }
type
  Buffer_T = record
               address : Addr_T;
               size,
               ent     : integer;  { Which entry buffer belongs to }
               more    : boolean;  { Does the file own other buffers? }
             end;
var
  Buffer                       : array[1..MaxBuf] of Buffer_T;
  tstr, tsrc, tdest            : str80;
  i, j, nb, n, tn, err,
  Rhandle, Whandle,
  cnt, Rcnt, Wcnt, Nwrit       : integer;
  MA, left, rsize              : real;
  done, split, tmore, diskfull : boolean;

  procedure ReadToBuffer;          { Local to CopyEntries }
    {
    Read until out of files or buffer full.
    }
  var
    tcnt : integer;
  begin
    nb   := 0;
    tcnt := 0;
    Rcnt := Rcnt + Nwrit;
    repeat
      if Rhandle = 0 then
      begin
        repeat
          i := NextEntry( w, i );
        until Marked[w][i] or (i = 0);
      end;
      if i <> 0 then
      begin
        tstr := ConvertName( Entry[w][i] );
        err  := 0;
        repeat
          clrscr;
          writeln;
          Disp( NATTR, ' Reading from file ' );
          Disp( HATTR, tsrc + tstr );
          Disp( NATTR, ' ('+Cstr(Rcnt+tcnt,0,0)+' of '+Cstr(cnt,0,0)+')' );
          writeln;
          if Rhandle = 0 then
          begin
            err := OpenFile( tsrc + tstr, Rhandle );
            if err <> 0 then
            begin
              ErrorMessage( err );
              done := not TryAgain;
            end
            else
            begin
              tcnt := tcnt + 1;
              left := EntrySize( Entry[w][i] );
            end;
          end;
        until (err = 0) or done;
        if not done then
        begin
          repeat
            MA := MemoryAvail;
            if MA > 0 then
            begin
              if MA > MaxSize then MA := MaxSize;
              rsize := MA;
              if rsize > left then rsize := left;
              left := left - rsize;
              nb := nb + 1;
              with Buffer[nb] do
              begin
                Ent  := i;
                More := (left > 0);
                Size := RealToInt( rsize );
                getmem( Address, Size );
                ReadFrom( Rhandle, Address, Size );
              end;
            end;
          until (left = 0) or (nb = MaxBuf) or (MA <= 0) or done;
          if (left = 0) then
            CloseFile( Rhandle );
        end;
      end;
    until (i = 0) or (nb = MaxBuf) or (MA <= 0) or done;
  end;

  procedure WriteFromBuffer;        { Local to CopyEntries }
    {
    Take those files read and put them all back on disk.
    }
  begin
    n        := 1;
    split    := (Whandle = 0);
    diskfull := false;
    Nwrit    := 0;
    while (n <= nb) and not done and not( diskfull and split) do
    begin
      tn   := n;
      j    := Buffer[n].Ent;
      tstr := ConvertName( Entry[w][j] );
      clrscr;
      writeln;
      Disp( NATTR, ' Writing to file ' );
      Disp( HATTR, tdest + tstr );
      Disp( NATTR, ' ('+Cstr(Wcnt+Nwrit,0,0)+' of '+Cstr(cnt,0,0)+')' );
      writeln;
      err := 0;
      if Whandle = 0 then
      begin
        err   := CreateFile( tdest + tstr, Entry[w][j].Attr, Whandle );
        Nwrit := Nwrit + 1;
      end;
      if err <> 0 then
      begin
        ErrorMessage( err );
        done := not TryAgain;
        if done then
        begin
          done := not Continue;  { This series of prompts allows the user    }
          if not done then       {   to skip the current file and continue   }
          begin                  {   with the next.  A good reason for       }
            writeln;             {   allowing this is when the copy routine  }
            diskfull := true;    {   is attempting to overwrite a file that  }
            split    := true;    {   has its read-only bit set.              }
            i := j;
          end;
        end
        else Wcnt := Wcnt - 1;
      end
      else
      begin
        repeat
          with Buffer[n] do
          begin
            tmore := More;
            diskfull := not WriteTo( Whandle, Address, Size );
          end;
          if not diskfull then
            n := n + 1
          else
          begin
            CloseFile( Whandle );
            err := DeleteFile( tdest + tstr );
            Disp( NATTR, ' Disk full: ' );

            if not (dest[1] in ['A','B']) then
            begin
              Disp(HATTR,'Can''t change disk in drive '+copy(dest,1,2)+'.');
              done := true;
              writeln;                { These prompts allow the user to    }
              gotoxy( 12, wherey );   {   change disks if they are copying }
              wait;                   {   to one of the floppy drives.     }
            end
            else
            begin
              Disp( NATTR, 'Continue with copy' );
              done := not YorN( false );
              writeln;
            end;
            if not done then
            begin
              if (wflag) then
                dest := ChangeCopyDisk( 3-w, dest, split )
              else
                dest := ChangeCopyDisk( 0, dest, split );
            end;

            if not split then
              n := tn
            else
            begin
              if Rhandle <> 0 then CloseFile( Rhandle );
              i := LastEntry( w, j );
              Rcnt := Rcnt - 1;
              Wcnt := Wcnt - 1;
            end;
          end;
        until not tmore or (n > nb) or diskfull;
        if not tmore and (Whandle <> 0) then
        begin
          CloseFile( Whandle );
          err := ChangeFileTime(tdest+tstr,Entry[w][j].Time,Entry[w][j].Date);
          split := false;
        end;
      end;
    end;
    Wcnt := Wcnt + Nwrit;
  end;

begin         { Actual start of CopyEntries }
  Wind( 3 );
  clrscr;
  writeln;
  tsrc := Path[w];
  if ord( tsrc[0] ) <> 3 then tsrc := tsrc + '\';
  tdest := dest;
  if ord( tdest[0] ) <> 3 then tdest := tdest + '\';
  done    := false;
  Rhandle := 0;
  Whandle := 0;
  Nwrit   := 0;
  cnt     := 0;
  i := NextEntry( w, 0 );
  while (i <> 0) do
  begin
    if (Marked[w][i]) then cnt := cnt + 1;
    i := NextEntry( w, i );
  end;
  i := 0;
  if (cnt > 0) then
  begin
    Rcnt    := 1;
    Wcnt    := 1;
    repeat
      release( HeapStart );   { Clear up heap each time }

      ReadToBuffer;           { Read as much as possible }
      WriteFromBuffer;        {   then write it back out }

    until done or (i = 0);
    if Rhandle <> 0 then CloseFile( Rhandle );
    if Whandle <> 0 then CloseFile( Whandle );
  end;
end;

function SortTime( E : Entry_T ) : real;
  {
  Returns a real number that reflects the date and
    time converted to one parameter.
  }
var
  dword, tword : real;
begin
  if E.Date < 0 then dword := E.Date + 65536.0
  else dword := E.Date;
  if E.Time < 0 then tword := E.Time + 65536.0
  else tword := E.Time;
  SortTime := dword * 65536.0 + tword;
end;

function SortAttr( w : integer; E : Entry_T ) : integer;
  {
  Returns a very special sort key that puts files into a logical
    order.  Examples are directories before normal entries and
    deleted files go last.
  }
begin
  if E.Name[1] = DelChar then         SortAttr := 9   { Deleted }
  else if (E.Attr AND $1E) = 0 then   SortAttr := 6   { Normal }
  else if E.Name[1] = '.' then
  begin
    if E.Name[2] = '.' then           SortAttr := 2   { Parent directory }
    else                              SortAttr := 1;  { Current directory }
  end
  else if (E.Attr AND Dbit) <> 0 then SortAttr := 5   { Directory }
  else if (E.Attr AND Sbit) <> 0 then
  begin
    if ord( Path[w][0] ) = 3 then     SortAttr := 0   { System in root }
    else                              SortAttr := 7   { System elsewhere }
  end
  else if (E.Attr AND Hbit) <> 0 then SortAttr := 8   { Hidden }
  else if (E.Attr AND Vbit) <> 0 then SortAttr := 3   { Volume label }
  else                                SortAttr := 10; { just in case }
end;

procedure InsertSort( w, field : integer; forwrd : boolean );
  {
  Performs an insertion sort on the field specified.
    0 = attributes, 1 = name, 2 = extension, 3 = size and 4 = time.
    An insertion sort was chosen because it is a stable sort
    and not such a bad one since we generally won't be sorting
    more than about 150 - 200 files at the very most.
  }
var
  i, j, count : integer;
  tempArray   : array[1..MaxFiles] of real;
  tempR       : real;
  tEntry      : Entry_T;
  exchange    : boolean;
begin
  count := 0;
  Wind( 3 );
  clrscr;
  writeln;
  Disp( NATTR, ' Sorting' );
  textcolor( White );
  if field in [0,3,4] then
  begin
    for i := 1 to MaxEntry[w] do
    begin
      case field of
        0 : tempArray[i] := SortAttr( w, Entry[w][i] );
        3 : tempArray[i] := EntrySize(   Entry[w][i] );
        4 : tempArray[i] := SortTime(    Entry[w][i] );
      end;
    end;
  end;
  for i := 2 to MaxEntry[w] do
  begin
    tEntry := Entry[w][i];
    tempR  := tempArray[i];
    j := i - 1;
    repeat
      count := count + 1;
      case forwrd of
        true : case field of
                 1 :  exchange := ( tEntry.Name < Entry[w][j].Name );
                 2 :  exchange := ( tEntry.Ext  < Entry[w][j].Ext );
                 else exchange := ( tempR       < tempArray[j] );
               end;
        false: case field of
                 1 :  exchange := ( tEntry.Name > Entry[w][j].Name );
                 2 :  exchange := ( tEntry.Ext  > Entry[w][j].Ext );
                 else exchange := ( tempR       > tempArray[j] );
               end;
      end;
      if exchange then
      begin
        Entry[w][j+1]  := Entry[w][j];
        tempArray[j+1] := tempArray[j];
        j := j - 1;
      end;
    until (j = 0) or not exchange;
    Entry[w][j+1]  := tEntry;
    tempArray[j+1] := tempR;
    if count > 1000 then
    begin
      write( '.' );
      count := 0;
    end;
  end;
end;

function CheckMatch( w : integer; s : str80 ) : boolean;
  {
  Does a simple search for an entry that matches S.
  }
var
  match : boolean;
  i     : integer;
begin
  match := false;
  for i := 1 to MaxEntry[w] do
    if ConvertName( Entry[w][i] ) = s then match := true;
  if match then
  begin
    Disp( NATTR, ' Error: ' );
    Disp( HATTR, 'Name already exists, try again.' );
  end;
  CheckMatch := match;
end;

function UnDel( w : integer ) : boolean;
  {
  Takes the best guess approach to recovering deleted files.
    It just starts at the cluster that was specified in the
    old directory entry and searches the FAT for free clusters
    until it finds as many as it needs or runs out of free ones.
    If the first cluster has already been alocated to a file
    then undeletion of the file is not possible and we
    must pass the bad news on to the user.
    I think it is as reliable as Norton's QuickUnerase (tm or whatever).
  }
var
  amt, CLbytes, MaxCL, clust, lastclust : integer;
  tempR, tempDisk                       : real;
  tHeapptr, tFATptr                     : Addr_T;
  error                                 : boolean;
begin
  error := false;
  with DiskTable[w]^ do
  begin
    amt     := FATSIZE * SECTORSIZE;
    CLbytes := (CLUSTERSIZE+1) * SECTORSIZE;
    MaxCL   := MAXCLUSTER;
  end;
  tempR    := EntrySize( Entry[w][CurEntry[w]] );
  tempDisk := DiskFree[w];
  clust    := Entry[w][CurEntry[w]].Cluster;
  if tempR = 0 then
  begin
    if clust <> 0 then error := true
  end
  else
  begin
    if FATentry( FATbytes[w], clust, FATptr ) <> 0 then
      error := true
    else
    begin
      Mark( tHeapptr );
      getmem( tFATptr, amt );
      move( FATptr^, tFATptr^, amt );
      tempR     := tempR - CLbytes;
      tempDisk  := tempDisk - CLbytes;
      lastclust := clust;
      repeat
        clust := clust + 1
      until (FATentry(FATbytes[w],clust,FATptr) = 0) or (clust > MaxCL);

      while (tempR > 0) and (clust <= MaxCL) do
      begin
        WriteFATentry( FATbytes[w], lastclust, clust, FATptr );
        tempR     := tempR - CLbytes;
        tempDisk  := tempDisk - CLbytes;
        lastclust := clust;
        repeat
          clust := clust + 1
        until (FATentry(FATbytes[w],clust,FATptr) = 0) or (clust > MaxCL);
      end;

      if (tempR <= 0) and (tempDisk >= 0) then
      begin
        WriteFATentry( FATbytes[w], lastclust, $FFFF, FATptr );
        DiskFree[w] := tempDisk;
      end
      else
      begin
        error := true;
        move( tFATptr^, FATptr^, amt );
      end;
      Release( tHeapptr );
    end;
  end;
  UnDel := not error;
end;

procedure RemoveDeleted( w : integer );
  {
  Purges all deleted files from directory.  That is, it
    moves them all to the end and then zeros them out so
    they look like they have never been used.
  }
var
  tEntry : Entry_T;
  i, j   : integer;
begin
  for i := 2 to MaxEntry[w] do
  begin
    tEntry := Entry[w][i];
    j := i - 1;
    if tEntry.Name[1] <> DelChar then
    begin
      while ( Entry[w][j].Name[1] = DelChar ) and ( j > 0 ) do
      begin
        Entry[w][j+1]  := Entry[w][j];
        j := j - 1;
      end;
    end;
    Entry[w][j+1]  := tEntry;
  end;
  while Entry[w][MaxEntry[w]].Name[1] = DelChar do
  begin
    fillchar( Entry[w][MaxEntry[w]], sizeof( Entry_T ), 0 );
    MaxEntry[w] := MaxEntry[w] - 1;
  end;
end;

function SysTime : integer;
  {
  Returns the current system clock time in the format
    used in directory entries.
    Time is put into the following word format for a file's
    directory entry
      [hhhhhmmmmmmsssss]
  }
var
  Regs    : reg_T;
begin
  with Regs do
  begin
    AH := $2C;                             { DOS function $2C - Get the Time }
    MsDos( Regs );
    SysTime := (CH SHL 11) OR (CL SHL 5) OR (DH SHR 1);
  end;
end;

function SysDate : integer;
  {
  Returns the current system date in the format
    required for disk files.
    Date field is put into the following word format
    for a file's directory entry
         [yyyyyyymmmmddddd]
  }
var
  Regs : reg_T;
begin
  with Regs do
  begin
    AH := $2A;                            { DOS function $2A - Get the Date }
    MsDos( Regs );
    SysDate := ((CX - 1980) SHL 9) OR (DH SHL 5) OR DL;
  end;
end;