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

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

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Data acquisition system tags database.                                     //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20020204 - Creation (uses CRW16) & test                                    //
// 20171115 - HashList to improve performance of FindTag                      //
// 20171202 - ReinitTags, use _HASH library and HashList_DefaultHasher        //
// 20190320 - LockTags,UnLockTags                                             //
// 20190321 - iAtomicTagOp,rAtomicTagOp                                       //
// 20200615 - CountTags                                                       //
// 20210423 - GetTagColor,GetTagParam,GetTagTimer                             //
// 20221116 - tag_type_nil,tag_type_int,tag_type_real,tag_type_string         //
// 20230523 - Modified for FPC (A.K.)                                         //
// 20230614 - SetTagsSpinlockCount                                            //
// 20250129 - Use TAtomicCounter                                              //
////////////////////////////////////////////////////////////////////////////////

unit _crw_daqtags; // Data Acquision system tags.

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math,
 _crw_alloc, _crw_fifo, _crw_str, _crw_fio, _crw_hl;

 {
 *******************************************************************************
 Daq tags is thread - safety database of common variables, uses by data
 acquisition system. Tags high protected against crash and errors.
 Each tag has:
  1) Unique name, a string to search variable by name from any thread.
  2) Unique reference, a integer value to access variable.
  3) Type of variable: 1=Integer, 2=Real=Double, 3=String.
  4) Value of specified type (iGetTag,rGetTag,sGetTag).
  5) Associated attributes (GetTagColor,GetTagParam,GetTagTimer).
 To access tag, you need find tag reference by known name via FindTag call and
 use this reference to access tag variable via xGetTag/xSetTag calls.
 If tag is not exists, FindTag returns 0, TypeTag returns 0, NameTag returns
 empty string.
 The typical code of tags usage are:
  var tag:Integer; Value:Double;
  begin
   tag:=FindTag('name');             // Find tag reference in database by name.
   if TypeTag(tag)=2 then begin      // Check, is tag of real type?
    Value:=rGetTag(tag);             // Read  real tag value.
    rSetTag(tag,Value);              // Write real tag value.
   end else Echo('Invalid tag!');    // Tag not found or has another type.
  end;
 *******************************************************************************
 }

const
 OriginTags = 256;                       // Low range of tag index
 MaxNumTags = 1024 * 64;                 // Maximum namber of tags

function  TagBugs:SizeInt;               // Internal bugs (errors) counter
procedure SetTagBugs(aValue:SizeInt);    // For example, R/W wrong tag type

const                                    // For program logic consistency
 TAG_REF_MIN = OriginTags;               // Must be TAG_REF_MIN > TASK_REF_MAX = 255
 TAG_REF_MAX = OriginTags+MaxNumTags-1;  // Must be TAG_REF_MAX < ObjectRegistryOffset

const                                   // TypeTag values:
 tag_type_nil    = 0;                   // Tag not initialized or invalid
 tag_type_int    = 1;                   // Tag has Integer type => Integer
 tag_type_real   = 2;                   // Tag has Real    type => Double
 tag_type_string = 3;                   // Tag has String  type => AnsiString

procedure ClearTags;
function  CountTags:Integer;
function  UnifyTagAlias(Name:LongString):LongString;
function  FindTag(Name:LongString):Integer;
function  InitTag(Name:LongString; Typ:Integer):Integer;
function  FreeTag(tag:Integer):Boolean;
function  TypeTag(tag:Integer):Integer;
function  NameTag(tag:Integer):LongString;
function  iGetTag(tag:Integer):Integer;
function  rGetTag(tag:Integer):Double;
function  sGetTag(tag:Integer):LongString;
function  iSetTag(tag:Integer; i:Integer):Boolean;
function  rSetTag(tag:Integer; r:Double):Boolean;
function  sSetTag(tag:Integer; const s:LongString):Boolean;
function  GetTagColor(tag:Integer):Integer;
function  SetTagColor(tag:Integer; c:Integer):Boolean;
function  GetTagParam(tag:Integer):Double;
function  SetTagParam(tag:Integer; p:Double):Boolean;
function  GetTagTimer(tag:Integer):Double;
function  SetTagTimer(tag:Integer; t:Double):Boolean;
function  GetTagList(P:TText):TText;
procedure ReadTags(const IniFile,SectionName:LongString; Warnings:TText);
procedure ReinitTags;
procedure LockTags;
procedure UnLockTags;
function  SetTagsSpinlockCount(SpinCount:Integer):Integer;

 {
 Atomic Tag Operations.
 op is operator ( + - * / ^ ) for Real,
 op is operator ( + - * / % & | ^ < > ) for Integer,
 Example: iAtomicTagOp(tag,'+',1); - atomic tag increment
 }
