Category : Pascal Source Code
Archive   : GSDB21.ZIP
Filename : GS_FILEH.PAS
{
Changes
5 Jan 91 - Corrected GS_FileWrite error is processing memo files
greater than 64K. Changed variable MovLth from type
word to type longint.
}
interface
uses
Dos,
GS_Strng,
GS_Error;
var
BRCmd,
BWCmd,
IOAsk,
IORed,
IOWri,
IOPhy : word;
Procedure GS_FileAssign(var dF : file; Fname : string; BufSize : longint);
Procedure GS_FileClose(var dF : file);
Procedure GS_FileErase(var dF : file);
Function GS_FileExists(var dF : file; Fname : string) : boolean;
Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
var RtnRslt : word);
Procedure GS_FileRename(var dF : file; FName : string);
Procedure GS_FileReset(var dF : file; len : longint);
Procedure GS_FileRewrite(var dF : file; len : longint);
Function GS_FileSize(var dF : file) : longint;
Procedure GS_FileTruncate(var dF : file; loc : longint);
Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
var RtnRslt : word);
implementation
type
BufferPointer = ^BufferArray;
BufferArray = array[0..32767] of char;
BufrRec = record
Size : word; {Size of buffer}
CntByt : word; {Bytes stores in buffer}
Posn : longint; {Beginning byte of file in buffer}
FPosn : longint; {Last byte read + 1 in buffer}
BufPtr : BufferPointer;
end;
var
Bufr : BufrRec;
dbfErr : integer;
Blok,
TPosS,
TPosE : longint;
StrFil : string[80];
istrue : boolean;
Function InRam(var dF : file; blk, len : longint; rf : boolean) : boolean;
var
dFa : FileRec absolute dF;
RorW : string[4];
begin
istrue := false;
inc(IOAsk);
if rf then RorW := 'Read' else RorW := 'Writ';
move(dFa.UserData, Bufr, sizeof(Bufr));
if blk > -1 then TPosS := dFa.RecSize * blk
else TPosS := Bufr.FPosn;
Blok := TPosS div dFa.RecSize;
Bufr.FPosn := TPosS + dFa.RecSize * len;
if Bufr.CntByt > 0 then
begin
TPosS := TPosS - Bufr.Posn;
if (TPosS >= 0) and (TPosS < Bufr.CntByt) then
begin
TPosE := (TPosS + dFa.RecSize * len) - 1;
if TPosE <= Bufr.CntByt then istrue := true;
end;
end;
if not istrue then inc(IOPhy);
if rf then inc(IORed) else inc(IOWri);
InRam := istrue;
end;
Procedure GS_FileAssign(var dF : file; Fname : string; BufSize : longint);
var
dFa : FileRec absolute dF;
begin
Assign(df, FName);
Bufr.Posn := 0;
Bufr.FPosn := 0;
Bufr.CntByt := 0;
Bufr.Size := BufSize;
GetMem(Bufr.BufPtr, BufSize);
move(Bufr, dFa.UserData, sizeof(Bufr));
end;
Procedure GS_FileClose(var dF : file);
var
dFa : FileRec absolute dF;
begin
Close(df);
move(dFa.UserData, Bufr, sizeof(Bufr));
FreeMem(Bufr.BufPtr, Bufr.Size);
end;
Procedure GS_FileErase(var dF : file);
begin
Erase(df);
end;
Function GS_FileExists(var dF : file; Fname : string) : boolean;
begin
if (FName <> '') then
begin
{$I-}
Assign(dF, FName);
Reset(dF);
Close(dF);
{$I+}
GS_FileExists := (IOResult = 0);
end else GS_FileExists := false;
end;
Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
var RtnRslt : word);
var
dFa : FileRec absolute dF;
Result,
LthHld : word;
StrFil : string[80];
begin
if InRam(dF, blk, len, true) then
begin
move(Bufr.BufPtr^[TPosS],dat,dFa.RecSize * len);
move(Bufr, dFa.UserData, sizeof(Bufr));
RtnRslt := len;
exit;
end;
dbfErr := 0;
begin
(*$I-*) Seek(dF, Blok); (*$I+*)
dbfErr := IOResult;
end;
IF dbfErr = 0 THEN {If seek ok, read the record}
BEGIN
inc(BRCmd);
LthHld := dFa.RecSize;
dFa.RecSize := 1;
(*$I-*)
BlockRead(dF, Bufr.BufPtr^, Bufr.Size, Result);
(*$I+*)
RtnRslt := Result div LthHld;
if RtnRslt > len then RtnRslt := len;
dbfErr := IOResult;
if dbfErr = 0 then
begin
move(Bufr.BufPtr^,dat,LthHld * len);
Bufr.CntByt := Result;
Bufr.Posn := Blok * LthHld;
Bufr.FPosn := (Blok * LthHld)+(LthHld * len);
move(Bufr, dFa.UserData, sizeof(Bufr));
end;
dFa.RecSize := LthHld;
end;
if dbfErr <> 0 then
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
end;
Procedure GS_FileRename(var dF : file; Fname : string);
begin
Rename(df, FName);
end;
Procedure GS_FileReset(var dF : file; len : longint);
var
dFa : FileRec absolute dF;
i : integer;
StrFil : string[80];
begin
(*$I-*) Reset(dF, len); (*$I+*)
dbfErr := IOResult;
if dbfErr <> 0 then
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
end;
Procedure GS_FileRewrite(var dF : file; len : longint);
var
dFa : FileRec absolute dF;
i : integer;
StrFil : string[80];
begin
(*$I-*) Rewrite(dF, len); (*$I+*)
dbfErr := IOResult;
if dbfErr <> 0 then
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
end;
Function GS_FileSize(var dF : file) : longint;
begin
GS_FileSize := FileSize(df);
end;
Procedure GS_FileTruncate(var dF : file; loc : longint);
var
dFa : FileRec absolute dF;
begin
dbfErr := 0;
if loc <> -1 then
begin
(*$I-*) Seek(dF, loc); (*$I+*)
dbfErr := IOResult;
end;
IF dbfErr <> 0 THEN
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
Truncate(df);
end;
Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
var RtnRslt : word);
var
dFa : FileRec absolute dF;
i : integer;
Result : word;
MovLth : longint;
StrFil : string[80];
begin
if InRam(dF, blk, len, false) then
move(dat,Bufr.BufPtr^[TPosS],dFa.RecSize * len)
else
begin
MovLth := (dFa.RecSize * len) + (dFa.RecSize * Blok);
if Bufr.Size >= MovLth then
begin
move(dat,Bufr.BufPtr^[dFa.RecSize * Blok],dFa.RecSize * len);
Bufr.CntByt := MovLth;
Bufr.Posn := 0;
Bufr.FPosn := MovLth;
end;
end;
move(Bufr, dFa.UserData, sizeof(Bufr));
dbfErr := 0;
begin
(*$I-*) Seek(dF, Blok); (*$I+*)
dbfErr := IOResult;
end;
IF dbfErr = 0 THEN {If seek ok, read the record}
BEGIN
inc(BWCmd);
(*$I-*) BlockWrite(dF, dat, len, Result); (*$I+*)
RtnRslt := Result;
dbfErr := IOResult;
end;
if dbfErr <> 0 then
begin
CnvAscToStr(dFa.Name,StrFil,64);
ShowError(dbfErr,StrFil);
end;
end;
begin
IOAsk := 0;
IOPhy := 0;
IORed := 0;
IOWri := 0;
BRCmd := 0;
BWCmd := 0;
end.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/