////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2023 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// This unit containts FIFO buffers for multithread applications.             //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20010712 - creation & tests                                                //
// 20011024 - puts/gets,tag                                                   //
// 20011027 - use safemove,safefillchar,kill                                  //
// 20011028 - use wasborn/mustdie                                             //
// 20011031 - TLatch                                                          //
// 20020129 - TFifo.PutText/GetText                                           //
// 20030323 - Struggle for safety (add some try/except checks)...             //
// 20030328 - LockUnlockBalance                                               //
// 20050224 - TLatch moved to _Alloc.pas                                      //
// 20050612 - SetSize                                                         //
// 20120218 - GrowFactor                                                      //
// 20170228 - GrowLimit                                                       //
// 20230503 - Convert to FPC (A.K.)                                           //
// 20230916 - Total property                                                  //
////////////////////////////////////////////////////////////////////////////////
{
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2001, <kouriakine@mail.ru>
 .
 Modifications:
 ****************************************************************************
 }

unit _crw_fifo; // Thread Safe queue - first in, first out.

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
  _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
  {$IFDEF UNIX} cthreads, dl, {$ENDIF}
  {$IFDEF WINDOWS} windows, {$ENDIF}
  sysutils, classes, math,
  _crw_alloc;

 {
 TFifo is object to transfer data between threads. "Writer" threads have to
 Put data to fifo, "reader" threads have to Get data from fifo.
 Put/Get cycle takes about 0.4+0.002*BufferSize mks on my K7-650.

 TFifo is full safety object, any call with "nil" will not break your program.
 For example, fifo.size=0 if fifo=nil.

 program Example;
 var x,y:double; fifo:TFifo;
 begin
  fifo:=TFifo.Create(1024);
  Echo(Format('%d bytes fifo buffer',[fifo.Size]));
  if fifo.put(@x,sizeof(double))=0 then Echo('overflow');
  Echo(fifo.Count+' bytes stored in fifo');
  Echo(fifo.Space+' bytes available in fifo');
  Echo(fifo.Lost+' bytes lost');
  if fifo.get(@y,sizeof(double))=0 then Echo('empty') else Echo(y);
  Kill(fifo);
 end.
 }
const
 MaxFifoTags = 16;
 DefaultFifoGrowLimit = 1024*1024*4;