function iAtomicTagOp(tag:Integer; op:Char; arg:Integer):Boolean;
function rAtomicTagOp(tag:Integer; op:Char; arg:Double):Boolean;

implementation

const
 AvailTyps = [tag_type_int,tag_type_real,tag_type_string];

var
 myLatch    : TSysCriticalSection = nil;
 myTags     : packed array[TAG_REF_MIN..TAG_REF_MAX] of packed record
               Typ   : Integer;
               Name  : LongString;
               iVal  : Integer;
               rVal  : Double;
               sVal  : LongString;
               Color : Integer;
               Param : Double;
               Timer : Double;
              end;
 myTagCount : TAtomicCounter = nil;
 myHashBugs : TAtomicCounter = nil;
 myHashList : THashList      = nil;
 myTagBugs  : TAtomicCounter = nil;

procedure InitTagCounters;
begin
 LockedInit(myTagCount);
 LockedInit(myHashBugs);
 LockedInit(myTagBugs);
end;

procedure FreeTagCounters;
begin
 LockedFree(myTagCount);
 LockedFree(myHashBugs);
 LockedFree(myTagBugs);
end;

function TagBugs:SizeInt;
begin
 Result:=LockedGet(myTagBugs);
end;

procedure SetTagBugs(aValue:SizeInt);
begin
 LockedSet(myTagBugs,aValue);
end;

procedure InitTags;
begin
 try
  LockTags;
  try
   LockedSet(myTagCount,0);
   SafeFillChar(myTags,sizeof(myTags),0);
   myHashList:=NewHashList(true,HashList_DefaultHasher);
   myHashList.Master:=@myHashList;
   LockedSet(myHashBugs,0);
  finally
   UnLockTags;
  end;
 except
  on E:Exception do BugReport(E,nil,'InitTags');
 end;
end;

procedure FreeTags;
begin
 try
  LockTags;
  try
   ClearTags;
   LockedSet(myHashBugs,0);
   Kill(myHashList);
   LockedSet(myTagCount,0);
   SafeFillChar(myTags,sizeof(myTags),0);
  finally
   UnLockTags;
  end;
 except
  on E:Exception do BugReport(E,nil,'FreeTags');
 end;
end;

procedure ReinitTags;
begin
 try
  LockTags;
  try
   FreeTags;
   InitTags;
  finally
   UnLockTags;
  end;
 except
  on E:Exception do BugReport(E,nil,'ReinitTags');
 end;
end;

procedure LockTags;
begin
 EnterCriticalSection(myLatch);
end;

procedure UnLockTags;
begin
 LeaveCriticalSection(myLatch);
end;

function  SetTagsSpinlockCount(SpinCount:Integer):Integer;
begin
 Result:=-1;
 {$IFDEF WINDOWS}
 if (SpinCount>=0) then Result:=SetCriticalSectionSpinCount(myLatch,SpinCount);
 {$ENDIF ~WINDOWS}
end;

procedure ClearTags;
var tag:Integer;
begin
 try
  EnterCriticalSection(myLatch);
  try
   for tag:=Low(myTags) to High(myTags) do FreeTag(tag);
   myHashList.Clear;
  finally
   LeaveCriticalSection(myLatch);
  end;
 except
  on E:Exception do BugReport(E,nil,'ClearTags');
 end;
end;

function CountTags:Integer;
begin
 Result:=LockedGet(myTagCount);
end;

function UnifyTagAlias(Name:LongString):LongString;
begin
 Result:=UpCaseStr(Trim(Name));
end;

