////////////////////////////////////////////////////////////////////////////////
// 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:                                                                   //
// DIM Queue library. See http://dim.web.cern.ch on DIM.                      //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20201123 - Created by A.K.                                                 //
// 20230501 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_dimq; // DIM Queue

{$I _crw_sysdef}

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

interface

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

 /////////////////
 // TDimDataHolder
 /////////////////
type
 TDimDataHolder=class(TMasterObject)
 private
  myLinkedTag  : PtrInt;
  myDataString : LongString;
  function  GetLinkedTag:PtrInt;
  function  GetDataLength:SizeInt;
  function  GetDataBuffer:Pointer;
  function  GetDataString:LongString;
 public
  constructor Create;
  destructor  Destroy; override;
 public
  property  LinkedTag  : PtrInt     read GetLinkedTag;
  property  DataLength : SizeInt    read GetDataLength;
  property  DataBuffer : Pointer    read GetDataBuffer;
  property  DataString : LongString read GetDataString;
 public
  function  PutData(aTag:PtrInt; aData:Pointer; aLeng:SizeInt):SizeInt;
  procedure ClearData;
 end;

 ////////////////
 // TDimDataQueue
 ////////////////
type
 TDimDataQueue = class(TLatch)
 private
  myList  : TFPObjectList;
  myQueue : TObjectQueue;
  myStack : TObjectStack;
  myLast  : TDimDataHolder;
 public
  function  Push(Tag:TDimLong; Buffer:Pointer; Size:Integer):SizeInt;
  function  Pop(out Tag:TDimLong; out Buffer:Pointer; out Size:Integer):SizeInt;
 public
  function  PopHolder(out Holder:TDimDataHolder):SizeInt;
  function  Count(Who:Char='Q'):Integer; // L,Q,S
  function  LastHolder:TDimDataHolder;
 public
  constructor Create;
  destructor  Destroy; override;
 end;

procedure Kill(var TheObject:TDimDataQueue); overload;

 ////////////////////////////////////////////////////////
 // DimDataQueue is the general instance of TDimDataQueue
 ////////////////////////////////////////////////////////
function DimDataQueue:TDimDataQueue;

procedure TestDimQueue;

implementation

 /////////////////
 // TDimDataHolder
 /////////////////

constructor TDimDataHolder.Create;
begin
 inherited Create;
 ClearData;
end;

destructor TDimDataHolder.Destroy;
begin
 ClearData;
 inherited Destroy;
end;

function  TDimDataHolder.GetLinkedTag:PtrInt;
begin
 if Assigned(Self) then Result:=myLinkedTag else Result:=0;
end;

function  TDimDataHolder.GetDataLength:SizeInt;
begin
 if Assigned(Self) then Result:=Length(myDataString) else Result:=0;
end;

function  TDimDataHolder.GetDataBuffer:Pointer;
begin
 if Assigned(Self) then Result:=Pointer(myDataString) else Result:=nil;
end;

function  TDimDataHolder.GetDataString:LongString;
begin
 if Assigned(Self) then Result:=myDataString;
end;

function  TDimDataHolder.PutData(aTag:PtrInt; aData:Pointer; aLeng:SizeInt):SizeInt;
begin
 Result:=0;
 if Assigned(Self) then
 try
  myDataString:='';
  myLinkedTag:=aTag;
  if Assigned(aData) and (aLeng>0)
  then myDataString:=StringBuffer(aData,aLeng);
  Result:=Length(myDataString);
 except
  on E:Exception do BugReport(E,Self,'PutData');
 end;
end;

procedure  TDimDataHolder.ClearData;
begin
 if Assigned(Self) then begin
  myDataString:='';
  myLinkedTag:=0;
 end;
end;

 ////////////////
 // TDimDataQueue
 ////////////////

constructor TDimDataQueue.Create;
begin
 inherited Create;
 myList:=TFPObjectList.Create;
 myQueue:=TObjectQueue.Create;
 myStack:=TObjectStack.Create;
 myLast:=nil;
end;

destructor TDimDataQueue.Destroy;
begin
 myLast:=nil;
 FreeAndNil(myStack);
 FreeAndNil(myQueue);
 FreeAndNil(myList);
 inherited Destroy;
end;