type
 TFifo = class(TLatch)
 private
  myBuff       : PChar;
  mySize       : LongInt;
  myHead       : LongInt;
  myTail       : LongInt;
  myLost       : Int64;
  myTotal      : Int64;
  myCount      : LongInt;
  myName       : LongString;
  myTag        : packed array[0..MaxFifoTags-1] of LongWord;
  myGrowFactor : Integer;
  myGrowLimit  : Integer;
  function    GetName:LongString;
  procedure   SetName(const NewName:LongString);
  function    GetTag(i:Integer):LongWord;
  procedure   SetTag(i:Integer; NewTag:LongWord);
  function    GetCount:LongInt;
  function    GetSpace:LongInt;
  function    GetSize:LongInt;
  procedure   SetSize(aSize:LongInt);
  function    GetGrowFactor:Integer;
  procedure   SetGrowFactor(aFactor:Integer);
  function    GetGrowLimit:Integer;
  procedure   SetGrowLimit(aLimit:Integer);
  function    GetLost:Int64;
  procedure   SetLost(N:Int64);
  function    GetTotal:Int64;
  procedure   SetTotal(N:Int64);
 public
  {
  Create fifo with given memory buffer size, name and tag.
  }
  constructor Create(aSize:LongInt=1024; const aName:LongString=''; aGrowFactor:Integer=0);
  {
  Destroy fifo and free memory buffer.
  }
  destructor  Destroy;override;
  {
  The name of fifo. That is any user name, for example, name of file.
  }
  property    Name:LongString read GetName write SetName;
  {
  The tags, associated with fifo. That is any user data, for example, linked objects.
  }
  property    Tag[i:Integer]:LongWord read GetTag write SetTag;
  {
  Return current size of data stored in fifo buffer.
  If only one "reader" thread uses, Count guarantees "at least" data size in buffer.
  If multiple "reader" thread uses, Count guarantees nothing.
  Use this function for debug or information purposes.
  }
  property    Count:LongInt read GetCount;
  {
  Return current size of available space in fifo buffer.
  If only one "writer" thread uses, Space guarantees "at least" free space.
  If multiple "writer" thread uses, Space guarantees nothing.
  Use this function for debug or information purposes.
  }
  property    Space:LongInt read GetSpace;
  {
  Return buffer size in bytes.
  }
  property    Size:LongInt read GetSize write SetSize;
  {
  Factor of FIFO buffer resizing in case of overflow.
  }
  property    GrowFactor:Integer read GetGrowFactor write SetGrowFactor;
  {
  Limit for FIFO buffer resizing in case of overflow.
  }
  property    GrowLimit:Integer read GetGrowLimit write SetGrowLimit;
  {
  Return counter of lost data bytes. This counter increments,
  when a "writer" thread try to Put data, and not enough space found in buffer.
  }
  property    Lost:Int64 read GetLost write SetLost;
  {
  Return total counter of data bytes transferred (put to fifo)..
  }
  property    Total:Int64 read GetTotal write SetTotal;
  {
  Transfer BufferSize bytes from Buffer to fifo.
  Note that you may tranfer only whole buffer or nothing.
  If not enough space to transfer data and TryMode if off, the Lost counter increments.
  Return BufferSize if sucess or 0 if not enough space in fifo, nil Buffer or zero BufferSize.
  }
  function    Put(Buffer:Pointer; BufferSize:LongInt; TryMode:boolean=false):LongInt;
  {
  Transfer data from fifo to Buffer. BufferSize is maximal number of bytes to transfer.
  Note that actual transfer count may be less then BufferSize if no more data in fifo.
  Return actual number of transfered bytes or 0 if empty fifo, nil Buffer or zero BufferSize.
  }
  function    Get(Buffer:Pointer; BufferSize:LongInt):LongInt;
  {
  Put string to fifo. To get string, use Gets only.
  This functions Puts/Gets must be uses in pair, and not with put/get.
  }
  function    Puts(const S:ShortString; TryMode:boolean=false):boolean;
  {
  Get string from fifo. To put string, use Puts only.
  This functions Puts/Gets must be uses in pair, and not with put/get.
  }
  function    Gets(var S:ShortString):boolean;
  {
  Put text, given in long string S, as binary buffer, without check or transform.
  }
  function    PutText(const S:LongString; TryMode:boolean=false):Boolean;
  {
  Get text, not more then MaxLen chars, as long string.
  }
  function    GetText(MaxLen:Integer=MaxInt):LongString;
  {
  Clear data buffer and counter of lost data.
  Buffer memory does not deallocates.
  }
  procedure   Clear;
 end;

 {
 General creation/destruction fifo functions.
 }
function  NewFifo(aSize:LongInt=1024; const aName:LongString=''; aGrowFactor:Integer=0):TFifo;
procedure Kill(var TheObject:TFifo); overload;

implementation

 {
 ********************
 TFifo implementation
 ********************
 }
constructor TFifo.Create(aSize:LongInt=1024; const aName:LongString=''; aGrowFactor:Integer=0);
begin
 inherited Create;
 myBuff:=Allocate(aSize);
 mySize:=AllocSize(myBuff);
 myHead:=0;
 myTail:=0;
 myLost:=0;
 myTotal:=0;
 myCount:=0;
 myName:=aName;
 SafeFillChar(myTag,sizeof(myTag),0);
 myGrowFactor:=Max(0,aGrowFactor);
 myGrowLimit:=DefaultFifoGrowLimit;
end;

destructor TFifo.Destroy;
begin
 Lock;
 try
  SafeFillChar(myTag,sizeof(myTag),0);
  myName:='';
  myCount:=0;
  myLost:=0;
  myTail:=0;
  myHead:=0;
  mySize:=0;
  Deallocate(Pointer(myBuff));
 finally
  Unlock;
 end;
 inherited Destroy;
end;