function  FindTag(Name:LongString):Integer;
var tag,i:Integer;
begin
 Result:=0;
 try
  EnterCriticalSection(myLatch);
  try
   Name:=UnifyTagAlias(Name);
   if IsNonEmptyStr(Name) then
   if Assigned(myHashList) then begin
    i:=myHashList.IndexOf(Name);
    if i>=0 then begin
     tag:=myHashList.Links[i];
     if (Low(myTags)<=tag) and (tag<=High(myTags)) then
     if (myTags[tag].Typ in AvailTyps) and IsSameText(myTags[tag].Name,Name)
     then Result:=tag else LockedInc(myHashBugs);
    end;
   end else // obsolete version
   for tag:=Low(myTags) to High(myTags) do
   if (myTags[tag].Typ in AvailTyps) and IsSameText(myTags[tag].Name,Name) then begin
    Result:=tag;
    break;
   end;
  finally
   LeaveCriticalSection(myLatch);
  end;
 except
  on E:Exception do BugReport(E,nil,'FindTag');
 end;
end;

function  InitTag(Name:LongString; Typ:Integer):Integer;
var tag:Integer;
begin
 Result:=0;
 try
  EnterCriticalSection(myLatch);
  try
   Name:=UnifyTagAlias(Name);
   if (Typ in AvailTyps) and IsNonEmptyStr(Name) then begin
    tag:=FindTag(Name);
    if tag>0 then begin
     if TypeTag(tag)=Typ then Result:=tag;
    end else begin
     for tag:=Low(myTags) to High(myTags) do
     if (myTags[tag].Typ=0) and (Length(myTags[tag].Name)=0) then begin
      FreeTag(tag);
      if Assigned(myHashList) then begin
       myHashList.KeyedLinks[Name]:=tag;
      end;
      LockedInc(myTagCount);
      myTags[tag].Name:=Name;
      myTags[tag].Typ:=Typ;
      Result:=tag;
      break;
     end;
    end;
   end;
  finally
   LeaveCriticalSection(myLatch);
  end;
 except
  on E:Exception do BugReport(E,nil,'InitTag');
 end;
end;

function  FreeTag(tag:Integer):Boolean;
begin
 Result:=false;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then
 try
  EnterCriticalSection(myLatch);
  try
   with myTags[tag] do begin
    if Assigned(myHashList) then begin
     if Name<>'' then myHashList.Delete(Name);
    end;
    if Typ>0 then LockedDec(myTagCount);
    Name:='';
    Typ:=0;
    iVal:=0;
    rVal:=0.0;
    sVal:='';
    Color:=0;
    Param:=0.0;
    Timer:=0.0;
   end;
   Result:=true;
  finally
   LeaveCriticalSection(myLatch);
  end;
 except
  on E:Exception do BugReport(E,nil,'FreeTag');
 end;
end;

function  TypeTag(tag:Integer):Integer;
begin
 Result:=0;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  Result:=myTags[tag].Typ;
  LeaveCriticalSection(myLatch);
 end;
end;

function  NameTag(tag:Integer):LongString;
begin
 Result:='';
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ in AvailTyps then Result:=myTags[tag].Name;
  LeaveCriticalSection(myLatch);
 end;
end;

function  iGetTag(tag:Integer):Integer;
begin
 Result:=0;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ = tag_type_int then Result:=myTags[tag].iVal else LockedInc(myTagBugs);
  LeaveCriticalSection(myLatch);
 end;
end;

function  rGetTag(tag:Integer):Double;
begin
 Result:=0.0;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ = tag_type_real then Result:=myTags[tag].rVal else LockedInc(myTagBugs);
  LeaveCriticalSection(myLatch);
 end;
end;

function  sGetTag(tag:Integer):LongString;
begin
 Result:='';
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then
 try
  EnterCriticalSection(myLatch);
  try
   if myTags[tag].Typ = tag_type_string then Result:=myTags[tag].sVal else LockedInc(myTagBugs);
  finally
   LeaveCriticalSection(myLatch);
  end;
 except
  on E:Exception do BugReport(E,nil,'sGetTag');
 end;
end;

