(* this is a cheesy file handler, just wrote this so i didnt have to do *)
(* alot of checking every time i messed with a file.  Things can be     *)
(* improved alot in here. *)

unit filehandle;

interface

uses dos,crt,detector;

const multitask:boolean=false;
function  ShareInstalled: boolean;
Procedure TextSeek     (Var F : Text; Offset : Longint);
Function  TextFileSize (Var F : Text): LongInt;
Function  TextFilePos  (Var F : Text): LongInt;
function  tassign (Var f:text;s:string):boolean;
procedure treset  (var f:text);
procedure tread   (Var f:text;var G:string);
procedure treadln (Var f:text;var G:string);
procedure twrite  (var f:text;var G:string);
procedure tclose  (var f:text);
procedure trewrite(var f:text);

procedure nreset  (var f:file);
procedure nclose(var f:file);
procedure nseek(var f:file;x:longint);
procedure ntruncate(var f:file);

Procedure Nread(var F:file;var Buf;count:longint);
Procedure NWrite(var F:file; var Buf;count:longint);
Procedure NBlockRead(Var FF:File; Var Buf; Count : Word; Var Res:Word);
Procedure NBlockWrite(Var FF:File; Var Buf; Count : Word; Var Res:Word);
function LockByte(var thefile; FirstByte, NoBytes: longint): byte;
function UnLockByte(var thefile; FirstByte, NoBytes: longint): byte;
function LockRec(var thefile; FirstRec, NoRecs: word): byte;
function UnLockRec(var thefile; FirstRec, NoRecs: word): byte;
function nassign(Var F:file;s:String):boolean;



type
  LockAction = (Lock, Unlock);

const maxtimeout = 500;
var mode:byte;
implementation
uses genstr;

procedure modeit(a:boolean);
begin
case a of
true:begin;
     mode:=filemode;
     filemode:=66;
     end;
false:filemode:=mode;
end;

end;

function lget_ms: longint;
var
   h,m,s,s1: word;
begin
   GetTime(h,m,s,s1);
   lget_ms  := longint(s1) * longint(10) +      {seconds/100}
               longint(s)  * longint(1000) +    {seconds}
               longint(m)  * longint(60000) +   {minutes}
               longint(h)  * longint(3600000);  {hours}
end;

function ShareInstalled; assembler;
asm
  mov ax,$1000
  int $2f
end;

function LockByte; assembler;
asm
  mov ax, $5c00
  les bx, thefile
  mov bx, es:[bx].FileRec.Handle
  les dx, FirstByte
  mov cx, es
  les di, NoBytes
  mov si, es
  int $21
  jc @1
  xor al, al
@1:
end;

function LockRec; assembler;
asm
  les bx, thefile
  mov cx, es:[bx].FileRec.RecSize
  mov ax, FirstRec
  mul cx
  push ax
  push dx
  mov ax, NoRecs
  mul cx
  mov si, dx
  mov di, ax
  pop cx
  pop dx
  mov ax, $5c00
  mov bx, es:[bx].FileRec.Handle
  int $21
  jc @1
  xor al, al
@1:
end;

function UnLockByte; assembler;
asm
  mov ax, $5c01
  les bx, thefile
  mov bx, es:[bx].FileRec.Handle
  les dx, FirstByte
  mov cx, es
  les di, NoBytes
  mov si, es
  int $21
  jc @1
  xor al, al
@1:
end;

function UnLockRec; assembler;
asm
  les bx, thefile
  mov cx, es:[bx].FileRec.RecSize
  mov ax, FirstRec
  mul cx
  push ax
  push dx
  mov ax, NoRecs
  mul cx
  mov si, dx
  mov di, ax
  pop cx
  pop dx
  mov ax, $5c01
  mov bx, es:[bx].FileRec.Handle
  int $21
  jc @1
  xor al, al
@1:
end;

Function Locked_Rec_Okay(Var F; FPos, Size : Longint) : Boolean;
Var Now, Start, Finish : Longint;
    Loop : Boolean;
    Lk : Byte;
    FF : File Absolute F;