function TFifo.GetName:LongString;
begin
 Result:='';
 if Assigned(Self) then begin
  Lock;
  Result:=myName;
  Unlock;
 end;
end;

procedure TFifo.SetName(const NewName:LongString);
begin
 if Assigned(Self) then begin
  Lock;
  myName:=NewName;
  Unlock;
 end;
end;

function TFifo.GetTag(i:Integer):LongWord;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  if (i>=Low(myTag)) and (i<=High(myTag)) then Result:=myTag[i];
  Unlock;
 end;
end;

procedure TFifo.SetTag(i:Integer; NewTag:LongWord);
begin
 if Assigned(Self) then begin
  Lock;
  if (i>=Low(myTag)) and (i<=High(myTag)) then myTag[i]:=NewTag;
  Unlock;
 end;
end;

function TFifo.GetCount:LongInt;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myCount;
  Unlock;
 end;
end;

function TFifo.GetSpace:LongInt;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=mySize-myCount;
  Unlock;
 end;
end;

function TFifo.GetSize:LongInt;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=mySize;
  Unlock;
 end;
end;

procedure TFifo.SetSize(aSize:LongInt);
var s:LongString; t:Int64;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   s:=GetText;
   t:=myTotal;
   Reallocate(Pointer(myBuff),Max(0,aSize));
   mySize:=AllocSize(myBuff);
   myHead:=0;
   myTail:=0;
   myCount:=0;
   PutText(s);
   myTotal:=t;
  finally
   Unlock;
   s:='';
  end;
 except
  on E:Exception do BugReport(E,Self,'SetSize');
 end;
end;

function TFifo.GetGrowFactor:Integer;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myGrowFactor;
  Unlock;
 end;
end;

procedure TFifo.SetGrowFactor(aFactor:Integer);
begin
 if Assigned(Self) then begin
  Lock;
  myGrowFactor:=Max(0,Min(4,aFactor));
  Unlock;
 end;
end;

function TFifo.GetGrowLimit:Integer;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myGrowLimit;
  Unlock;
 end;
end;

procedure TFifo.SetGrowLimit(aLimit:Integer);
begin
 if Assigned(Self) then begin
  Lock;
  myGrowLimit:=Max(0,aLimit);
  Unlock;
 end;
end;

function TFifo.GetLost:Int64;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myLost;
  Unlock;
 end;
end;

procedure TFifo.SetLost(N:Int64);
begin
 if Assigned(Self) then begin
  Lock;
  myLost:=N;
  Unlock;
 end;
end;

function TFifo.GetTotal:Int64;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myTotal;
  Unlock;
 end;
end;

procedure TFifo.SetTotal(N:Int64);
begin
 if Assigned(Self) then begin
  Lock;
  myTotal:=N;
  Unlock;
 end;
end;

function TFifo.Put(Buffer:Pointer; BufferSize:LongInt; TryMode:boolean=false):LongInt;
var
 n   : LongInt;
 newSize : LongInt;
 Buf : PChar absolute Buffer;
