cbuf.pas

Source code Delphi FTP-server

{$A+,B-,C+,D+,E-,F-,G+,H-,I-,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
unit CBuf;

{--------------------------------------------------------------------}
{ CBuf - Circle buffer module.                                       }
{ 11/15/1999 Drt.                                                    }
{--------------------------------------------------------------------}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

const
 MaxCB  = 30000;
 MaxOut = 250;

type
  pCBbuf = ^tCBbuf;
  tCBbuf = array [1..MaxCB] of char;

  TCB = class (TObject)
  private
    mtx : tHandle;
    CB  : pCBbuf;
    cbs : word;
    cbe : word;
  public
    constructor Create;
    destructor Destroy; override;
    function AddCB(s : string) : boolean;
    function AddCBBuf(var b; l : word) : boolean;
    function GetCB(var out : string) : boolean;
    function GetCBBuf(var out; var n : word) : boolean;
    procedure Reset;
  end;

implementation

{ tCBbuf }

constructor tCB.Create;
begin
inherited create;
CB:=nil;
getmem(CB,sizeof(tCBbuf));
cbs:=1;
cbe:=1;
mtx:=CreateMutex(nil,false,nil);
end;

procedure tCB.Reset;
begin
WaitForSingleObject(mtx,INFINITE);
cbs:=1;
cbe:=1;
ReleaseMutex(mtx);
end;

destructor tCB.Destroy;
begin
WaitForSingleObject(mtx,INFINITE);
if CB <> nil then
  freemem(CB,sizeof(tCBbuf));
CB:=nil;
ReleaseMutex(mtx);
CloseHandle(mtx);
inherited Destroy;
end;

function tCB.AddCB(s : string) : boolean;
var
 l : integer;
begin
AddCB:=false;
WaitForSingleObject(mtx,INFINITE);
l:=length(s);
if cbe >= cbs then
  begin
  if (MaxCB-cbe+1) >= l then
    begin
    copymemory(@CB^[cbe],@s[1],l);
    cbe:=cbe+l;
    if cbe > MaxCB then cbe:=1;
    end
  else
    begin
    if ((MaxCB-cbe)+(cbs-1)) < l then
      begin
      ReleaseMutex(mtx);
      exit;
      end
    else
      begin
      copymemory(@CB^[cbe],@s[1],MaxCB-cbe+1);
      s:=copy(s,MaxCB-cbe+2,255);
      l:=length(s);
      copymemory(CB,@s[1],l);
      cbe:=l+1;
      end;
    end;
  end
else
  begin
  if (cbs-cbe-1) < l then
    begin
    ReleaseMutex(mtx);
    exit;
    end
  else
    begin
    copymemory(@CB^[cbe],@s[1],l);
    cbe:=cbe+l;
    end;
  end;
AddCB:=true;
ReleaseMutex(mtx);
end;

type
 ts = array [1..$fff0] of char;

function tCB.AddCBBuf(var b; l : word) : boolean;
var
 i : word;
begin
AddCBBuf:=false;
WaitForSingleObject(mtx,INFINITE);
if cbe >= cbs then
  begin
  if (MaxCB-cbe+1) >= l then
    begin
    copymemory(@CB^[cbe],@b,l);
    cbe:=cbe+l;
    if cbe > MaxCB then cbe:=1;
    end
  else
    begin
    if ((MaxCB-cbe)+(cbs-1)) < l then
      begin
      ReleaseMutex(mtx);
      exit;
      end
    else
      begin
      copymemory(@CB^[cbe],@b,MaxCB-cbe+1);
      i:=l-(MaxCB-cbe+1);
      copymemory(CB,@ts(b)[MaxCB-cbe+2],i);
      cbe:=i+1;
      end;
    end;
  end
else
  begin
  if (cbs-cbe-1) < l then
    begin
    ReleaseMutex(mtx);
    exit;
    end
  else
    begin
    copymemory(@CB^[cbe],@b,l);
    cbe:=cbe+l;
    end;
  end;
AddCBBuf:=true;
ReleaseMutex(mtx);
end;

function ScanMem(var buf; len : word; s : string) : word;
var
 i,i1 : word;
 p    : boolean;
begin
ScanMem:=0;
if (s = '') or (len < length(s)) then exit;
for i:=1 to (len-length(s)+1) do
  begin
  if ts(buf)[i] = s[1] then
    begin
    p:=true;
    for i1:=2 to length(s) do
      if ts(buf)[i+i1-1] <> s[i1] then p:=false;
    if p then
      begin
      ScanMem:=i;
      exit;
      end;
    end;
  end;
end;

function tCB.GetCB(var out : string) : boolean;
var
 i : word;
 s : string;
begin
GetCB:=false;
WaitForSingleObject(mtx,INFINITE);
if cbe = cbs then
  begin
  ReleaseMutex(mtx);
  exit;
  end;
if cbe > cbs then
  begin
  i:=ScanMem(CB^[cbs],cbe-cbs,#10);
  if i = 0 then
    begin
    ReleaseMutex(mtx);
    exit;
    end;
  if (i-1) < MaxOut then
    begin
    copymemory(@s[1],@CB^[cbs],i-1);
    s[0]:=chr(i-1);
    end
  else
    begin
    copymemory(@s[1],@CB^[cbs],MaxOut);
    s[0]:=chr(MaxOut);
    end;
  cbs:=cbs+i;
  end
else
  begin
  i:=ScanMem(CB^[cbs],MaxCB-cbs+1,#10);
  if i > 0 then
    begin
    if (i-1) < MaxOut then
      begin
      copymemory(@s[1],@CB^[cbs],i-1);
      s[0]:=chr(i-1);
      end
    else
      begin
      copymemory(@s[1],@CB^[cbs],MaxOut);
      s[0]:=chr(MaxOut);
      end;
    cbs:=cbs+i;
    if cbs > MaxCB then cbs:=1;
    end
  else
    begin
    i:=ScanMem(CB^[1],cbe-1,#10);
    if i = 0 then
      begin
      ReleaseMutex(mtx);
      exit;
      end;
    if (MaxCB-cbs+1) < MaxOut then
      begin
      copymemory(@s[1],@CB^[cbs],MaxCB-cbs+1);
      if (MaxCB-cbs+i) < MaxOut then
        begin
        copymemory(@s[MaxCB-cbs+2],CB,i-1);
        s[0]:=chr(MaxCB-cbs+i);
        end
      else
        begin
        copymemory(@s[MaxCB-cbs+2],CB,MaxOut-MaxCB+cbs-1);
        s[0]:=chr(MaxOut);
        end;
      end
    else
      begin
      copymemory(@s[1],@CB^[cbs],MaxOut);
      s[0]:=chr(MaxOut);
      end;
    cbs:=i+1;
    end;
  end;
if (s[0] <> #0) and (s[byte(s[0])] = #13) then dec(byte(s[0]));
out:=s;
GetCB:=true;
ReleaseMutex(mtx);
end;

function tCB.GetCBBuf(var out; var n : word) : boolean;
var
 i : word;
begin
GetCBBuf:=false;
WaitForSingleObject(mtx,INFINITE);
if cbe = cbs then
  begin
  ReleaseMutex(mtx);
  n:=0;
  exit;
  end;
if cbe > cbs then
  begin
  if (cbe-cbs) > n then
    i:=n
  else
    i:=cbe-cbs;
  copymemory(@out,@CB^[cbs],i);
  cbs:=cbs+i;
  n:=i;
  end
else
  begin
  if (MaxCB-cbs+1) >= n then
    begin
    copymemory(@out,@CB^[cbs],n);
    cbs:=cbs+n;
    if cbs > MaxCB then cbs:=1;
    end
  else
    begin
    copymemory(@out,@CB^[cbs],MaxCB-cbs+1);
    if (n-(MaxCB-cbs)) < cbe then
      i:=n-(MaxCB-cbs+1)
    else
      i:=cbe-1;
    copymemory(@ts(out)[MaxCB-cbs+2],CB,i);
    n:=MaxCB-cbs+1+i;
    cbs:=i+1;
    end;
  end;
ReleaseMutex(mtx);
GetCBBuf:=true;
end;

end.