////////////////////////////////////////////////////////////////////////////////
// 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:                                                                   //
// ZeroMQ simplified API to use for DaqPascal pipes.                          //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20260330 - Created by A.K.                                                 //
// 20260425 - smq_recv_multipart, smq_send_multipart                          //
////////////////////////////////////////////////////////////////////////////////

unit _crw_zmqapi; // ZeroMQ simplified API - smq.

{$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_ef, _crw_rtc, _crw_str,
 _crw_zmqlib, _crw_zmqman;

 {
 The smq is (super|safe|string|socket on your choice) message queue.
 That is binding for ZeroMQ. See smq_self_test as example.
 }

function smq_init(arg:LongString):Integer;
function smq_free(soc:Integer):Boolean;
function smq_ref(soc:Integer):TZmqSocket;
function smq_send(soc:Integer; arg:LongString):Integer;
function smq_recv(soc:Integer; len:Integer=0):LongString;
function smq_txcount(soc:Integer):Integer;
function smq_rxcount(soc:Integer):Integer;
function smq_txspace(soc:Integer):Integer;
function smq_rxspace(soc:Integer):Integer;
function smq_ctrl(soc:Integer; arg:LongString):LongString;
function smq_txclear(soc:Integer):Boolean;
function smq_rxclear(soc:Integer):Boolean;

 {
 Receive multipart ZeroMQ message to Lines (reference TText).
 Return summary number of parts received or zero on error(s).
 On exit Lines contains all parts of message, one part per line.
 NB: message parts are BINARY strings and may contain ANY data.
 }
function smq_recv_multipart(sid,Lines:Integer):Integer; overload;
function smq_recv_multipart(sid:Integer; Lines:TStringList):Integer; overload;

 {
 Send multipart ZeroMQ message from Lines (reference TText).
 Return number of sent message parts or 0 on any error occured.
 NB: message parts are BINARY strings and may contain ANY data.
 }
function smq_send_multipart(sid,Lines:Integer):Integer; overload;
function smq_send_multipart(sid:Integer; Lines:TStringList):Integer; overload;

function smq_self_test(typ:Integer=ZMQ_PUB; niter:Integer=100; timeout:Integer=5000):LongString;

implementation

 // zmq PUB bind tcp://*:12345
 // zmq SUB connect tcp://localhost:12345 subscribe *
function ParseArg(arg:LongString; out typ:Integer; out aBind,aConn,aSubs:LongString):Boolean;
var w1,w2,wi,we:LongString; i,skip:Integer;
const argActions='bind,connect,subscribe';
begin
 Result:=False; typ:=-1; aBind:=''; aConn:=''; aSubs:='';
 if IsEmptyStr(arg) or (WordCount(arg,ScanSpaces)<2) then Exit;
 w1:=ExtractWord(1,arg,ScanSpaces);
 w2:=ExtractWord(2,arg,ScanSpaces);
 w2:=ZmqMan.EnsureZmqPrefix(w2);
 if not ZmqMan.IsZmqEngineName(w1) then Exit;
 if not ZmqMan.SockTypMap.HasName(w2) then Exit;
 typ:=ZmqMan.SockTypMap.CodeByName(w2); skip:=0;
 for i:=3 to WordCount(arg,ScanSpaces)-1 do begin
  if (skip>0) then Dec(Skip) else begin
   wi:=ExtractWord(i,arg,ScanSpaces);
   we:=ExtractWord(i+1,arg,ScanSpaces);
   case WordIndex(wi,argActions,ScanSpaces) of
    1: begin
     if ZmqMan.ValidEndpointName(we)
     then aBind+=(ZmqMan.AdaptEndpointName(we)+EOL);
     Inc(skip);
    end;
    2: begin
     if ZmqMan.ValidEndpointName(we)
     then aConn+=(ZmqMan.AdaptEndpointName(we)+EOL);
     Inc(skip);
    end;
    3: begin
     if IsNonEmptyStr(we) and ZmqMan.ValidSubFilter(we)
     then aSubs+=(we+EOL);
     Inc(skip);
    end;
   end;
  end;
 end;
 Result:=True;
end;

function smq_init(arg:LongString):Integer;
var typ,i:Integer; obj:TZmqSocket; sbin,scon,subs:LongString;
begin
 Result:=0;
 if ZmqMan.ValidApi then
 if IsNonEmptyStr(arg) then
 try
  typ:=0; sbin:=''; scon:=''; subs:='';
  if not ParseArg(arg,typ,sbin,scon,subs) then Exit;
  if (typ<0) or not ZmqMan.SockTypMap.HasCode(typ) then Exit;
  obj:=ZmqMan.NewSocket(typ); if (obj.SockRef=nil) then Kill(obj);
  if not Assigned(obj) then Exit;
  for i:=1 to WordCount(sbin,ScanSpaces) do begin
   obj.Bind(ExtractWord(i,sbin,ScanSpaces));
  end;
  for i:=1 to WordCount(scon,ScanSpaces) do begin
   obj.Connect(ExtractWord(i,scon,ScanSpaces));
  end;
  for i:=1 to WordCount(subs,ScanSpaces) do begin
   obj.Subscribe(ExtractWord(i,subs,ScanSpaces));
  end;
  Result:=obj.Ref;
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_init');
 end;
end;

function smq_free(soc:Integer):Boolean;
var obj:TZmqSocket;
begin
 Result:=False;
 if (soc<>0) then
 try
  obj:=smq_ref(soc);
  Result:=Assigned(obj);
  if Result then Kill(obj);
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_free');
 end;
end;

function smq_ref(soc:Integer):TZmqSocket;
var obj:TObject;
begin
 Result:=nil;
 if (soc=0) then Exit;
 obj:=ObjectRegistry[soc];
 if (obj is TZmqSocket) then Result:=TZmqSocket(obj);
end;

function smq_send(soc:Integer; arg:LongString):Integer;
begin
 Result:=0;
 if (soc<>0) then
 try
  Result:=smq_ref(soc).Send(arg);
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_send');
 end;
end;

function smq_recv(soc:Integer; len:Integer):LongString;
begin
 Result:='';
 if (soc<>0) then
 try
  Result:=smq_ref(soc).Recv;
  if InRange(len,1,MaxInt-1)
  then Result:=Copy(Result,1,len);
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_recv');
 end;
end;

function smq_txcount(soc:Integer):Integer;
begin
 Result:=0;
 if (soc<>0) then
 try
  Result:=(1-smq_txspace(soc));
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_txcount');
 end;
end;

function smq_rxcount(soc:Integer):Integer;
begin
 Result:=0;
 if (soc<>0) then
 try
  Result:=BoolToInt(smq_ref(soc).CanPollIn);
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_rxcount');
 end;
end;

function smq_txspace(soc:Integer):Integer;
begin
 Result:=0;
 if (soc<>0) then
 try
  Result:=BoolToInt(smq_ref(soc).CanPollOut);
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_txspace');
 end;
end;

function smq_rxspace(soc:Integer):Integer;
begin
 Result:=0;
 if (soc<>0) then
 try
  Result:=(1-smq_rxcount(soc));
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_rxspace');
 end;
end;

function smq_ctrl(soc:Integer; arg:LongString):LongString;
begin
 Result:='';
 if IsNonEmptyStr(arg) then
 try
  if (soc=0)
  then Result:=ZmqMan.Ctrl(arg)
  else Result:=smq_ref(soc).Ctrl(arg);
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_ctrl');
 end;
end;

function smq_txclear(soc:Integer):Boolean;
begin
 Result:=False;
 if (soc<>0) then
 try
  Result:=smq_ref(soc).Ok;
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_txclear');
 end;
end;

function smq_rxclear(soc:Integer):Boolean;
const Big=1000000; var n:Integer;
begin
 Result:=False;
 if (soc<>0) then
 try
  n:=0;
  Result:=smq_ref(soc).Ok;
  while (smq_rxcount(soc)>0) and (n<Big) do begin
   smq_recv(soc,0);
   Inc(n);
  end;
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_rxclear');
 end;
end;

function smq_self_test(typ:Integer=ZMQ_PUB; niter:Integer=100; timeout:Integer=5000):LongString;
var pub,su1,su2,n0,n1,n2:Integer; ms:Int64; s1,s2:LongString;
begin
 Result:='';
 if (smq_ctrl(0,'ValidApi=1')='1') then
 try
  Result+=(Format('Start smq_self_test(%d,%d,%d):',[typ,niter,timeout])+EOL);
  case typ of
   ZMQ_PUB,ZMQ_SUB: begin
    pub:=smq_init('zmq PUB bind inproc://smq_self_test');
    su1:=smq_init('zmq SUB connect inproc://smq_self_test subscribe *');
    su2:=smq_init('zmq SUB connect inproc://smq_self_test subscribe *');
    try
     ms:=GetTickCount64; n0:=0; n1:=0; n2:=0;
     while (GetTickCount64<ms+timeout) and (n0<niter) and (n1<niter) and (n2<niter) do begin
      // Publisher send a message
      if smq_send(pub,Format('Iteration%d',[n0+1]))>0 then begin
       inc(n0); Result+=(Format('Pub sent Iteration%d',[n0])+EOL);
      end;
      // Subscriber 1 recieve
      if smq_rxcount(su1)>0 then begin // Has events?
       s1:=smq_recv(su1);
       if (s1<>'') then begin
        inc(n1); Result+=(Format('Su1 recv %d = %s',[n1,s1])+EOL);
       end;
      end;
      // Subscriber 2 recieve
      if smq_rxcount(su2)>0 then begin // Has events?
       s2:=smq_recv(su2);
       if (s2<>'') then begin
        inc(n2); Result+=(Format('Su2 recv %d = %s',[n2,s2])+EOL);
       end;
      end;
     end;
     ms:=GetTickCount64-ms;
     Result+=(smq_ctrl(0,'BriefInfo')+EOL);
     Result+=(Format('Pub sent %s msg, %s bytes',[smq_ctrl(pub,'SentCount'),smq_ctrl(pub,'SentBytes')])+EOL);
     Result+=(Format('Su1 recv %s msg, %s bytes',[smq_ctrl(su1,'RecvCount'),smq_ctrl(su1,'RecvBytes')])+EOL);
     Result+=(Format('Su2 recv %s msg, %s bytes',[smq_ctrl(su2,'RecvCount'),smq_ctrl(su2,'RecvBytes')])+EOL);
     Result+=(Format('Done smq_self_test. %d ms elapsed.',[ms])+EOL);
    finally
      smq_free(pub);
      smq_free(su1);
      smq_free(su2);
    end;
   end;
   else Result+=(Format('Error: unsupported test type %d.',[typ])+EOL);
  end;
 except
  on E:Exception do BugReport(E,ZmqMan,'smq_self_test');
 end;
end;

function smq_recv_multipart(sid,Lines:Integer):Integer;
var line,more:LongString;
begin
 Result:=0;
 if smq_ref(sid).Ok and text_ref(Lines).Ok then
 if (smq_rxcount(sid)>0) then
 try
  text_fromstring(Lines,'');
  repeat
   line:=smq_recv(sid,MaxInt);
   more:=smq_ctrl(sid,'RecvMore');
   if (line='') then break;
   if text_addln(Lines,line)
   then Inc(Result);
  until (more<>'1');
 except
  on E:Exception do BugReport(E,nil,'smq_recv_multipart');
 end;
end;

function smq_send_multipart(sid,Lines:Integer):Integer;
var line:LongString; i,sent:Integer;
begin
 Result:=0;
 if smq_ref(sid).Ok and text_ref(Lines).Ok then
 if (smq_txspace(sid)>0) then
 try
  // Drop empty lines
  for i:=text_numln(Lines)-1 downto 0 do begin
   if (text_getln(Lines,i)='')
   then text_delln(Lines,i);
  end;
  // Send lines as multipart message
  for i:=0 to text_numln(Lines)-1 do begin
   line:=text_getln(Lines,i);
   // All but last lines should be marked with "SendMore"
   if (i<text_numln(Lines)-1) then smq_ctrl(sid,'SendMore=1');
   sent:=smq_send(sid,line);
   if (sent<=0) then break;
   Inc(Result);
  end;
 except
  on E:Exception do BugReport(E,nil,'smq_send_multipart');
 end;
end;

function smq_recv_multipart(sid:Integer; Lines:TStringList):Integer;
var part,more:LongString;
begin
 Result:=0;
 if (sid<>0) and (Lines<>nil) then
 try
  Lines.Clear;
  repeat
   part:=smq_recv(sid,MaxInt);
   more:=smq_ctrl(sid,'RecvMore');
   if (part='') then break;
   if (Lines.Add(part)>=0)
   then Inc(Result);
  until (more<>'1');
 except
  on E:Exception do BugReport(E,nil,'smq_recv_multipart');
 end;
end;

function smq_send_multipart(sid:Integer; Lines:TStringList):Integer;
var part:LongString; i,sent:Integer;
begin
 Result:=0;
 if (sid<>0) and (Lines<>nil) then
 try
  // Drop empty lines
  for i:=Lines.Count-1 downto 0 do begin
   if (Lines.Strings[i]='')
   then Lines.Delete(i);
  end;
  // Send lines as multipart message
  for i:=0 to Lines.Count-1 do begin
   part:=Lines.Strings[i];
   // All but last lines should be marked with "SendMore"
   if (i<Lines.Count-1) then smq_ctrl(sid,'SendMore=1');
   sent:=smq_send(sid,part);
   if (sent<=0) then break;
   Inc(Result);
  end;
 except
  on E:Exception do BugReport(E,nil,'smq_send_multipart');
 end;
end;

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

procedure Init_crw_zmqapi;
begin
end;

procedure Free_crw_zmqapi;
begin
end;

initialization

 Init_crw_zmqapi;

finalization

 Free_crw_zmqapi;

end.

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