function TDimDataQueue.Push(Tag:TDimLong; Buffer:Pointer; Size:Integer):SizeInt;
var Holder:TDimDataHolder; Obj:TObject;
begin
 Result:=0;
 if (Tag<>0) then
 if (Size>0) then
 if (Buffer<>nil) then
 if Assigned(Self) then
 try
  Lock;
  try
   Obj:=myStack.Pop;
   if (Obj is TDimDataHolder) then begin
    Holder:=TDimDataHolder(Obj);
    myQueue.Push(Holder);
   end else begin
    Holder:=TDimDataHolder.Create;
    myQueue.Push(Holder);
    myList.Add(Holder);
   end;
   Result:=Holder.PutData(Tag,Buffer,Size);
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self,'Push');
 end;
end;

function TDimDataQueue.PopHolder(out Holder:TDimDataHolder):SizeInt;
var Obj:TObject;
begin
 Result:=0;
 Holder:=nil;
 if Assigned(Self) then
 try
  Lock;
  try
   Obj:=myQueue.Pop;
   if (Obj is TDimDataHolder) then begin
    Holder:=TDimDataHolder(Obj);
    Result:=Holder.DataLength;
    myStack.Push(Obj);
    myLast:=Holder;
   end;
  finally
   UnLock;
  end;
 except
  on E:Exception do BugReport(E,Self,'Pop');
 end;
end;

function TDimDataQueue.Pop(out Tag:TDimLong; out Buffer:Pointer; out Size:Integer):SizeInt;
var Holder:TDimDataHolder;
begin
 Result:=PopHolder(Holder);
 if (Result>0) then begin
  Buffer:=Holder.DataBuffer;
  Size:=Holder.DataLength;
  Tag:=Holder.LinkedTag;
 end else begin
  Buffer:=nil;
  Size:=0;
  Tag:=0;
 end;
end;

function TDimDataQueue.Count(Who:Char='Q'):Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   case UpCase(Who) of
    'L' : Result:=myList.Count;
    'Q' : Result:=myQueue.Count;
    'S' : Result:=myStack.Count;
   end;
  finally
   UnLock;
  end;
 except
  on E:Exception do BugReport(E,Self,'Count');
 end;
end;

function TDimDataQueue.LastHolder:TDimDataHolder;
begin
 if Assigned(Self) then Result:=myLast else Result:=nil;
end;

procedure TestDimQueue;
var i,n:Integer; Tag:TDimLong; S:LongString; Buf:Pointer;
 procedure Report(Msg:LongString);
 begin
  writeln(Msg,' ',Tag,' ',S,' ',n,
          '  Q:',DimDataQueue.Count('Q'),
          '  S:',DimDataQueue.Count('S'),
          '  L:',DimDataQueue.Count('L'));
 end;
begin
 try
  // Push data to queue
  for i:=1 to 10 do begin
   Tag:=i; S:=Format('Data[%d]',[i]);
   n:=DimDataQueue.Push(Tag,PChar(S),Length(s));
   Report('Push');
  end;
  // Extract data from queue
  while DimDataQueue.Pop(Tag,Buf,n)>0 do begin
   S:=StringBuffer(Buf,n);
   Report('Pop');
   DimDataQueue.LastHolder.ClearData;
  end;
  // Push data to queue
  for i:=1 to 10 do begin
   Tag:=i; S:=Format('Data[%d]',[i]);
   n:=DimDataQueue.Push(Tag,PChar(S),Length(s));
   Report('Push');
  end;
  // Extract data from queue
  while DimDataQueue.Pop(Tag,Buf,n)>0 do begin
   S:=StringBuffer(Buf,n);
   Report('Pop');
   DimDataQueue.LastHolder.ClearData;
  end;
 except
  on E:Exception do BugReport(E,nil,'TestDimQueue');
 end;
end;

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

var
 TheDimDataQueue : TDimDataQueue = nil;

function DimDataQueue:TDimDataQueue;
begin
 if not Assigned(TheDimDataQueue) then begin
  TheDimDataQueue:=TDimDataQueue.Create;
 end;
 Result:=TheDimDataQueue;
end;

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

procedure Init_crw_dimq;
begin
end;

procedure Free_crw_dimq;
begin
 Kill(TheDimDataQueue);
end;

initialization

 Init_crw_dimq;

finalization

 Free_crw_dimq;

end.

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

