[Back to FILES SWAG index] [Back to Main SWAG index] [Original]
{$A+,B-,D-,E-,F-,G+,I-,L-,N+,O-,P-,Q-,R-,S-,T-,V+,X+,Y-}
Unit UFile95;
{A lot of declarations in this unit belong in other units, such as
Move32 (UMemory); TBoolean/TByte/TChar - UGlobal. Unit was modified to
be standalone.}
(* **************************************************************
TO COMPILE UFILE95 YOU NEED TO COMPILE THE UMULTI UNIT
WHOSE SOURCE CAN BE FOUND AT THE END OF THIS FILE
**************************************************************
PLEASE PUBLISH THIS IN THE SWAG
************************************************************** *)
Interface {Nothing!}
Const Author = 'UFile95 v6.2, 05-Feb-97, 1995-1997.'+
'Written by Gil Shapira.'+
'Bug or other reports to: gilsh@ibm.net';
{Nicer looks ;-) }
Type TBoolean = Boolean;
TPointer = Pointer;
TChar = Char;
TByte = Byte;
TWord = Word;
THalf = ShortInt;
TInt = Integer;
TDouble = LongInt;
Type THandle = TWord;
TError = TWord;
{File modes}
Const fmRead = 0;
fmWrite = 1;
fmReadWrite = 2;
fmDenyAll = 16;
fmDenyWrite = 32;
fmDenyRead = 48;
fmDenyNone = 64;
{File seek origins}
Const foStart = 0;
foCurrent = 1;
foEnd = 2;
{File attributes}
Const faReadOnly = 1;
faHidden = 2;
faSystem = 4;
faVolume = 8;
faDirectory = 16;
faArchive = 32;
faAnyFile = 63;
{File parts}
Const fcExtension = 1;
fcFileName = 2;
fcDirectory = 4;
fcWildcards = 8;
{Search record for DOS interrupt 21h}
Type PSearch = ^TSearch;
TSearch = Record
SearchDrive: TChar;
SearchTemplate: Array [1..11] Of TByte;
SearchAttr: TByte;
DirEntry: TWord;
StartCluster: TWord;
Reserved: Array [1..4] Of TByte;
Attr: TByte;
Time: TWord;
Date: TWord;
Size: TDouble;
Name: Array [1..13] Of TChar;
End;
{Search record for Windows '95 interrupt 21h}
Type PSearch95 = ^TSearch95;
TSearch95 = Record
Handle: TWord;
Attr: TDouble;
Creation: Comp;
LastAccess: Comp;
LastModify: Comp;
SizeHi: TDouble;
SizeLo: TDouble;
Reserved: Array [1..8] Of TByte;
Name: Array [0..259] Of TChar;
ShortName: Array [0..13] Of TChar;
End;
Var LockLevel,
FileMode,
FindAttr,
CopyAttr,
DeleteAttr,
CreateAttr: TWord;
flError: TError;
isError,
Using95: TBoolean;
{Creates a new directory; only ONE directory at a time.}
Procedure CreateDir(PathName: PChar);
{Removes an existing directory; should not be current directory}
Procedure RemoveDir(PathName: PChar);
{Makes the specified directory the current directory,
without changing the current drive}
Procedure ChangeDir(PathName: PChar);
{Returns the current directory path}
Procedure CurrentDir(CurDir: PChar);
{Makes the specified directory the current directory,
and changes the current drive if needed}
Procedure ChangePath(PathName: PChar);
{Creates a virtual drive for the path specified; should be
used ONLY under Windows '95}
Procedure Subst(Drive: TChar; PathName: PChar);
{Returns the path for the virtual drive specified; should be
used ONLY under Windows '95}
Procedure QuerySubst(Drive: TChar; Var PathName: PChar);
{Terminates the virtual drive association; should be
used ONLY under Windows '95}
Procedure DeleteSubst(Drive: TChar);
{Creates a new file}
Function Create(FileName: PChar): THandle;
{Replaces an existing file, erasing its content}
Function Replace(FileName: PChar): THandle;
{Opens an existing file}
Function Open(FileName: PChar): THandle;
{Duplicated a file handle}
Function Duplicate(Handle: THandle): THandle;
{Changes the position in the file; use the file origin
constants for Origin}
Function Seek(Handle: THandle; Position: TDouble; Origin: TByte): TDouble;
{Returns the current position in the file}
Function FilePos(Handle: THandle): TDouble;
{Returns the size of the file}
Function FileSize(Handle: THandle): TDouble;
{Splits the path to directory, filename (8), and extension (4)}
Function FSplit(Path,Dir,Name,Ext: PChar): TByte;
{Expands a short/long filename}
Procedure FExpand(Path,Result: PChar);
{Return the file attributes}
Function GetFileAttr(FileName: PChar): TByte;
{Changes the file attributes}
Procedure SetFileAttr(FileName: PChar; Attr: TByte);
{Returns a file's true name}
Procedure TrueName(FileName,TrueFileName: PChar);
{Returns a file's short name (8.3); should be used only
under Windows '95}
Procedure ShortName(FileName,ShortFileName: PChar);
{Generates a short name (8.3) for a long file name; should
be used only under Windows '95}
Procedure LongToShort(FileName,ShortFileName: PChar);
{Deletes a file}
Procedure Delete(FileName: PChar);
{Renames a file; can move a file between directories on the same drive}
Procedure Rename(FileName,NewName: PChar);
{Deletes any bytes from the position in the file to its end}
Procedure Truncate(Handle: THandle);
{Flushes any file buffers}
Procedure Commit(Handle: THandle);
{Closes a file, writing any changes}
Procedure Close(Handle: THandle);
{Reads a block of bytes to a buffer}
Function BlockRead(Handle: THandle; Var Buff; Count: TWord): TWord;
{Writes a block of bytes to a file}
Function BlockWrite(Handle: THandle; Var Buff; Count: TWord): TWord;
{Locks a drive to allow direct drive accesses}
Procedure LockDrive(Drive: TChar);
{Unlocks a drive to disallow direct drive accesses}
Procedure UnlockDrive(Drive: TChar);
{Changes the current drive}
Procedure ChangeDrive(Drive: TChar);
{Returns the current drive}
Function CurrentDrive: TChar;
{Disables a drive, rendering it completely inaccessible until reenabled}
Procedure DisableDrive(Drive: TChar);
{Enables a previously disabled drive}
Procedure EnableDrive(Drive: TChar);
{Turns a FLOPPY drive's led on}
Procedure TurnLedOn(Drive: TChar);
{Turns a FLOPPY drive's led off}
Procedure TurnLedOff(Drive: TChar);
{Returns a drive's information}
Function DriveInformation(Drive: TChar; Var DriveType: TByte; Volume: TPointer; Var Serial,TotalSpace,FreeSpace,
ClusterSize: TDouble): TBoolean;
{Returns the amount of bytes free on a drive}
Function DiskFree(Drive: TChar): TDouble;
{Returns the total amount of bytes used on a drive}
Function DiskSize(Drive: TChar): TDouble;
{Resets a drive, flushing its buffers}
Procedure ResetDrive(Drive: TChar);
{Quits from the calling program}
Procedure Halt(ErrorLevel: TByte);
{Runs another program; READ NOTE IN THE CODE ITSELF!}
Procedure Exec(Prog,Params: PChar);
{Sets the data transfer area; not to be changed normally}
Procedure SetDTA(Address: TPointer);
{Returns the data transfer area's address}
Function GetDTA: TPointer;
{Finds the first file; able to process long filenames; should be
used ONLY under Windows '95}
Procedure FindFirst95(FileSpec: PChar; Attr: TByte; Var Search: TSearch95);
{Returns the next file; should be
used ONLY under Windows '95}
Procedure FindNext95(Var Search: TSearch95);
{Closes a file search; MUST be done at the end of a search; should be
used ONLY under Windows '95}
Procedure FindClose95(Var Search: TSearch95);
{Finds the first file}
Procedure FindFirst(FileSpec: PChar; Attr: TWord; Var Search: TSearch);
{Finds the next file}
Procedure FindNext(Var Search: TSearch);
{Moves 4 bytes in each move; much faster; (80386 processors
and faster ONLY)}
Procedure Move32(Var Source,Target; Len: TWord);
Implementation uses UMulti,Strings; {This is of course the Strings unit
you got with your Borland/Turbo Pascal.
The UMulti unit is at the end of this
file. Compile if first.}
Var DTA: TPointer;
ParameterBlock: TPointer;
Block: Array [1..40] Of TByte;
Procedure Move32(Var Source,Target; Len: TWord); Assembler;
Asm
Push Ds
Mov Cx,Len
Jcxz @End
Lds Si,Source
Les Di,Target
Cld
ShR Cx,1
Jnc @Sw
MovSb
@Sw:
Shr Cx,1
Jnc @Sd
MovSw
@Sd:
Db 66h,0F3h,0A5h {Rep MovSd}
@End:
Pop Ds
End;
Procedure CreateDir(PathName: PChar); Assembler;
Asm
Push Ds
Mov Ax,7139h
Cmp Using95,True
Je @Use95
Mov Ax,3900h
@Use95:
Lds Dx,PathName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure RemoveDir(PathName: PChar); Assembler;
Asm
Push Ds
Mov Ax,713Ah
Cmp Using95,True
Je @Use95
Mov Ax,3A00h
@Use95:
Lds Dx,PathName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure ChangeDir(PathName: PChar); Assembler;
Asm
Push Ds
Mov Ax,713Bh
Cmp Using95,True
Je @Use95
Mov Ax,3B00h
@Use95:
Lds Dx,PathName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure CurrentDir(CurDir: PChar); Assembler;
Asm
Push Ds
Mov Ax,7147h
Cmp Using95,True
Je @Use95
Mov Ax,4700h
@Use95:
Xor Dl,Dl
Lds Si,CurDir
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure ChangePath(PathName: PChar); Assembler;
Asm
Push Ds
Lds Si,PathName
LodSw
Cmp Ah,':'
Jne @NoDrive
Cmp Al,'A'
Jb @NoUpper
Cmp Al,'Z'
Ja @NoUpper
Sub Al,20h
@NoUpper:
Xor Ah,Ah
Push Ax
Call ChangeDrive
@NoDrive:
Lds Si,PathName
LodSw
Cmp Ah,':'
Jne @Added
Dec Si
Dec Si
@Added:
Mov Ax,Ds
Mov Es,Ax
Pop Ds
Push Es
Push Si
Call ChangeDir
@End:
End;
Procedure Subst(Drive: TChar; PathName: PChar); Assembler;
Asm
Push Ds
Cmp Using95,True
Jne @End
Mov Ax,71AAh
Xor Bh,Bh
Mov Bl,Drive
Sub Bl,64
Lds Dx,PathName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure QuerySubst(Drive: TChar; Var PathName: PChar); Assembler;
Asm
Push Ds
Cmp Using95,True
Jne @End
Mov Ax,71AAh
Mov Bh,02h
Mov Bl,Drive
Sub Bl,64
Lds Dx,PathName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure DeleteSubst(Drive: TChar); Assembler;
Asm
Cmp Using95,True
Jne @End
Mov Ax,71AAh
Mov Bh,01h
Mov Bl,Drive
Sub Bl,64
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Function Create(FileName: PChar): THandle; Assembler;
Asm
Push Ds
Mov Ax,716Ch
Cmp Using95,True
Je @Use95
Mov Ax,6C00h
@Use95:
Mov Bl,Byte Ptr FileMode
Mov Bh,32
Mov Cx,Word Ptr CreateAttr
Mov Dx,0000000000010000b
Lds Si,FileName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Function Replace(FileName: PChar): THandle; Assembler;
Asm
Push Ds
Mov Ax,716Ch
Cmp Using95,True
Je @Use95
Mov Ax,6C00h
@Use95:
Mov Bl,Byte Ptr FileMode
Mov Bh,32
Mov Cx,32
Mov Dx,0000000000010010b
Lds Si,FileName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Function Open(FileName: PChar): THandle; Assembler;
Asm
Push Ds
Mov Ax,716Ch
Cmp Using95,True
Je @Use95
Mov Ax,6C00h
@Use95:
Mov Bl,Byte Ptr FileMode
Mov Bh,32
Mov Cx,32
Mov Dx,0000000000000001b
Lds Si,FileName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Function Duplicate(Handle: THandle): THandle; Assembler;
Asm
Mov Ah,45h
Mov Bx,Word Ptr Handle
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Function Seek(Handle: THandle; Position: TDouble; Origin: TByte): TDouble; Assembler;
Asm
Mov Ah,42h
Mov Al,Byte Ptr Origin
Mov Bx,Word Ptr Handle
Mov Cx,Word Ptr Position
Mov Dx,Word Ptr Position+2
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Function FilePos(Handle: THandle): TDouble; Assembler;
Asm
Mov Ah,42h
Mov Al,foCurrent
Mov Bx,Word Ptr Handle
Xor Cx,Cx
Xor Dx,Dx
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
Xor Dx,Dx
@End:
End;
Function FileSize(Handle: THandle): TDouble; Assembler;
Var FPos: TDouble;
Asm
Push Word Ptr Handle
Call FilePos
Cmp Word Ptr flError,0
Jne @Error
Mov Word Ptr FPos,Dx
Mov Word Ptr FPos+2,Ax
Mov Ah,42h
Mov Al,foEnd
Mov Bx,Word Ptr Handle
Xor Cx,Cx
Xor Dx,Dx
Int 21h
Jc @Error
Pusha
Mov Ah,42h
Mov Al,foStart
Mov Bx,Word Ptr Handle
Mov Cx,Word Ptr FPos
Mov Dx,Word Ptr FPos+2
Int 21h
Jnc @End
@Error:
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
Xor Dx,Dx
@End:
Popa
End;
Function FSplit(Path,Dir,Name,Ext: PChar): TByte;
{Based on the Borland Pascal run-time library and EnhancedDos (Andrew Eigus);
Modified for long filename support by Gil Shapira}
Var DirLen,NameLen,Flags: TWord;
NamePtr,ExtPtr: PChar;
Begin
NamePtr:=StrRScan(Path,'\');
If (NamePtr=Nil) Then NamePtr:=StrRScan(Path,':');
If (NamePtr=Nil) Then NamePtr:=Path Else Inc(NamePtr);
ExtPtr:=StrScan(NamePtr,'.');
If (ExtPtr=Nil) Then ExtPtr:=StrEnd(NamePtr);
DirLen:=NamePtr-Path;
NameLen:=ExtPtr-NamePtr;
Flags:=0;
If (StrScan(NamePtr,'?')<>Nil) Or (StrScan(NamePtr,'*')<>Nil) Then Flags:=fcWildcards;
If (DirLen<>0) Then Flags:=Flags Or fcDirectory;
If (NameLen<>0) Then Flags:=Flags Or fcFilename;
If (ExtPtr[0]<>#0) Then Flags:=Flags Or fcExtension;
If (Dir<>Nil) Then StrLCopy(Dir,Path,DirLen);
If (Name<>Nil) Then StrLCopy(Name,NamePtr,NameLen);
If (Ext<>Nil) Then StrLCopy(Ext,ExtPtr,4);
FSplit:=Flags;
End;
Procedure FExpand(Path,Result: PChar); Assembler;
Asm
Push Ds
Cld
Lds Si,Path
Push Ds
Push Si
Call StrLen
Mov Cx,Ax
Add Cx,Si
Les Di,Result
LodSw
Cmp Si,Cx
Ja @1
Cmp Ah,':' {If DriveLetter not present...}
Jne @1 {use default drive}
Cmp Al,'a' {If DriveLetter below 'a'...}
Jb @2
Cmp Al,'z' {or above 'z'...}
Ja @2 {jump...}
Sub Al,20h {or else make it uppercase...}
Jmp @2 {and jump}
@1: {Get current drive}
Dec Si
Dec Si
Mov Ah,19h
Int 21h
Add Al,'A'
Mov Ah,':'
@2:
StoSw {Write drive letter}
Cmp Si,Cx {If source is only drive letter...}
Je @21 {jump...}
Cmp Byte Ptr [Si],'\' {if it includes path...}
Je @3 {jump}
@21: {Get current directory}
Sub Al,'A'-1
Mov Dl,Al
Mov Al,'\'
StoSb
Push Si
Push Ds
Mov Ax,7147h
Mov Si,Di
Push Es
Pop Ds
Int 21h
Pop Ds
Pop Si
Jc @3
Cmp Byte Ptr Es:[Di],0
Je @3
Push Cx
Mov Cx,-1
Xor Al,Al
RepNe ScaSb
Dec Di
Mov Al,'\'
StoSb
Pop Cx
@3:
Sub Cx,Si
Rep MovSb
Xor Al,Al
StoSb
Lds Si,Result
Mov Di,Si
Push Di
@4:
LodSb
Or Al,Al
Je @6
Cmp Al,'\'
Je @6
Cmp Al,'a'
Jb @5
Cmp Al,'z'
Ja @5
@5:
StoSb
Jmp @4
@6:
Cmp Word Ptr [Di-2],'.\'
Jne @7
Dec Di
Dec Di
Jmp @9
@7:
Cmp Word Ptr [Di-2],'..'
Jne @9
Cmp Byte Ptr [Di-3],'\'
Jne @9
Sub Di,3
Cmp Byte Ptr [Di-1],':'
Je @9
@8:
Dec Di
Cmp Byte Ptr [Di],'\'
Jne @8
@9:
Or Al,Al
Jne @5
Cmp Byte Ptr [Di-1],':'
Jne @10
Mov Al,'\'
StoSb
@10:
Xor Al,Al
StoSb
Pop Di
Pop Ds
End;
Function GetFileAttr(FileName: PChar): TByte; Assembler;
Asm
Push Ds
Mov Ax,7143h
Cmp Using95,True
Je @Use95
Mov Ax,4300h
@Use95:
Xor Bl,Bl
Lds Dx,FileName
Int 21h
Pop Ds
Jnc @OK
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
Jmp @End
@OK:
Mov Ax,Cx
@End:
End;
Procedure SetFileAttr(FileName: PChar; Attr: TByte); Assembler;
Asm
Push Ds
Mov Ax,7143h
Cmp Using95,True
Je @Use95
Mov Ax,4301h
@Use95:
Mov Bl,01h
Mov Cl,Byte Ptr Attr
Xor Ch,Ch
Lds Dx,FileName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure TrueName(FileName,TrueFileName: PChar); Assembler;
Asm
Push Ds
Mov Ax,7160h
Cmp Using95,True
Je @Use95
Mov Ax,6000h
@Use95:
Mov Cx,0002h
Lds Si,FileName
Les Di,TrueFileName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure ShortName(FileName,ShortFileName: PChar); Assembler;
Asm
Push Ds
Cmp Using95,True
Jne @End
Mov Ax,7160h
Mov Cx,0001h
Lds Si,FileName
Les Di,ShortFileName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure LongToShort(FileName,ShortFileName: PChar); Assembler;
Asm
Cld
Push Ds
Mov Ax,71A8h
Cmp Using95,True
Jne @End
Lds Si,FileName
Les Di,ShortFileName
Xor Dx,Dx
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure Delete(FileName: PChar); Assembler;
Asm
Push Ds
Mov Ax,7141h
Cmp Using95,True
Je @Use95
Mov Ax,4100h
@Use95:
Lds Dx,FileName
Mov Si,0001h
Mov Cl,Byte Ptr DeleteAttr
Xor Ch,Ch
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure Rename(FileName,NewName: PChar); Assembler;
Asm
Push Ds
Mov Ax,7156h
Cmp Using95,True
Je @Use95
Mov Ax,5600h
@Use95:
Lds Dx,FileName
Les Di,NewName
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure Close(Handle: THandle); Assembler;
Asm
Mov Ah,3Eh
Mov Bx,Word Ptr Handle
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure Truncate(Handle: THandle); Assembler;
Asm
Push Ds
Mov Ah,40h
Mov Bx,Word Ptr Handle
Xor Cx,Cx
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure Commit(Handle: THandle); Assembler;
Asm
Mov Ah,68h
Mov Bx,Word Ptr Handle
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Function BlockRead(Handle: THandle; Var Buff; Count: TWord): TWord; Assembler;
Asm
Push Ds
Mov Ah,3Fh
Mov Bx,Word Ptr Handle
Mov Cx,Count
Jcxz @End
Lds Dx,Buff
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Function BlockWrite(Handle: THandle; Var Buff; Count: TWord): TWord; Assembler;
Asm
Push Ds
Mov Ah,40h
Mov Bx,Word Ptr Handle
Mov Cx,Count
Jcxz @End
Lds Dx,Buff
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Procedure LockDrive(Drive: TChar); Assembler;
Asm
Mov Ax,440Dh
Mov Cx,084Ah
Mov Bl,Drive
Sub Bl,'@'
Mov Bh,Byte Ptr LockLevel
Mov Dx,0000000000000001b
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure UnlockDrive(Drive: TChar); Assembler;
Asm
Mov Ax,440Dh
Mov Cx,086Ah
Mov Bl,Drive
Sub Bl,'@'
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure ChangeDrive(Drive: TChar); Assembler;
Asm
Mov Ah,0Eh
Mov Dl,Byte Ptr Drive
Sub Dl,'A'
Int 21h
End;
Function CurrentDrive: TChar; Assembler;
Asm
Mov Ah,19h
Int 21h
Add Al,'A'
End;
Procedure EnableDrive(Drive: TChar); Assembler;
Asm
Mov Ax,5F07h
Mov Dl,Byte Ptr Drive
Sub Dl,'A'
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Procedure DisableDrive(Drive: TChar); Assembler;
Asm
Mov Ax,5F08h
Mov Dl,Byte Ptr Drive
Sub Dl,'A'
Int 21h
Jnc @End
Mov flError,Ax
Mov isError,True
Xor Ax,Ax
@End:
End;
Procedure FindFirst95(FileSpec: PChar; Attr: TByte; Var Search: TSearch95); Assembler;
Asm
Push Ds
Mov Ax,714Eh
Xor Si,Si
Xor Ch,Ch
Mov Cl,Attr
Lds Dx,FileSpec
Les Di,Search
Inc Di
Inc Di
Int 21h
Dec Di
Dec Di
StoSw
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure FindNext95(Var Search: TSearch95); Assembler;
Asm
Push Ds
Lds Si,Search
LodSw
Mov Bx,Ax
Mov Ax,714Fh
Xor Si,Si
Les Di,Search
Inc Di
Inc Di
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure FindClose95(Var Search: TSearch95); Assembler;
Asm
Push Ds
Lds Si,Search
LodSw
Mov Bx,Ax
Mov Ax,71A1h
Int 21h
Pop Ds
Jnc @End
Mov flError,Ax
Mov isError,True
@End:
End;
Procedure FindFirst(FileSpec: PChar; Attr: TWord; Var Search: TSearch); Assembler;
Asm
Push Ds
Mov Ah,4Eh
Mov Cx,Attr
Lds Dx,FileSpec
Int 21h
Jnc @Transfer
Mov flError,Ax
Mov isError,True
Jmp @End
@Transfer:
Les Si,DTA
Push Es
Push Si
Les Si,Search
Push Es
Push Si
Push 43
Call Move32
@End:
Pop Ds
End;
Procedure FindNext(Var Search: TSearch); Assembler;
Asm
Push Ds
Les Si,Search
Push Es
Push Si
Les Si,DTA
Push Es
Push Si
Push 43
Call Move32
Mov Ah,4Fh
Int 21h
Jnc @Transfer
Mov flError,Ax
Mov isError,True
Jmp @End
@Transfer:
Les Si,DTA
Push Es
Push Si
Les Si,Search
Push Es
Push Si
Push 43
Call Move32
@End:
Pop Ds
End;
Procedure Halt(ErrorLevel: TByte); Assembler;
Asm
Mov Ah,4Ch
Mov Al,Byte Ptr ErrorLevel
Int 21h
End;
Procedure Exec(Prog,Params: PChar); Assembler;
{For some reason, you need to add a space before the Params
string. For example:
To run:
C:\COMMAND.COM /C DIR C:\
The variables need to be like this:
Prog:='C:\COMMAND.COM';
Params:=' /C DIR C:\'; {Notice the space before the /C}
Var ShortFileName: PChar;
Asm
Push Ds
{Building ParameterBlock}
Cld
Les Di,ParameterBlock
Lds Si,Params
Inc Di
Inc Di
Mov Ax,Si
StoSw
Mov Ax,Ds
StoSw
Db 86h,0D0h,90h,86h,0C2h,86h,0C9h
Pop Ds
Push Ds
Cmp Using95,True
Je @Use95
Lds Dx,Prog
Jmp @OK
@Use95:
{Getting short filename}
Mov Ax,7160h
Mov Cx,0001h
Lds Si,Prog
Les Di,ShortFileName
Int 21h
Lds Dx,ShortFileName
Jc @End
{Executing}
@OK:
Les Bx,ParameterBlock
Mov Ah,4Bh
Xor Al,Al
Int 21h
@End:
Pop Ds
End;
Procedure SetDTA(Address: Pointer); Assembler;
Asm
Push Ds
Mov Ah,1Ah
Lds Dx,Address
Int 21h
Pop Ds
End;
Function GetDTA: Pointer; Assembler;
Asm
Mov Ah,2Fh
Int 21h
Mov Dx,Es
Mov Ax,Bx
End;
Function DriveInformation(Drive: TChar; Var DriveType: TByte; Volume: TPointer; Var Serial,TotalSpace,FreeSpace,
ClusterSize: TDouble): TBoolean; Assembler;
Asm
Push Ds
Mov Ax,440Dh
Mov Bl,Drive
Sub Bl,64
Mov Cx,0860h
Lds Dx,ParameterBlock
Int 21h
Mov Al,1
Jnc @Continue
Xor Al,Al
Jmp @Error
@Continue:
Mov Si,Dx
Inc Si
LodSb
Les Di,DriveType
StoSb
Pop Ds
Push Ds
Les Di,ParameterBlock
Xor Ax,Ax
StoSw
Lds Dx,ParameterBlock
Mov Ax,440Dh
Mov Bl,Drive
Sub Bl,64
Mov Cx,0866h
Int 21h
Mov Si,Dx
Inc Si
Inc Si
Les Di,Serial
Dw 0A566h
Les Di,Volume
Dw 0A566h
Dw 0A566h
MovSw
MovSb
Mov Ah,36h
Mov Dl,Drive
Sub Dl,64
Int 21h
Push Dx
Push Ax
Mul Cx
Les Di,ClusterSize
StoSw
Mov Ax,Dx
StoSw
Pop Ax
Push Ax
Mul Cx
Mul Bx
Les Di,FreeSpace
StoSw
Mov Ax,Dx
StoSw
Pop Ax
Pop Dx
Mov Bx,Dx
Mul Cx
Mul Bx
Les Di,TotalSpace
StoSw
Mov Ax,Dx
StoSw
Mov Al,1
@Error:
Pop Ds
End;
Function DiskFree(Drive: TChar): TDouble; Assembler;
Asm
Mov Ah,36h
Mov Dl,Drive
Sub Dl,64
Int 21h
Cmp Ax,0FFFFh
Je @Error
Mul Cx
Mul Bx
Jmp @End
@Error:
Mov Dx,Ax
@End:
End;
Function DiskSize(Drive: TChar): TDouble; Assembler;
Asm
Mov Ah,36h
Mov Dl,Drive
Sub Dl,64
Int 21h
Cmp Ax,0FFFFh
Je @Error
Mul Cx
Mul Dx
Jmp @End
@Error:
Mov Dx,Ax
@End:
End;
Procedure ResetDrive(Drive: TChar); Assembler;
Asm
Mov Ax,710Dh
Cmp Using95,True
Je @Use95
Mov Ax,0D00h
@Use95:
Mov Cx,01h
Xor Dh,Dh
Mov Dl,Drive
Sub Dx,65
Int 21h
End;
Procedure TurnLedOn(Drive: TChar); Assembler;
Asm
Mov Al,Drive
Sub Al,65
Mov Cl,Al
Add Cl,4
Mov Ah,1
ShL Ah,Cl
Add Al,Ah
Add Al,12
Mov Dx,03F2h
Out Dx,Al
End;
Procedure TurnLedOff(Drive: TChar); Assembler;
Asm
Mov Al,Drive
Sub Al,53
Mov Dx,03F2h
Out Dx,Al
End;
Begin
CreateAttr:=faArchive;
FindAttr:=faArchive Or faReadOnly;
CopyAttr:=faArchive Or faReadOnly;
DeleteAttr:=faArchive;
FileMode:=fmReadWrite;
FillChar(Block,40,$00);
ParameterBlock:=@Block;
LockLevel:=0;
Using95:=(Task.OS=osWin95);
DTA:=GetDTA;
End.
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
(* UMulti - multitasker support unit *)
(* Compile this first *)
Unit UMulti;
Interface uses UGlobal;
Const Tasker: Array [0..10] Of String[9] = ('DOS','Windows ''95','Windows','OS/2','DesqView','TopView','DoubleDos',
'NetWare','MultiLink','CSwitch','EuroDOS');
Const osDOS = 0;
osWin95 = 1;
osWindows = 2;
osOS2 = 3;
osDesqView = 4;
osTopView = 5;
osDoubleDos = 6;
osNetWare = 7;
osMultiLink = 8;
osCSwitch = 9;
osEuroDOS = 10;
Type TaskRec = Record
OS: Word;
Version: Word;
Delay: Word;
End;
Const Task: TaskRec = (OS: 0;
Version: 0;
Delay: 100);
{ Call GiveTimeSlice to release CPU cycles to the multitasker. }
{ Polling could be use as procedure to be used inside ReadKey procedures
to read the clock, update the screen, and release CPU cycles. Polling is
at startup the same as GiveTimeSlice }
Var GiveTimeSlice,
Polling: TProc;
{ AssignProcs is called automatically by the startup procedure Init }
Procedure AssignProcs;
{ ReleaseTime is a macro procedure which takes only 7 bytes, and releases
DOS, Windows, Windows '95, and OS/2 timeslices }
Procedure ReleaseTime; Inline($CD/$28/$B8/$80/$16/$CD/$2F);
Implementation
{$F+}
Procedure NetWare_GTS; Assembler;
Asm
Mov Bx,000Ah
Int 7Ah
End;
Procedure DoubleDOS_GTS; Assembler;
Asm
Mov Ax,0EE02h
Int 21h
End;
Procedure Windows_Win95_OS2_GTS; Assembler;
Asm
Mov Ax,1680h
Int 2Fh
End;
Procedure DesqView_TopView_GTS; Assembler;
Asm
Mov Ax,1000h
Int 15h
End;
Procedure DOS_GTS; Assembler;
Asm
Int 28h
End;
Procedure MultiLink_GTS; Assembler;
Asm
Mov Ah,02h
Int 7Fh
End;
Procedure CSwitch_GTS; Assembler;
Asm
Mov Ah,01h
Int 62h
End;
Procedure EuroDOS_GTS; Assembler;
Asm
Mov Ah,89h
Xor Cx,Cx
Int 21h
End;
{$F-}
Procedure AssignProcs;
Begin
Case Task.OS Of
osDos: GiveTimeSlice:=DOS_GTS;
osWin95: GiveTimeSlice:=Windows_Win95_OS2_GTS;
osWindows: GiveTimeSlice:=Windows_Win95_OS2_GTS;
osOS2: GiveTimeSlice:=Windows_Win95_OS2_GTS;
osDesqView: GiveTimeSlice:=DesqView_TopView_GTS;
osTopView: GiveTimeSlice:=DesqView_TopView_GTS;
osDoubleDos: GiveTimeSlice:=DoubleDOS_GTS;
osNetWare: GiveTimeSlice:=NetWare_GTS;
osMultiLink: GiveTimeSlice:=MultiLink_GTS;
osCSwitch: GiveTimeSlice:=CSwitch_GTS;
osEuroDOS: GiveTimeSlice:=EuroDOS_GTS;
End;
End;
Procedure Init; Assembler;
Asm
Mov Task.OS,00h
Mov Task.Version,00h
Mov Ah,87h
Xor Al,Al
Int 21h
Cmp Al,0
Jne @EuroDOS
Mov Ah,30h
Mov Al,01h
Int 21h
Cmp Al,14h
Je @OS2
Mov Ax,160Ah
Int 2Fh
Cmp Ax,00h
Je @Windows
Mov Ax,1022h
Mov Bx,0000h
Int 15h
Cmp Bx,00h
Jne @DesqView
Mov Ah,2Bh
Mov Al,01h
Mov Cx,4445h
Mov Dx,5351h
Int 21h
Cmp Al,0FFh
Jne @TopView
Mov Ax,0E400h
Int 21h
Cmp Al,00h
Jne @DoubleDos
Mov Ax,7A00h
Int 2Fh
Cmp Al,0FFh
Je @NetWare
Jmp @End
@Windows:
Cmp Bh,04h
Jne @Win3
Mov Task.OS,01h
Jmp @Windows_OK
@Win3:
Mov Task.OS,02h
@Windows_OK:
Mov Task.Version,Bx
Jmp @End
@OS2:
Mov Task.OS,03h
Mov Bh,Ah
Xor Ah,Ah
Mov Cl,0Ah
Div Cl
Mov Ah,Bh
XChg Ah,Al
Mov Task.Version,Ax
Jmp @End
@DesqView:
Mov Task.OS,04h
Jmp @End
@TopView:
Mov Task.OS,05h
Jmp @End
@DoubleDos:
Mov Task.OS,06h
Jmp @End
@NetWare:
Mov Task.OS,07h
Jmp @End
@MultiLink:
Mov Task.OS,08h
Jmp @End
@CSwitch:
Mov Task.OS,09h
Jmp @End
@EuroDOS:
Mov Task.OS,10h
@End:
Call AssignProcs
End;
Begin
Init;
Polling:=GiveTimeSlice;
End.
[Back to FILES SWAG index] [Back to Main SWAG index] [Original]