home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programming
/
powerprogramming1994.iso
/
progtool
/
turbopas
/
sfmsrc.arc
/
SFMDOS.INC
< prev
next >
Wrap
Text File
|
1987-11-15
|
46KB
|
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;