function  iSetTag(tag:Integer; i:Integer):Boolean;
begin
 Result:=false;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ = tag_type_int then begin
   myTags[tag].iVal:=i;
   Result:=true;
  end else LockedInc(myTagBugs);
  LeaveCriticalSection(myLatch);
 end;
end;

function  rSetTag(tag:Integer; r:Double):Boolean;
begin
 Result:=false;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ = tag_type_real then begin
   myTags[tag].rVal:=r;
   Result:=true;
  end else LockedInc(myTagBugs);
  LeaveCriticalSection(myLatch);
 end;
end;

function  sSetTag(tag:Integer; const s:LongString):Boolean;
begin
 Result:=false;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then
 try
  EnterCriticalSection(myLatch);
  try
   if myTags[tag].Typ = tag_type_string then begin
    myTags[tag].sVal:=s;
    Result:=true;
   end else LockedInc(myTagBugs);
  finally
   LeaveCriticalSection(myLatch);
  end;
 except
  on E:Exception do BugReport(E,nil,'sSetTag');
 end;
end;

function  GetTagColor(tag:Integer):Integer;
begin
 Result:=0;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ in AvailTyps then Result:=myTags[tag].Color;
  LeaveCriticalSection(myLatch);
 end;
end;

function  SetTagColor(tag:Integer; c:Integer):Boolean;
begin
 Result:=false;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ in AvailTyps then begin
   myTags[tag].Color:=c;
   Result:=true;
  end;
  LeaveCriticalSection(myLatch);
 end;
end;

function  GetTagParam(tag:Integer):Double;
begin
 Result:=0;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ in AvailTyps then Result:=myTags[tag].Param;
  LeaveCriticalSection(myLatch);
 end;
end;

function  SetTagParam(tag:Integer; p:Double):Boolean;
begin
 Result:=false;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ in AvailTyps then begin
   myTags[tag].Param:=p;
   Result:=true;
  end;
  LeaveCriticalSection(myLatch);
 end;
end;

function  GetTagTimer(tag:Integer):Double;
begin
 Result:=0;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ in AvailTyps then Result:=myTags[tag].Timer;
  LeaveCriticalSection(myLatch);
 end;
end;

function  SetTagTimer(tag:Integer; t:Double):Boolean;
begin
 Result:=false;
 if (tag>=Low(myTags)) and (tag<=High(myTags)) then begin
  EnterCriticalSection(myLatch);
  if myTags[tag].Typ in AvailTyps then begin
   myTags[tag].Timer:=t;
   Result:=true;
  end;
  LeaveCriticalSection(myLatch);
 end;
end;

function  GetTagList(P:TText):TText;
var i,m:Integer;
begin
 Result:=P;
 if P is TText then
 try
  m:=3;
  for i:=Low(myTags) to High(myTags) do m:=max(m,Length(NameTag(i)));
  P.Addln(Pad('ИМЯ',m)+' ¦ ТИП     ¦ ЗНАЧЕНИЕ');
  for i:=Low(myTags) to High(myTags) do begin
   case TypeTag(i) of
    tag_type_int:    P.Addln(Pad(NameTag(i),m)+' ¦ INTEGER ¦ '+format('%d',[iGetTag(i)]));
    tag_type_real:   P.Addln(Pad(NameTag(i),m)+' ¦ REAL    ¦ '+format('%g',[rGetTag(i)]));
    tag_type_string: P.Addln(Pad(NameTag(i),m)+' ¦ STRING  ¦ '+sGetTag(i));
   end;
  end;
 except
  on E:Exception do BugReport(E,nil,'GetTagList');
 end;
end;

