unit filehandle;
interface

{ Lucid BBS File Handle Routins By Judge Dredd }
{ These will Help out alot because it has all  }
{ the ERROR checking remade so you dont have   }
{ have to add the checking everytime time you  }
{ handle a file.  These will soon have         }
{ MULTI-TASKING support built right in!        }

uses dos,crt,detector;

const multitask:boolean=false;


{ New Assign, Only does TEXT}
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);
{ New Assign, Only does BINARY}
function nassign (var f:file;s:string):boolean;
{ Reset file, will Rewrite if have to }
procedure nreset  (var f:file);
{ Read file info in, Like Blockread but with error checking }
{procedure nread   (Var f:file;var G;z:longint);
{ Write file info in, Like Blockread but with error checking }
{procedure nwrite  (var f:file;var G;z:longint);
{ Close the File }
procedure nclose(var f:file);
{ Seek file position }
procedure nseek(var f:file;x:longint);
{ truncate a file }
procedure ntruncate(var f:file);
{ Is share installed }
function ShareIn: Boolean;
{ File Locker }
{function FLock(var F; Action: LockAction; FPos,Len: Longint): Word;}

Procedure NWrite(Var FF:File; Var Buf; Count : Word);
Procedure NRead(Var FF:File; Var Buf; Count : 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;

const maxtimeout = 500;
implementation

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 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
  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;
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;

Procedure NRead(Var FF:File; Var Buf; Count : Word);
var FPos : LongInt;
    LK   : Byte;
begin
  FPos := FilePos(FF);
  If Not Locked_Byte_Okay(FF, FPos, Count) Then Exit;
  {$i-} blockRead(FF,Buf,Count); {$i+}
  Lk  := UnLockByte(FF, FPos, Count);
end;

Procedure NWrite(Var FF:File; Var Buf; Count : Word);
var FPos : Longint;
    LK   : Byte;
Begin
  FPos := FilePos(FF);
  If Not Locked_Byte_Okay(FF, FPos, Count) Then Exit;
  {$i-} BlockWrite(FF,Buf,Count); {$i+}

  Lk := UnLockByte(FF,FPos,Count);
End;

function ShareIn: Boolean; assembler;
asm
  mov ax, 1000h  {Test for share}
  int 2fh        {Call multiplex interrupt}
  cmp al, 0ffh   {ShareIn = AL=$FF}
  xor al, al     {Default is false}
  jne @@Done     {False}
  mov al, 01h    {True}
@@Done:
  mov ax, 01h
end;

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

function nassign(var f:file;s:string):boolean;
begin
nassign:=true;
assign(f,s);
{filemode := fmDenyNone and fmReadWrite;}
{$I-} reset(f,1); {$I+}
if ioresult<>0 then begin;
{                    FileMode := $02;}
                    nassign:=false;
                   {$i-} rewrite(f,1); {$i+}
{                    FileMode := fmDenyNone + fmReadWrite;}
                    end;
TimeSlice;
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
{filemode := fmDenyNone and fmReadWrite;}
{$I-} reset(f); {$I+}
if ioresult<>0 then rewrite(f);
end;

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

(* procedure nwrite (var f:file;var G;z:longint);
begin
TimeSlice;
{$i-} blockwrite(f,g,z); {$I+}
if ioresult<>0 then writeln('*File Error ',ioresult);
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 nread  (Var f:file;var G;z:longint);
var b:longint;
begin
TimeSlice;
fillchar(g,sizeof(g),#0);
{$i-} if filesize(f)=0 then {$i+} exit;
if ioresult<>0 then writeln('!File Error ',ioresult);
{$i-} blockread(f,g,z); {$i+}
if ioresult<>0 then writeln('+File Error ',ioresult);
end; *)

procedure nclose(var f:file);
begin
{$i-} close(f); {$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 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;

begin
end.