begin
 Result:=0;
 if Assigned(Self) then                       { Protection if nil fifo object. }
 if Assigned(Buffer) then                     { Protection if nil buffer. }
 if BufferSize>0 then begin                   { Protection if invalid size of data. }
  Lock;                                       { Enter critical section for thread safety. }
  if myGrowFactor>1 then                      { If growing on overflow enabled. }
  if BufferSize>mySize-myCount then begin     { If buffer overflow expected. }
   newSize:=mySize*myGrowFactor;              { newSize wanted. }
   while newSize<=myGrowLimit do begin        { Find reasonable value: }
    if BufferSize>newSize-myCount             { If still not enough, }
    then newSize:=newSize*myGrowFactor        { Grow buffer more. }
    else break;                               { Found. }
    if newSize<=mySize then break;            { Digital overflow protection. }
   end;                                       { Found? }
   if newSize>mySize then                     { If not digital overflow, }
   if newSize<=myGrowLimit                    { If growing allowed by limit }
   then SetSize(newSize);                     { Resize to avoid overflow. }
  end;
  if BufferSize<=mySize-myCount then begin    { Check free buffer space. }
   n:=mySize-myHead;                          { Free space in buffer end }
   if BufferSize<=n then begin                { If may copy all data to end }
    SafeMove(Buf[0],myBuff[myHead],BufferSize);{ then do it. }
   end else begin                             { If can't copy all data to end }
    SafeMove(Buf[0],myBuff[myHead],n);        { then copy a piece to end }
    SafeMove(Buf[n],myBuff[0],BufferSize-n);  { and a piece to start }
   end;
   inc(myHead,BufferSize);
   if myHead>=mySize then dec(myHead,mySize); { Cyclic discipline! }
   inc(myCount,BufferSize);
   inc(myTotal,BufferSize);
   inc(Result,BufferSize);
  end else begin                              { Not enough buffer space found. }
   if not TryMode then inc(myLost,BufferSize);{ Fix error, if not TryMode. }
  end;
  Unlock;                                     { Leave critical section. }
 end;
end;

function TFifo.Get(Buffer:Pointer; BufferSize:LongInt):LongInt;
var
 n   : LongInt;
 Buf : PChar absolute Buffer;
begin
 Result:=0;
 if Assigned(Self) then                       { Protection if nil fifo object. }
 if Assigned(Buffer) then                     { Protection if nil buffer. }
 if BufferSize>0 then begin                   { Protection if invalid size of data. }
  Lock;                                       { Enter critical section for thread safety. }
  if myCount>0 then begin                     { Check if fifo empty? }
   if BufferSize>myCount                      { Size of data to get = smallest of }
   then BufferSize:=myCount;                  { BufferSize and Ņount. }
   n:=mySize-myTail;                          { Free space in buffer end }
   if BufferSize<=n then begin                { If may copy all data to end }
    SafeMove(myBuff[myTail],Buf[0],BufferSize);{ then do it. }
   end else begin                             { If can't copy all data to end }
    SafeMove(myBuff[myTail],Buf[0],n);        { then copy a piece to end }
    SafeMove(myBuff[0],Buf[n],BufferSize-n);  { and a piece to start }
   end;
   inc(myTail,BufferSize);
   if myTail>=mySize then dec(myTail,mySize); { Cyclic discipline! }
   dec(myCount,BufferSize);
   inc(Result,BufferSize);
  end;
  Unlock;                                     { Leave critical section. }
 end;
end;

function TFifo.Puts(const S:ShortString; TryMode:boolean=false):boolean;
begin
 Result:=(Put(@S[0], length(S)+1, TryMode) = length(S)+1);
end;

function TFifo.Gets(var S:ShortString):boolean;
begin
 Result:=false;
 S[0]:=#0;
 if Assigned(Self) then begin
  Lock;
  if Get(@S[0],1)=1 then Result:=Get(@S[1],length(S))=length(S);
  Unlock;
 end;
end;

function TFifo.PutText(const S:LongString; TryMode:boolean=false):Boolean;
begin
 Result:=(Put(Pointer(S), Length(S), TryMode) = Length(S));
end;

function TFifo.GetText(MaxLen:Integer=MaxInt):LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   if Count>0 then begin
    SetLength(Result,min(MaxLen,Count));
    if Get(Pointer(Result),Length(Result))<>Length(Result) then Result:='';
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do begin
   BugReport(E,Self,'GetText');
   Result:='';
  end;
 end;
end;

procedure TFifo.Clear;
begin
 if Assigned(Self) then begin
  Lock;
  myHead:=0;
  myTail:=0;
  myLost:=0;
  myCount:=0;
  Unlock;
 end;
end;

function NewFifo(aSize:LongInt=1024; const aName:LongString=''; aGrowFactor:Integer=0):TFifo;
begin
 Result:=nil;
 try
  Result:=TFifo.Create(aSize, aName, aGrowFactor);
 except
  on E:Exception do BugReport(E,nil,'NewFifo');
 end;
end;

procedure Kill(var TheObject:TFifo); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_fifo;
begin
end;

procedure Free_crw_fifo;
begin
end;

initialization

 Init_crw_fifo;

finalization

 Free_crw_fifo;

end.

//////////////
// END OF FILE
//////////////