procedure AddTag(Index:LongInt; const TextLine:LongString; var Terminate:boolean; CustomData:Pointer);
var tag,err:Integer; SName,SType,SValu:LongString; d:LongInt; r:double; tmp:TParsingBuffer;
begin
 if IsNonEmptyStr(TextLine) then
 try
  err:=0; d:=0; r:=0;
  SName:=ExtractWord(1,TextLine,ScanSpaces);
  if SName<>'' then begin
   SType:=UpcaseStr(ExtractWord(2,TextLine,ScanSpaces));
   if SType<>'' then begin
    SValu := ExtractWord(3,TextLine,ScanSpaces);
    if SameText(SType,'INTEGER') then begin
     tag:=findtag(SName);              if tag>0 then inc(err);
     tag:=inittag(SName,tag_type_int); if tag=0 then inc(err);
     if SValu<>'' then
     if not ((ScanVarLongInt(svAsIs,StrCopyBuff(tmp,SValu),'%d',d)<>nil) and iSetTag(tag,d)) then inc(err);
    end else
    if SameText(SType,'REAL') then  begin
     tag:=findtag(SName);               if tag>0 then inc(err);
     tag:=inittag(SName,tag_type_real); if tag=0 then inc(err);
     if SValu<>'' then
     if not ((ScanVarDouble(svAsIs,StrCopyBuff(tmp,SValu),'%f',r)<>nil) and rSetTag(tag,r)) then inc(err);
    end else
    if SameText(SType,'STRING') then  begin
     tag:=findtag(SName);                 if tag>0 then inc(err);
     tag:=inittag(SName,tag_type_string); if tag=0 then inc(err);
     if not sSetTag(tag,SValu) then inc(err);
    end;
   end;
  end;
  if (err<>0) and TText(CustomData).Ok
  then TText(CustomData).Addln('Can~t init TAG -> "'+TextLine+'"');
 except
  on E:Exception do BugReport(E,nil,'AddTag');
 end;
end;

procedure ReadTags(const IniFile,SectionName:LongString; Warnings:TText);
var P:TText;
begin
 P:=ExtractListSection(IniFile,SectionName,efConfig);
 if P.Ok then P.ForEach(AddTag,Warnings);
 Kill(P);
end;

function iAtomicTagOp(tag:Integer; op:Char; arg:Integer):Boolean;
begin
 Result:=false;
 if TypeTag(tag)=tag_type_int then
 try
  if (op in ['/','%']) then if (arg=0) then Exit; // Prevent EDivByZero
  case op of
   '+' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) +   arg); finally UnLockTags; end; end;
   '-' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) -   arg); finally UnLockTags; end; end;
   '*' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) *   arg); finally UnLockTags; end; end;
   '/' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) div arg); finally UnLockTags; end; end;
   '%' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) mod arg); finally UnLockTags; end; end;
   '&' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) and arg); finally UnLockTags; end; end;
   '|' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) or  arg); finally UnLockTags; end; end;
   '^' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) xor arg); finally UnLockTags; end; end;
   '<' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) shl arg); finally UnLockTags; end; end;
   '>' : begin LockTags; try Result:=iSetTag(tag,iGetTag(tag) shr arg); finally UnLockTags; end; end;
  end;
 except
  on E:Exception do BugReport(E,nil,'iAtomicTagOp');
 end;
end;

function rAtomicTagOp(tag:Integer; op:Char; arg:Double):Boolean;
begin
 Result:=false;
 if TypeTag(tag)=tag_type_real then
 try
  case op of
   '+' : begin LockTags; try Result:=rSetTag(tag,rGetTag(tag) +   arg);    finally UnLockTags; end; end;
   '-' : begin LockTags; try Result:=rSetTag(tag,rGetTag(tag) -   arg);    finally UnLockTags; end; end;
   '*' : begin LockTags; try Result:=rSetTag(tag,rGetTag(tag) *   arg);    finally UnLockTags; end; end;
   '/' : begin LockTags; try Result:=rSetTag(tag,rGetTag(tag) /   arg);    finally UnLockTags; end; end;
   '^' : begin LockTags; try Result:=rSetTag(tag,Power(rGetTag(tag),arg)); finally UnLockTags; end; end;
  end;
 except
  on E:Exception do BugReport(E,nil,'rAtomicTagOp');
 end;
end;

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

procedure Init_crw_daqtags;
begin
 InitTagCounters;
 InitCriticalSection(myLatch);
 InitTags;
end;

procedure Free_crw_daqtags;
begin
 FreeTags;
 DoneCriticalSection(myLatch);
 ResourceLeakageLog(Format('%-60s = %d',['DAQ Tags HashList Bugs',LockedGet(myHashBugs)]));
 FreeTagCounters;
end;

initialization

 Init_crw_daqtags;

finalization

 Free_crw_daqtags;

end.

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

