unit cheaplok;
{$O+,F+}

interface

function lock(f:string):boolean; {Returns true if was already locked}
function unlock(f:string):boolean; {Returns true if was already unlocked}
function islocked(f:string):boolean; {Returns true if file is locked}
function waitlock(f:string):boolean; {Returns true if we finally got file unlocked}
function hoas:longint; {Hundredths Of A Second today}
procedure xdelay(f:longint);
function checkdv:boolean;

implementation

uses dos,crt,nanostr,nanocore,bbskern;

{ CRC calc stuff from the SWAG }

var
    crc32table : array [byte] of longint;
    crcval : longint;
    j      : integer;

procedure makeCRC32table;
var crc : longint;
    i,n : byte;
begin
 for i := 0 to 255 do
   begin
     crc := i;
     for n := 1 to 8 do
       if odd(crc) then
         crc := (crc shr 1) xor $EDB88320
       else
         crc := crc shr 1;
     crc32table[i] := crc;
   end;
end;

function updateCRC32(c : byte; crc : longint) : longint;
begin
 updateCRC32 := crc32table[lo(crc) xor c] xor (crc shr 8);
end;

function racrc(pass1:string):longint;
begin
  pass1:=upcasestr(pass1);
  makecrc32table;
  crcval := $FFFFFFFF;
  for j := 1 to length(pass1) do
    begin
      crcval := updateCRC32(ord(pass1[j]),crcval);
    end;
    racrc := crcval;
end;


{ The following 4 functions make up the Lock system which writes semaphores}
{ representing the files being written to }

function lock(f:string):boolean; {Returns true if was already locked}
var f2:string;
    ff:text;
    crap:integer;
    p:dos.pathstr; d:dos.dirstr; n:dos.namestr; e:dos.extstr;
begin
{  writeln('Locking ',f);{}
  p:=f; fsplit(p,d,n,e);
  f2:=d+hexl(longint(racrc(f)))+'.BSY';
  if exist(f2) then begin lock:=true; exit; end;
{$I-}
  lock:=false;
  assign(ff,f2); rewrite(ff); crap:=ioresult;
  writeln(ff,f); crap:=ioresult;
  close(ff); crap:=ioresult;
{$I+}
end;

function unlock(f:string):boolean; {Returns true if was already unlocked}
var f2:string;
    ff:file;
    crap:integer;
    p:dos.pathstr; d:dos.dirstr; n:dos.namestr; e:dos.extstr;
begin
{  writeln('Unlocking ',f);{}
  p:=f; fsplit(p,d,n,e);
  f2:=d+hexl(longint(racrc(f)))+'.BSY';
  if not exist(f2) then begin unlock:=true; exit; end;
{$I-}
  unlock:=false;
  assign(ff,f2); erase(ff); crap:=ioresult; if crap<>0 then unlock:=true;
{$I+}
end;

function islocked(f:string):boolean; {Returns true if file is locked}
var f2:string;
    p:dos.pathstr; d:dos.dirstr; n:dos.namestr; e:dos.extstr;
begin
  p:=f; fsplit(p,d,n,e);
  f2:=d+hexl(longint(racrc(f)))+'.BSY';
  islocked:=exist(f2);
end;

function getlockname(lockname:string):string;
var f:text;
    s:string;
    crap:integer;
begin
  if not exist(lockname) then exit;
{$I-}
  assign(f,lockname); crap:=ioresult;
  reset(f); crap:=ioresult;
  readln(f,s); crap:=ioresult;
  close(f); crap:=ioresult;
{$I+}
end;

function waitlock(f:string):boolean; {Returns true if we finally got file unlocked}
var retries:integer;
begin
  retries:=0;
  repeat
    inc(retries);
    if
      not islocked(f)
    then
      begin
        waitlock:=true;
        exit;
      end
    else
      xdelay(random(50)+25);
(*    if retries=5 then writeln(f);
    case (retries mod 4) of
      0: write('-'#8);
      1: write('\'#8);
      2: write('|'#8);
      3: write('/'#8);
    end;  (* *)
  until (retries>99);
  waitlock:=false;
end;

procedure xdelay(f:longint);
var z:longint;
    t1,t2:longint;
    isdv:boolean;
begin
  if f=0 then exit;
  isdv:=checkdv;
  z:=f div 10;
  t1:=hoas; t2:=t1+z;
  if (t2>=8640000) then t2:=longint(t2 mod 8640000);
  repeat
    if isdv then timeslice else delay(2);
  until (hoas>=t2) or lostcarrier;
end;

function hoas:longint; {Hundredths Of A Second today}
var h,m,s,o:word;
    tmp,tmp1:longint;
begin
  gettime(h,m,s,o);
  tmp:=h; tmp:=tmp*360000;
  tmp1:=m; tmp1:=tmp1*6000; tmp:=tmp+tmp1;
  tmp1:=s; tmp1:=tmp1*100; tmp:=tmp+tmp1;
  tmp1:=o; tmp:=tmp+o;
  hoas:=tmp;
end;

function checkdv:boolean;
var regs:registers;
begin
  regs.cx:=$4445;
  regs.dx:=$5351;
  regs.ax:=$2b01;
  intr($21,regs);
  checkdv:=(regs.al<>$ff);
end;

begin
end.