Begin
  modeit(true);
  If LockRec(FF, FPos, 1)<>0 Then Begin
    Start := LGet_MS;
    Finish := Start + MaxTimeOut;
    Repeat
      Repeat
        Lk  := LockRec(FF, FPos, 1);
        Now := LGet_MS;
      Until (LK = 0) or (Now > Finish) or (Now < Start);
      If Not LK = 0 Then Begin
        Lk := UnlockByte(FF, 0, FileSize(FF));
        Lk := 1;
      End;
    Until LK = 0;
  End Else Lk:=0;
  Locked_Rec_Okay := LK = 0;
  modeit(false);
End;

Function Locked_Byte_Okay(Var F; FPos, Size : Longint) : Boolean;
Var Now, Start, Finish : Longint;
    Loop : Boolean;
    Lk : Byte;
    FF : File Absolute F;
Begin
  If LockByte(FF, FPos, Size)<>0 Then Begin
    Start := LGet_MS;
    Finish := Start + MaxTimeOut;
    Repeat
      Repeat
        Lk  := LockByte(FF, FPos, Size);
        Now := LGet_MS;
      Until (LK = 0) or (Now > Finish) or (Now < Start);
      If Not LK = 0 Then Begin
        Lk := UnlockByte(FF, 0, FileSize(FF));
        Lk := 1;
      End;
    Until LK = 0;
  End Else Lk:=0;
  Locked_Byte_Okay := LK = 0;
End;

function nassign(var f:file;s:string):boolean;
var count:byte;
begin
{the TP system unit. 0=read/only 1=write/only 2=read/write 64=shared-r/o
 65=shared-w/o 66=shared-r/w.  In your case there may be no need to test}

count:=1;
nassign:=true;
modeit(true);
assign(f,s);
{$I-} reset(f,1); {$I+}
if ioresult<>0 then begin;
                    repeat
                    nassign:=false;
                   {$i-} rewrite(f,1); {$i+}
                    inc(count);
                    until (ioresult=0) or (count=5);
                    end;
TimeSlice;
modeit(false);
end;

Procedure Nread(var F:file;var Buf;count:longint);
    var
    FPos : Longint;
    Lk : Byte;
    mode:byte;
Begin
  FPos := FilePos(F);
  If Not Locked_Rec_Okay(F, FPos,1)
    Then Exit;
{$i-}  BlockRead(F, Buf, count); {$i+}
  Lk := UnLockRec(F, FPos, 1);
End;

Procedure NWrite(var F:file;var Buf;count:longint);
var
    FPos : Longint;
    LK   : Byte;
    mode:byte;
Begin
  FPos := FilePos(f);
  If Not Locked_Rec_Okay(F, FPos, count)
    Then Exit;
  mode:=filemode;
  filemode:=65;
{$i-}  BlockWrite(f, buf, count); {$i+}
  filemode:=mode;
  Lk := UnLockRec(f, FPos, count);
End;

Procedure NBlockRead(Var FF:File; Var Buf; Count : Word; Var Res:Word);
var FPos : LongInt;
    LK   : Byte;
begin
  FPos := FilePos(FF);
  If Not Locked_Byte_Okay(FF, FPos, Count) Then Exit;
  BlockRead(FF,Buf,Count,Res);
  Lk  := UnLockByte(FF, FPos, Count);
end;

Procedure NBlockWrite(Var FF:File; Var Buf; Count : Word; Var Res:Word);
var FPos : Longint;
    LK   : Byte;
Begin
  FPos := FilePos(FF);
  If Not Locked_Byte_Okay(FF, FPos, Count) Then Exit;
  BlockWrite(FF,Buf,Count,Res);
  Lk := UnLockByte(FF,FPos,Count);
End;

procedure trewrite(var f:text);
begin
{$i-} rewrite(f); {$i+}
if ioresult<>0 then writeln('^File Error ',ioresult);
end;

procedure nreset  (var f:file);
begin
  filemode:=66;
{$I-} reset(f,1); {$I+}
if ioresult<>0 then rewrite(f,1);
TimeSlice;
end;


