Unit GSOB_Dsk;
{------------------------------------------------------------------------------
Disk File Handler
GSOB_DSK Copyright (c) Richard F. Griffin
01 April 1993
102 Molded Stone Pl
Warner Robins, GA 31088
-------------------------------------------------------------
This unit handles the objects for all untyped disk file I/O.
File Sharing Routines are derived from:
Lock4 - DOS 3 Record Locking for Turbo Pascal 4.0
version 1.0 11/16/87
by Richard Sadowsky, CompuServe 74017,1670
Released to the public domain
File Handle Extension Routine is derived from:
EXTEND.PAS - Increase File Handle Count to 255
Version 3.2 September 25, 1988
by Scott Bussinger, Compuserve 72247,2671
Released to the public domain
File Flushing Routine is derived from:
FLUSH.PAS - Replacement for Turbo Pascal Flush Procedure
Version 1.2 January 9, 1986
by Randy Forgaard, CompuServe 70307,521
Released to the public domain
changes:
15 Jul 93 - Fixes problem with the flush after write in Write
and AddToFile methods. Flush supposedly removes locks,
so record locking was reestablished. This caused
access denied problems on Novell Lans. Removed the
relocking routine.
22 Jul 93 - Fixes problem with detecting a read-only file. In the
Assign method, FileMode is set to ReadOnly if the read
only file attribute is set in the file. If a network
file, SharedDenyWrite is also set.
07 Aug 93 - Added statement to clear IOResult before attempting to
make an IO call. If IOResult is non-zero when a
command is issued, it is possible the routine will
get that result code instead of the valid result.
-------------------------------------------------------------------------------}
{$O-,V-} {Cannot be Overlayed!!}
interface
uses
GSOB_Var,
{$IFDEF WINDOWS}
WinDOS,
WinProcs,
Objects,
Strings;
{$ELSE}
DOS,
GSOB_Obj;
{$ENDIF}
const
{File Modes (including sharing)}
dfReadOnly = 0;
dfWriteOnly = 1;
dfReadWrite = 2;
dfSharedDenyAll = 16;
dfSharedDenyWrite = 32;
dfSharedDenyRead = 48;
dfSharedDenyNone = 64;
dfDirtyRead : longint = $40000000;
type
{$IFNDEF WINDOWS}
TFileRec = FileRec;
TRegisters = Registers;
TSearchRec = SearchRec;
TDateTime = DateTime;
{$ENDIF}
dfFlushStatus = (NeverFlush,WriteFlush,AppendFlush,UnLockFlush);
GSP_DiskFile = ^GSO_DiskFile;
GSO_DiskFile = Object(TObject)
dfFileHndl : word;
dfFileErr : word; {I/O error code}
dfFileExst : boolean; {True if file exists}
dfFileName : string[80];
dfFilePosn : longint;
dfFileRSiz : word;
dfFileShrd : boolean;
dfFileMode : byte;
dfFileType : file;
dfFileInfo : TSearchRec;
dfFileFlsh : dfFlushStatus;
dfGoodRec : word;
dfLockRec : Boolean;
dfLockPos : Longint;
dfLockLth : Longint;
Constructor Init(Fname : string; Fmode : byte);
destructor Done; virtual;
Procedure AddtoFile(var dat; len, StepBack : word); virtual;
Procedure Assign(FName : string); virtual;
Procedure Close; virtual;
Procedure Erase; virtual;
Procedure Error(Code, Info : integer); virtual;
Function FileSize : longint; virtual;
Procedure Flush; virtual;
Function LockFile : Word; virtual;
Function LockRec(FilePosition,FileLength : LongInt) : Word; virtual;
Procedure Read(blk : longint; var dat; len : word); virtual;
Procedure Rename(Fname : string); virtual;
Procedure Reset(len : word); virtual;
Procedure ReWrite(len : word); virtual;
Procedure SetFlushCondition(Condition : dfFlushStatus); virtual;
Procedure Truncate(loc : longint); virtual;
Function UnLock : Word; virtual;
Procedure Write(blk : longint; var dat; len : word); virtual;
end;
Var
FindFileInfo : TSearchRec;
Procedure GS_ClearLocks;
Function GS_ExtendHandles(HndlCount : byte) : boolean;
Procedure GS_FileDateTime(var f: file; var Year,Month,Day,Hour,Min,Sec: Word);
Function GS_FileExists(Fname : string) : boolean;
Function GS_FileIsOpen(fnam : string): boolean;
Function GS_Flush(Hndl : word): Word;
Function GS_LockFile(Hndl : word; FilePosition,FileLength : LongInt) : Word;
Function GS_RetryFile(Wait,Retry : Word) : Word;
Function GS_UnLockFile(Hndl : word; FilePosition,FileLength : LongInt) : Word;
Function GS_ShareAllowed : boolean;
Procedure GS_ShareAuto(tf : boolean);
Function GS_AutoShare : boolean;
Function GS_Exclusive : boolean;
Procedure GS_SetExclusive(tf : boolean);
{------------------------------------------------------------------------------
IMPLEMENTATION SECTION
------------------------------------------------------------------------------}
implementation
const
RetriesChgd : boolean = false;
AutomaticShare: boolean = false;
ShareChecked : boolean = false;
ShareAllowed : boolean = false;
UseExclusive : boolean = true;
HandlesExtnd : boolean = false;
var
istrue : boolean;
ExitSave : pointer;
ObjtLog : TCollection;
NewHandleTable: array[0..255] of byte; { New table for handles }
OldHandleTable: pointer; { Pointer to original table }
OldNumHandles : byte; { Original number of handles }
{------------------------------------------------------------------------------
Internal Functions
------------------------------------------------------------------------------}
function HiLong(Long : LongInt) : Word;
{ This inline directive is similar to Turbo's Hi() function, except }
{ it returns the high word of a LongInt }
Inline(
$5A/ {pop dx ; low word of long}
$58); {pop ax ; hi word of long}
function LowLong(Long : LongInt) : Word;
{ This inline directive is similar to Turbo's Lo() function, except }
{ it returns the Low word of a LongInt }
Inline(
$5A/ {pop dx ; low word of long}
$58/ {pop ax ; hi word of long}
$89/$D0); {mov ax,dx ; return lo word as function result in Ax}
function Temp_File : string;
var
h, mn, s, hund : Word;
hundchk : Word;
LS : string;
begin
GetTime(h,mn,s,hund); {Call TP 5.5 procedure for current time}
hundchk := hund;
repeat
GetTime(h,mn,s,hund); {Call TP 5.5 procedure for current time}
until hundchk <> hund; {Ensures always a unique time}
LS := 'GS'+chr((mn div 10)+65)+chr((mn mod 10)+65);
LS := LS+chr((s div 10)+65)+chr((s mod 10)+65);
LS := LS+chr((hund div 10)+65)+chr((hund mod 10)+65);
LS := LS+'.$$$';
Temp_File := LS; {Return the unique field}
end;
{------------------------------------------------------------------------------
Global Routines
------------------------------------------------------------------------------}
Function FileNameIs(hdl: word): string ;
var
i : integer;
rslt : word;
optr : GSP_DiskFile;
begin
if ObjtLog.Count > 0 then
begin
FileNameIs := '';
for i := 0 to ObjtLog.Count-1 do
begin
optr := ObjtLog.Items^[i];
if optr^.dfFileHndl = hdl then
FileNameIs := optr^.dfFileName;
end;
end
else FileNameIs := '';
end;
Procedure GS_ClearLocks;
var
i : integer;
rslt : word;
optr : GSP_DiskFile;
begin
if ObjtLog.Count > 0 then
begin
for i := 0 to ObjtLog.Count-1 do
begin
optr := ObjtLog.Items^[i];
with optr^ do
if dfLockRec then
rslt := GS_UnLockFile(dfFileHndl,dfLockPos,dfLockLth);
end;
end;
end;
Function GS_Exclusive : boolean;
begin
if not ShareChecked then
UseExclusive := not GS_ShareAllowed;
GS_Exclusive := UseExclusive;
end;
Function GS_ExtendHandles(HndlCount : byte) : boolean;
var
reg : TRegisters;
hcnt : word;
pfxcnt : pointer;
pfxtbl : pointer;
begin
GS_ExtendHandles := false;
if HandlesExtnd then exit;
if HndlCount <= 20 then exit;
if lo(DosVersion) = 2 then exit; { Can't handle DOS Ver 2}
{$IFDEF WINDOWS}
hcnt := SetHandleCount(HndlCount);
{$ELSE}
{$IFDEF DPMI}
Reg.BX := HndlCount;
Reg.AH := $67;
Reg.Ds := 0;
Reg.Es := 0;
MsDos(Reg);
{$ELSE}
fillchar(NewHandleTable,sizeof(NewHandleTable),$FF);
{ Initialize new handles as unused }
pfxcnt := Ptr(PrefixSeg, $0032);
pfxtbl := Ptr(PrefixSeg, $0034);
OldNumHandles := byte(pfxcnt^); { Get old table length }
OldHandleTable := pointer(pfxtbl^);
{ Save address of old table }
byte(pfxcnt^) := HndlCount; { Set new table length }
pointer(Pfxtbl^) := Addr(NewHandleTable);
{ Point to new handle table }
move(OldHandleTable^,NewHandleTable,OldNumHandles);
{ Copy the current handle table to the new handle table }
{$ENDIF}
{$ENDIF}
HandlesExtnd := true;
GS_ExtendHandles := true;
end;
Procedure GS_FileDateTime(var f: file; var Year,Month,Day,Hour,Min,Sec: Word);
var
dt : TDateTime;
ftime : longint;
begin
GetFTime(f,ftime); { Get creation time }
UnpackTime(ftime,dt);
Year := dt.Year;
Month := dt.Month;
Day := dt.Day;
Hour := dt.Hour;
Min := dt.Min;
Sec := dt.Sec;
end;
{$IFDEF WINDOWS}
Function GS_FileExists(Fname : string) : boolean;
var
NulEnd : array[0..80] of byte;
pNulEnd : PChar;
begin
if (FName <> '') then
begin
pNulEnd := @NulEnd;
pNulEnd := StrPCopy(pNulEnd, FName);
FindFirst(pNulEnd, $27, FindFileInfo);
if DosError = 0 then
GS_FileExists := true
else
begin
GS_FileExists := false;
FillChar(FindFileInfo,SizeOf(FindFileInfo),#0);
end;
end
else
begin
GS_FileExists := false;
FillChar(FindFileInfo,SizeOf(FindFileInfo),#0);
end;
end;
{$ELSE}
Function GS_FileExists(Fname : string) : boolean;
begin
if (FName <> '') then
begin
FindFirst(FName, $27, FindFileInfo);
if DosError = 0 then
GS_FileExists := true
else
begin
GS_FileExists := false;
FillChar(FindFileInfo,SizeOf(FindFileInfo),#0);
end;
end
else
begin
GS_FileExists := false;
FillChar(FindFileInfo,SizeOf(FindFileInfo),#0);
end;
end;
{$ENDIF}
Function GS_FileIsOpen(fnam : string): boolean;
var
fmode : byte;
frslt : word;
filx : file;
fopn : boolean;
begin
fmode := FileMode;
FileMode := 18;
System.Assign(filx, fnam);
frslt := IOResult; {Clear IOResult}
{$I-} System.Reset(filx); {$I+}
frslt := IOResult;
if frslt = 0 then System.Close(filx);
if frslt = 2 then frslt := 0;
fopn := frslt <> 0;
FileMode := fmode;
GS_FileIsOpen := fopn;
end;
Function GS_Flush(Hndl : word): Word;
var
Reg: TRegisters;
begin
Reg.AH := $45; {DOS function to duplicate a file handle}
Reg.BX := Hndl;
Reg.Ds := 0;
Reg.Es := 0;
MsDos(Reg);
if Odd(Reg.Flags) then {Check if carry flag is set}
begin
GS_Flush := 1;
exit;
end;
Reg.BX := Reg.AX; {Put new file handle into BX}
Reg.AH := $3E; {Dos function to close a file handle}
Reg.Ds := 0;
Reg.Es := 0;
MsDos(Reg);
if Odd(Reg.Flags) then {Check if carry flag is set}
begin
GS_Flush := 2;
exit;
end;
GS_Flush := 0;
end;
Function GS_LockFile(Hndl : word; FilePosition,FileLength : LongInt) : Word;
var
Reg : TRegisters;
H,L : Word;
rsl : word;
begin
if UseExclusive then
begin
if ShareAllowed then GS_LockFile := 0
else GS_LockFile := 1;
exit;
end;
with Reg do begin
Ax := $5C00; {DOS call 5Ch}
Bx := Hndl;
Cx := HiLong(FilePosition);
Dx := LowLong(FilePosition);
Si := HiLong(FileLength);
Di := LowLong(FileLength);
Ds := 0;
Es := 0;
MsDos(Reg);
if Odd(Reg.Flags) then {Check if carry flag is set}
rsl := Ax
else
rsl := 0;
end;
GS_LockFile := rsl;
end;
Function GS_RetryFile(Wait,Retry : Word) : Word;
var
Reg : TRegisters;
begin
if UseExclusive then
begin
if ShareAllowed then GS_RetryFile := 0
else GS_RetryFile := 1;
exit;
end;
with Reg do begin
Ax := $440B;
Cx := Wait; {Num of 1/18 sec loops between retries (default = 1)}
Dx := Retry; {Num of times to retry (default = 3)}
Ds := 0;
Es := 0;
MsDos(Reg);
if Odd(Reg.Flags) then {Check if carry flag is set}
GS_RetryFile := Ax
else
begin
GS_RetryFile := 0;
RetriesChgd := true;
end;
end;
end;
Function GS_UnLockFile(Hndl : word; FilePosition,FileLength : LongInt) : Word;
var
Reg : TRegisters;
H,L : Word;
rsl : word;
begin
if UseExclusive then
begin
if ShareAllowed then GS_UnlockFile := 0
else GS_UnLockFile := 1;
exit;
end;
with Reg do begin
Ax := $5C01; {DOS call 5Ch, subfunction 1}
Bx := Hndl;
Cx := HiLong(FilePosition);
Dx := LowLong(FilePosition);
Si := HiLong(FileLength);
Di := LowLong(FileLength);
Ds := 0;
Es := 0;
MsDos(Reg);
if Odd(Reg.Flags) then {Check if carry flag is set}
rsl := Ax
else
rsl := 0;
end;
GS_UnLockFile := rsl;
end;
Function GS_ShareAllowed : boolean;
begin
if not ShareChecked then
begin
UseExclusive := false;
ShareAllowed := true;
ShareChecked := true;
AutomaticShare := true;
end;
GS_ShareAllowed := ShareAllowed;
end;
Procedure GS_SetExclusive(tf : boolean);
begin
if GS_Exclusive then
if tf then exit;
if not ShareAllowed then
if not tf then exit;
UseExclusive := tf;
end;
Procedure GS_ShareAuto(tf : boolean);
begin
if GS_ShareAllowed then AutomaticShare := tf
else AutomaticShare := false;
end;
Function GS_AutoShare : boolean;
begin
GS_AutoShare := AutomaticShare;
end;
{------------------------------------------------------------------------------
GSO_DiskFile
------------------------------------------------------------------------------}
Constructor GSO_DiskFile.Init(Fname : string; Fmode : byte);
var
attr : word;
begin
dfFileMode := Fmode;
if GS_Exclusive then dfFileMode := dfFileMode and $07;
dfFileShrd := dfFileMode > 8;
Assign(FName);
dfFileHndl := 0;
dfFileRSiz := 0;
dfLockRec := false;
dfFileFlsh := NeverFlush;
ObjtLog.Insert(@Self);
end;
destructor GSO_DiskFile.Done;
begin
GSO_DiskFile.Close;
ObjtLog.Delete(@Self);
end;
Procedure GSO_DiskFile.AddToFile(var dat; len, StepBack : word);
var
LRslt : word;
FLen : Longint;
begin
FLen := FileSize - StepBack;
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) System.Seek(dFFileType, FLen); (*$I+*)
dfFileErr := IOResult;
IF dfFileErr = 0 THEN {If seek ok, read the record}
begin
(*$I-*) BlockWrite(dfFileType, dat, len, dfGoodRec); (*$I+*)
dfFileErr := IOResult;
dfFilePosn := (FLen+len);
end;
if dfFileErr <> 0 then Error(dfFileErr,dskAddToFileError);
if (dfFileFlsh = WriteFlush) or
(dfFileFlsh = AppendFlush) then Flush;
end;
Procedure GSO_DiskFile.Assign(FName : string);
begin
dfFileName := FName;
dfFileExst := GS_FileExists(FName);
dfFileInfo := FindFileInfo;
if not dfFileExst then FillChar(dfFileInfo,SizeOf(dfFileInfo),#0);
{07/22/93 fix}
if (dfFileInfo.Attr and $01) > 0 then
if dfFileShrd then dfFileMode := dfReadOnly+dfSharedDenyWrite
else dfFileMode := dfReadOnly;
System.Assign(dfFileType, FName);
DosError := 0;
dfFilePosn := 0;
end;
Procedure GSO_DiskFile.Close;
var
rsl : word;
begin
if TFileRec(dfFileType).Mode = fmClosed then exit;
if dfLockRec then rsl := UnLock;
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) System.Close(dfFileType); {$I+}
dfFileErr := IOResult;
if dfFileErr <> 0 then Error(dfFileErr,dskCloseError);
end;
Procedure GSO_DiskFile.Erase;
begin
if dfFileShrd then Error(dosAccessDenied,dskEraseError)
else
begin
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) System.Erase(dfFileType); {$I+}
dfFileErr := IOResult;
if dfFileErr <> 0 then Error(dfFileErr,dskEraseError);
end;
end;
Procedure GSO_DiskFile.Error(Code, Info : integer);
begin
RunError(Code);
end;
Function GSO_DiskFile.FileSize : longint;
begin
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) FileSize := System.FileSize(dfFileType); {$I+}
dfFileErr := IOResult;
if dfFileErr <> 0 then Error(dfFileErr,dskFileSizeError);
end;
Procedure GSO_DiskFile.Flush;
begin
dfFileErr := GS_Flush(dfFileHndl);
if dfFileErr <> 0 then Error(dfFileErr,dskFlushError);
end;
Function GSO_DiskFile.LockFile : Word;
begin
LockFile := LockRec(0,FileSize*dfFileRSiz);
end;
Function GSO_DiskFile.LockRec(FilePosition,FileLength: LongInt): Word;
begin
if not dfFileShrd then dfFileErr := 1
else
if dfLockRec then
begin
if (FilePosition = dfLockPos) and (FileLength = dfLockLth) then
dfFileErr := 0
else
dfFileErr := dosLockViolated;
end
else
begin
dfLockPos := FilePosition;
dfLockLth := FileLength;
dfFileErr := GS_LockFile(dfFileHndl,dfLockPos,dfLockLth);
dfLockRec := dfFileErr = 0;
end;
LockRec := dfFileErr;
end;
Procedure GSO_DiskFile.Read(blk : longint; var dat; len : word);
begin
if blk = -1 then blk := dfFilePosn;
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) System.Seek(dFFileType, blk); (*$I+*)
dfFileErr := IOResult;
IF dfFileErr = 0 THEN {If seek ok, read the record}
BEGIN
(*$I-*) BlockRead(dfFileType, dat, len, dfGoodRec); (*$I+*)
dfFileErr := IOResult;
dfFilePosn := (blk+len);
end;
if dfFileErr <> 0 then Error(dfFileErr,dskReadError);
end;
Procedure GSO_DiskFile.Rename(Fname : string);
begin
if dfFileShrd then Error(dosAccessDenied,dskRenameError)
else
begin
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) System.Rename(dfFileType, FName); {$I+}
dfFileName := Fname;
dfFileErr := IOResult;
if dfFileErr <> 0 then Error(dfFileErr,dskRenameError);
end;
end;
Procedure GSO_DiskFile.Reset(len : word);
var
Handle : word absolute dfFileType;
OldMode : byte;
begin
OldMode := FileMode;
FileMode := dfFileMode;
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) System.Reset(dfFileType, len); (*$I+*)
dfFileErr := IOResult;
if dfFileErr <> 0 then Error(dfFileErr,dskResetError);
dfFilePosn := 0;
dfFileRSiz := len;
dfFileHndl := Handle;
FileMode := OldMode;
if dfFileShrd then
if LockRec(0,1) = 1 then
dfFileShrd := false
else dfFileErr := Unlock;
end;
Procedure GSO_DiskFile.ReWrite(len : word);
var
Handle : word absolute dfFileType;
OldMode : byte;
begin
OldMode := FileMode;
FileMode := dfFileMode;
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) System.ReWrite(dfFileType, len); (*$I+*)
dfFileErr := IOResult;
if dfFileErr <> 0 then Error(dfFileErr,dskRewriteError);
dfFilePosn := 0;
dfFileRSiz := len;
dfFileHndl := Handle;
FileMode := OldMode;
if dfFileShrd then
if LockRec(0,1) = 1 then
dfFileShrd := false
else dfFileErr := Unlock;
end;
Procedure GSO_DiskFile.SetFlushCondition(Condition : dfFlushStatus);
begin
dfFileFlsh := Condition;
end;
Procedure GSO_DiskFile.Truncate(loc : longint);
begin
if dfFileShrd then Error(dosAccessDenied,dskTruncateError)
else
begin
if loc = -1 then loc := dfFilePosn;
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) Seek(dfFileType, loc); (*$I+*)
dfFileErr := IOResult;
if dfFileErr = 0 then
begin
(*$I-*) System.Truncate(dfFileType); {$I+}
dfFileErr := IOResult;
end;
if dfFileErr <> 0 then Error(dfFileErr,dskTruncateError)
end;
end;
Function GSO_DiskFile.UnLock : Word;
var
ulokok : word;
begin
UnLock := 0;
if not dfLockRec then exit;
ulokok := GS_UnLockFile(dfFileHndl,dfLockPos,dfLockLth);
dfLockRec := ulokok <> 0;
UnLock := ulokok;
if dfFileFlsh = UnLockFlush then Flush;
end;
Procedure GSO_DiskFile.Write(blk : longint; var dat; len : word);
var
LRslt : word;
begin
if blk = -1 then blk := dfFilePosn;
dfFileErr := IOResult; {Clear IOResult}
(*$I-*) System.Seek(dFFileType, blk); (*$I+*)
dfFileErr := IOResult;
IF dfFileErr = 0 THEN {If seek ok, read the record}
begin
(*$I-*) BlockWrite(dfFileType, dat, len, dfGoodRec); (*$I+*)
dfFileErr := IOResult;
dfFilePosn := (blk+len);
end;
if dfFileErr <> 0 then Error(dfFileErr,dskWriteError);
if dfFileFlsh = WriteFlush then Flush;
end;
{------------------------------------------------------------------------------
Setup and Exit Routines
------------------------------------------------------------------------------}
{$F+}
procedure ExitHandler;
var
rslt : word;
begin
GS_ClearLocks;
if RetriesChgd then
begin
UseExclusive := false;
rslt := GS_RetryFile(1,3);
end;
ExitProc := ExitSave;
end;
{$F-}
begin
ObjtLog.Init(32,16);
ExitSave := ExitProc;
ExitProc := @ExitHandler;
end.
{-----------------------------------------------------------------------------}
END