procedure nclose(var f:file);
begin
{$i-} close(f); {$i+}
if ioresult<>0 then writeln('@File Error ',ioresult);
end;

procedure nseek(var f:file;x:longint);
begin
{$i-} if filesize(f)=0 then {$i+} exit;
if ioresult<>0 then writeln('-File Error ',ioresult);
{$i-} seek(f,x); {$i+}
if ioresult<>0 then writeln('$File Error ',ioresult);
end;

procedure ntruncate(var f:file);
begin
{$i-} if filesize(f)=0 then {$i+} exit;
{$i-} truncate(f); {$i+}
if ioresult<>0 then writeln('%File Error ',ioresult);
end;


function tassign(var f:text;s:string):boolean;
begin
tassign:=true;
assign(f,s);
{$I-} reset(f); {$I+}
if ioresult<>0 then begin;
                    tassign:=false;
                    {$i-} rewrite(f); {$i+}
                    end;
end;

procedure treset  (var f:text);
begin
{$I-} reset(f); {$I+}
if ioresult<>0 then rewrite(f);
end;



procedure twrite (var f:text;var G:string);
begin
{$i-} write(f,g); {$I+}
if ioresult<>0 then writeln('*File Error ',ioresult);
end;

procedure tread  (Var f:text;var G:string);
var b:longint;
begin
fillchar(g,sizeof(g),#0);
{$i-} read(f,g); {$i+}
if ioresult<>0 then writeln('+File Error ',ioresult);
end;

procedure treadln(Var f:text;var G:string);
var b:longint;
begin
fillchar(g,sizeof(g),#0);
{$i-} readln(f,g); {$i+}
if ioresult<>0 then writeln('+File Error ',ioresult);
end;


procedure tclose(var f:text);
begin
{$i-} close(f); {$i+}
if ioresult<>0 then writeln('@File Error ',ioresult);
end;

Procedure TextSeek(Var F : Text; Offset : Longint);
var BFile    : File of byte absolute F;  (* Set up File for Seek *)
    BFileRec : FileRec absolute Bfile;
    TFileRec : TextRec Absolute F;
    OldRecSize : Word;
    oldmode : word;

Begin
  With BfileRec do Begin
    oldmode:=mode;
    Mode := FmInOut;         (* Change file mode so Turbo thinks it is *)
    OldRecSize := RecSize;   (* dealing with a untyped file.           *)
    RecSize := 1;            (* Set the Record size to 1 byte.         *)
    Seek(Bfile,Offset);      (* Perform Seek on untyped file.          *)
    Mode := oldmode;         (* Change file mode back to text so that  *)
    RecSize := OldRecSize;   (* normal text operation can resume.      *)
  end;
  TfileRec.BufPos := TfileRec.BufEnd; (* Force next Readln.              *)
end; {textseek}

Function TextFileSize(Var F : Text): LongInt;
var BFile:File of byte absolute F;
    BFileRec:FileRec absolute Bfile;
    OldRecSize:Word;
    oldmode:word;
Begin
  With BfileRec do Begin
    oldmode:=mode;
    Mode := FmInOut;
    OldRecSize := RecSize;
    RecSize := 1;
    TextFileSize := FileSize(Bfile);
    Mode := oldmode;
    RecSize := OldRecSize;
  end;
end; {textfilesize}


Function Textfilepos(Var F : Text): LongInt;

{ determine current position (in bytes) in text file f}

var BFile:File of byte absolute F;
    BFileRec:FileRec absolute Bfile;
    TFileRec:TextRec Absolute F;
    OldRecSize:Word;
    oldmode:word;

Begin
  With BfileRec do Begin
    oldmode:=mode;
    Mode := FmInOut;
    OldRecSize := RecSize;
    RecSize := 1;
    textfilepos := Filepos(Bfile)-tfilerec.bufend+tfilerec.bufpos;
    Mode := oldmode;
    RecSize := OldRecSize;
  end;
end; {textfilepos}

begin
end.
