////////////////////////////////////////////////////////////////////////////////
// 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:                                                                   //
// Debug logger - control over debug messages.                                //
// Usage: see Test_DemoDebugLog.                                              //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20240516 - Created by A.K.                                                 //
// 20240605 - DebugLogAddIncludeFilter,DebugLogAddExcludeFilter               //
////////////////////////////////////////////////////////////////////////////////

unit _crw_dbglog; //  Debug logger.

{$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_fio, _crw_regexp, _crw_utf8;

 {
 ///////////////////////////////////////////////////////////////////////////////
 DebugLog API - библиотека функций управляемого отладочного вывода.
 Функция DebugLog, Get/SetDebugLogMode и другие служат для УПРАВЛЯЕМОГО вывода
 отладочных сообщений, разделенных на КАНАЛЫ (типы сообщений), которые имеют
 постоянное ИМЯ (Name), динамический (постоянный в рамках сеанса) номер (id),
 РЕЖИМ вывода (Mode). Отличие от вывода с помощью Echo, DebugOut, writeln …
 состоит в том, что каналы отладочного вывода DebugLog можно динамически
 включать/отключать/перенаправлять, при этом сохраняется возможность отладки,
 но без потери производительности в случае, если отладка не нужна (отключена).
 Правила использования DebugLog:
 1. В начале программы надо зарегистрировать канал отладочного вывода по имени:
    id:=RegisterDebugLogChannel('ChannelName');
    Идентификатор канала (id) - следует запомнить.
    Идентификатор (id=-1) считается ПРИЗНАКОМ ОШИБКИ.
    Имя канала должно быть идентификатором, как в Pascal.
 2. Надо задать режим отладочного вывода для канала, например:
    SetDebugLogMode(id,0);    // Вывод ОТКЛЮЧЕН (по умолчанию)
    SetDebugLogMode(id,1);    // Вывод в консоль с помощью Echo
    SetDebugLogMode(id,2);    // Вывод в файл …/debug.log через DebugOut(…)
 3. В цикле опроса/выполнения можно делать отладочные выводы, например:
    if DebugLogEnabled(id) then DebugLog(id,…);
 4. Использование if DebugLogEnabled(id) позволяет ускорить выполнение
    путем БЫСТРОЙ проверки режима вывода. Отключенный вывод игнорируется.
    Вызов DebugLog(id,…) направляет отладочные сообщения в тот или иной
    поток вывода в соответствии с режимом вывода GetDebugLogMode(id).
 5. Флаги режима dlm_XXXX управляют способом вывода и форматирования.
    Например, можно отключить метку времени, вывод миллисекунд времени,
    вывод имени канала, или выводить время как число миллисекунд от н.э.
    Типичный вывод сообщения (Message) выглядит примерно так:
    2024.05.17-09:01:22.328 : ChannelName => Message
    С помощью флагов dlm_XXXX можно управлять форматом (меткой времени,
    форматом времени, наличием имени).
 6. DebugLog можно безопасно применять в многопоточной среде.
    Однако вызовы Find/RegisterDebugLogChannel желательно делать при старте
    программы в основном потоке и далее использовать полученный при вызове
    идентификатор канала (id).
 7. Удаление каналов отладочного вывода не предусмотрено,
    инициализация делается на все время работы программы.
    Емкость каналов (DebugLogCapacity) достаточна для большинства
    задач при разумном (обоснованном) применении каналов отладки.
 8. Для отладоччного вывода можно назначать фильтры (Include/Exclude), которые
    могут включать /РегулярныеВыражения/ - см. описание regexp_init.
    Отладочный вывод печатается, если фильтры не заданы или допускают вывод.
    Включающий фильтр (Inclide) допускает вывод, если верен хоть один фильтр.
    Исключающий фильтр (Exclude) запрещает вывод, если верен хоть один фильтр.
 9. Каналы отладки и фильтры можно очищать вызовом ClearDebugLogChannels(…).
 ///////////////////////////////////////////////////////////////////////////////
 }

const                   // DebugLog dimension constants:
 DebugLogNameLeng=31;   // Max length of DebugLog channel name.
 DebugLogCapacity=1024; // Max number of channels for DebugLog.

const                      // DebugLog Mode flags:
 dlm_Echo     = $00000001; // Output with Echo
 dlm_DebugOut = $00000002; // Output with DebugOut(…)
 dlm_StdOut   = $00000004; // Output with StdOut
 dlm_StdErr   = $00000008; // Output with StdErr
 dlm_NoTime   = $01000000; // Do not add time stamp
 dlm_NoName   = $02000000; // Do not add chaannel name
 dlm_NoMsec   = $04000000; // No msec time (round to sec)
 dlm_MSecNow  = $08000000; // Use flat msecnow since Xmas
 dlm_OutMask  = $00FFFFFF; // Mask for output modes
 dlm_FmtMask  = $FF000000; // Mask for format modes

const // Prompt separator after TimeStamp.
 DebugLogTimeSeparator:LongString=' : ';

const // Prompt separator after TimeStamp and Name.
 DebugLogNameSeparator:LongString=' => ';

 ///////////////////////////////////////////
 // Debug Log channel (id) with message Msg.
 // It's general function for debug logging.
 ///////////////////////////////////////////
function DebugLog(id:Integer; Msg:LongString):Integer;

 // Get DebugLog mode of channel (id).
 // Mode uses to control output stream & format.
function  GetDebugLogMode(id:Integer):Integer;

 // Get DebugLog name of channel (id).
 // Name uses to identify debug log channel.
function  GetDebugLogName(id:Integer):LongString;

 // Set DebugLog mode of channel (id).
 // Mode uses to control output stream & format.
procedure SetDebugLogMode(id:Integer; Mode:Integer);

 // Set DebugLog name of channel (id).
 // Name uses to identify debug log channel.
procedure SetDebugLogName(id:Integer; Name:LongString);

 // DebugLog enabled for this channel (id)?
 // Uses for fast check before DebugLog call.
function  DebugLogEnabled(id:Integer):Boolean;

 ///////////////////////////////////////////////////////////////////////////////
 // Note:
 // Find/RegisterDebugLog should be called once at object/thread start.
 // Do not use it in thread loop because it's not fully threadsafe and
 // can give wrong channel number in multithreaded applications.
 // But DebugLog,Get/SetDebugLogMode are threadsafe.
 ///////////////////////////////////////////////////////////////////////////////

 // Find DebugLog channel by Name or return -1 if not exist.
function FindDebugLogChannel(Name:LongString):Integer;

 // Register DebugLog channel by Name if one not found.
 // Return channel number (id) to use with DebugLog call.
function RegisterDebugLogChannel(Name:LongString):Integer;

 // Get list of registered DebugLog channels; What=1/2=channels/filters.
function ListDebugLogChannels(What:Integer=-1):LongString;

 // Clear DebugLog params; What=1/2=channels/filters.
function ClearDebugLogChannels(What:Integer=-1):Integer;

 // Add include filter to pass DebugLog messages by pattern.
function DebugLogAddIncludeFilter(aPattern:LongString):Boolean;

 // Add exclude filter to skip DebugLog messages by pattern.
function DebugLogAddExcludeFilter(aPattern:LongString):Boolean;

 // Is string (aStr) match to (in,ex) filters of DebugLog?
function DebugLogStringIsMatch(const aStr:LongString):Boolean;

 // Test and demo on DebugLog usage.
procedure Test_DemoDebugLog;

implementation

type // String type for log channels names.
 TLogNameString = String[DebugLogNameLeng];

type // Log channel item type.
 TDebugLogRec = packed record
  Mode : Integer;
  Name : TLogNameString;
 end;

var // The array to register (Mode,Name) per DebugLog channel.
 TheDebugLogChannels:packed array[0..DebugLogCapacity-1] of TDebugLogRec;

const
 TheDebugLogLatch:TLatch=nil;
 TheInFilter:TStringList=nil;
 TheExFilter:TStringList=nil;

function ClearDebugLogChannels(What:Integer=-1):Integer;
var i:Integer;
begin
 Result:=0;
 if HasFlags(What,1) then begin
  SafeFillChar(TheDebugLogChannels,SizeOf(TheDebugLogChannels),0);
  LiftFlags(Result,1);
 end;
 if HasFlags(What,2) then begin
  TheDebugLogLatch.Lock;
  try
   for i:=0 to TheInFilter.Count-1 do regexp_free(PointerToPtrInt(TheInFilter.Objects[i]));
   for i:=0 to TheExFilter.Count-1 do regexp_free(PointerToPtrInt(TheExFilter.Objects[i]));
   TheInFilter.Clear;
   TheExFilter.Clear;
  finally
   TheDebugLogLatch.UnLock;
  end;
  LiftFlags(Result,2);
 end;
end;

procedure InitDebugLogChannels;
begin
 TheDebugLogLatch:=NewLatch;
 TheDebugLogLatch.Master:=@TheDebugLogLatch;
 TheInFilter:=TStringList.Create;
 TheInFilter.CaseSensitive:=true;
 TheInFilter.Duplicates:=dupIgnore;
 TheInFilter.OwnsObjects:=False;
 TheExFilter:=TStringList.Create;
 TheExFilter.CaseSensitive:=true;
 TheExFilter.Duplicates:=dupIgnore;
 TheExFilter.OwnsObjects:=False;
 ClearDebugLogChannels;
end;

procedure FreeDebugLogChannels;
begin
 ClearDebugLogChannels;
 Kill(TheInFilter);
 Kill(TheExFilter);
 Kill(TheDebugLogLatch);
end;

function ValidateChannelName(Name:LongString):LongString;
var i:Integer;
begin
 Result:=Trim(Name);
 if (Result='') then Exit;
 Result:=Copy(Result,1,DebugLogNameLeng);
 if IsLexeme(Result,lex_Name) then Exit;
 for i:=1 to Length(Result) do begin
  if (i=1) and IsLexeme(Result[i],lex_Name) then continue;
  if (i>1) and IsLexeme(Result[i],lex_Word) then continue;
  Result[i]:='_';
 end;
end;

function GetDebugLogMode(id:Integer):Integer;
begin
 if InRange(id,Low(TheDebugLogChannels),High(TheDebugLogChannels))
 then Result:=TheDebugLogChannels[id].Mode
 else Result:=0;
end;

function GetDebugLogName(id:Integer):LongString;
begin
 if InRange(id,Low(TheDebugLogChannels),High(TheDebugLogChannels))
 then Result:=TheDebugLogChannels[id].Name
 else Result:='';
end;

procedure SetDebugLogMode(id:Integer; Mode:Integer);
begin
 if InRange(id,Low(TheDebugLogChannels),High(TheDebugLogChannels))
 then TheDebugLogChannels[id].Mode:=Mode;
end;

procedure SetDebugLogName(id:Integer; Name:LongString);
begin
 if InRange(id,Low(TheDebugLogChannels),High(TheDebugLogChannels))
 then TheDebugLogChannels[id].Name:=ValidateChannelName(Name);
end;

function DebugLogEnabled(id:Integer):Boolean;
begin
 if InRange(id,Low(TheDebugLogChannels),High(TheDebugLogChannels))
 then Result:=HasFlags(TheDebugLogChannels[id].Mode,dlm_OutMask)
 else Result:=false;
end;

function SearchDebugLogChannel(Name:LongString; CanCreate:Boolean):Integer;
var i:Integer;
begin
 Result:=-1;
 TheDebugLogLatch.Lock;
 try
  Name:=ValidateChannelName(Name); if (Name='') then Exit;
  for i:=Low(TheDebugLogChannels) to High(TheDebugLogChannels) do begin
   if SameText(Name,GetDebugLogName(i)) then Exit(i);
   if CanCreate and (GetDebugLogName(i)='') then begin
    SetDebugLogName(i,Name);
    SetDebugLogMode(i,0);
    Exit(i);
   end;
  end;
 finally
  TheDebugLogLatch.UnLock;
 end;
end;

function RegisterDebugLogChannel(Name:LongString):Integer;
begin
 Result:=SearchDebugLogChannel(Name,true);
end;

function FindDebugLogChannel(Name:LongString):Integer;
begin
 Result:=SearchDebugLogChannel(Name,false);
end;

function ListDebugLogChannels(What:Integer=-1):LongString;
var Lines:TStringList; i,Mode:Integer; Name:LongString;
begin
 Result:='';
 Lines:=TStringList.Create;
 TheDebugLogLatch.Lock;
 try
  if HasFlags(What,1) then
  for i:=Low(TheDebugLogChannels) to High(TheDebugLogChannels) do begin
   Name:=GetDebugLogName(i);
   Mode:=GetDebugLogMode(i);
   if (Name='') then Continue;
   Lines.Add(Format('%4d $%8.8x %s',[i,Mode,Name]));
  end;
  if HasFlags(What,2) then
  if (TheInFilter.Count>0) then begin
   Lines.Add('IncludeFilter:');
   for i:=0 to TheInFilter.Count-1 do Lines.Add(' '+TheInFilter.Strings[i]);
  end;
  if HasFlags(What,2) then
  if (TheExFilter.Count>0) then begin
   Lines.Add('ExcludeFilter:');
   for i:=0 to TheExFilter.Count-1 do Lines.Add(' '+TheExFilter.Strings[i]);
  end;
  Result:=Lines.Text;
 finally
  TheDebugLogLatch.UnLock;
  Lines.Free;
 end;
end;

function DebugLogAddIncludeFilter(aPattern:LongString):Boolean;
begin
 Result:=false;
 if (aPattern<>'') then
 try
  TheDebugLogLatch.Lock;
  try
   if (TheInFilter.IndexOf(aPattern)<0) then begin
    if (Pos('/',aPattern)=1) and (CountChars(aPattern,['/'])>1)
    then TheInFilter.AddObject(aPattern,PtrIntToPointer(regexp_init(0,aPattern)))
    else TheInFilter.Add(aPattern);
    Result:=true;
   end;
  finally
   TheDebugLogLatch.Unlock;
  end;
 except
  on E:Exception do BugReport(E,nil,'DebugLogAddIncludeFilter');
 end;
end;

function DebugLogAddExcludeFilter(aPattern:LongString):Boolean;
begin
 Result:=false;
 if (aPattern<>'') then
 try
  TheDebugLogLatch.Lock;
  try
   if (TheExFilter.IndexOf(aPattern)<0) then begin
    if (Pos('/',aPattern)=1) and (CountChars(aPattern,['/'])>1)
    then TheExFilter.AddObject(aPattern,PtrIntToPointer(regexp_init(0,aPattern)))
    else TheExFilter.Add(aPattern);
    Result:=true;
   end;
  finally
   TheDebugLogLatch.Unlock;
  end;
 except
  on E:Exception do BugReport(E,nil,'DebugLogAddExcludeFilter');
 end;
end;

function IsMatch(const aPattern,aStr:LongString; rex:PtrInt):Boolean;
begin
 Result:=false;
 if (aPattern<>'') and (aStr<>'') then begin
  if (rex=0) then begin
   if utf8_valid(aPattern) and utf8_valid(aStr)
   then Result:=(Pos(utf8_uppercase(aPattern),utf8_uppercase(aStr))>0)
   else Result:=(PosI(aPattern,aStr)>0);
  end else begin
   Result:=regexp_test(rex,aStr);
  end;
 end;
end;

function DebugLogStringIsMatch(const aStr:LongString):Boolean;
var i:Integer;
begin
 Result:=false;
 if (aStr<>'') then
 try
  if (TheInFilter.Count=0) and (TheExFilter.Count=0)
  then Exit(true); // No Inclide/Exclude filters
  TheDebugLogLatch.Lock;
  try
   Result:=true;
   for i:=0 to TheInFilter.Count-1 do begin
    Result:=    IsMatch(TheInFilter.Strings[i],aStr,
        PointerToPtrInt(TheInFilter.Objects[i]));
    if Result then Break;
   end;
   if Result then
   for i:=0 to TheExFilter.Count-1 do begin
    Result:=not IsMatch(TheExFilter.Strings[i],aStr,
        PointerToPtrInt(TheExFilter.Objects[i]));
    if not Result then Break;
   end;
  finally
   TheDebugLogLatch.Unlock;
  end;
 except
  on E:Exception do BugReport(E,nil,'DebugLogAddExcludeFilter');
 end;
end;

//////////////////////////
// DebugLog implementation
//////////////////////////

type
 TDLIRec=record
  Mode : Integer;
  Time : String[31];
  Name : TLogNameString;
 end;

function DebugLogIterator(n:SizeInt; Line:LongString; Custom:Pointer):Boolean;
var Msg:LongString;
begin
 Result:=true; Msg:='';
 if Assigned(Custom) then
 with TDLIRec(Custom^) do begin
  if (Time<>'') then Msg:=Time+DebugLogTimeSeparator;
  if (Name<>'') then Msg:=Msg+Name;
  if (Msg<>'') then Msg:=Msg+DebugLogNameSeparator;
  Msg:=Msg+Line;
  if (n=0) and not DebugLogStringIsMatch(Msg) then Exit(false);
  if HasFlags(Mode,dlm_Echo) then Echo(Msg);
  if HasFlags(Mode,dlm_StdOut) then StdOutPrintLn(Msg);
  if HasFlags(Mode,dlm_StdErr) then StdErrPrintLn(Msg);
  if HasFlags(Mode,dlm_DebugOut) then DebugOutText(stdfDebug,Msg);
  if (n=0) and (Time<>'') then Time:=StringOfChar(' ',Length(Time));
 end;
end;

function DebugLog(id:Integer; Msg:LongString):Integer;
var R:TDLIRec;
begin
 Result:=0;
 if (Msg<>'') and DebugLogEnabled(id) then
 try
  R:=Default(TDLIRec);
  try
   R.Mode:=GetDebugLogMode(id);
   if HasFlags(R.Mode,dlm_NoName) then R.Name:='' else R.Name:=GetDebugLogName(id);
   if HasFlags(R.Mode,dlm_NoTime) then R.Time:='' else begin
    if HasFlags(R.Mode,dlm_MSecNow)
    then R.Time:=Format('%d',[IntMSecNow]) else
    if HasFlags(R.Mode,dlm_NoMsec)
    then R.Time:=StdDateTimeStr(0,0)
    else R.Time:=StdDateTimeStr(0,4);
   end;
   Result:=ForEachStringLine(Msg,DebugLogIterator,@R);
  finally
   R.Time:=''; R.Name:='';
  end;
 except
  on E:Exception do BugReport(E,nil,'DebugLog');
 end;
end;

///////////////////////////////////
// Test_DemoDebugLog implementation
///////////////////////////////////

type
 TTestDebugLogThread=class(TThread)
 public
  procedure Execute; override;
 end;

procedure TTestDebugLogThread.Execute;
var n1,n2,i,n:Integer;
begin
 n:=10;
 Echo('DemoDebugLog thread Started.');
 // At start find Logger channels.
 n1:=FindDebugLogChannel('TestDemoLog1');
 n2:=FindDebugLogChannel('TestDemoLog2');
 // Now make log output.
 for i:=1 to n do begin
  // DebugLogEnabled uses for fast check before call DebugLog.
  if DebugLogEnabled(n1)
  then DebugLog(n1,'Iteration '+IntToStr(i));
  Sleep(50);
  if DebugLogEnabled(n2)
  then DebugLog(n2,'Iteration '+IntToStr(i)+EOL+'Line 2'+EOL+'Line 3');
  Sleep(50);
 end;
 Echo('DemoDebugLog thread Stopped.');
 Terminate;
end;

procedure Test_DemoDebugLog;
var n1,n2:Integer; Tester:TThread;
begin
 Echo('Test_DebugLog:');
 // At start register Logger channels.
 n1:=RegisterDebugLogChannel('TestDemoLog1');
 n2:=RegisterDebugLogChannel('TestDemoLog2');
 // Enable Echo for this channels.
 SetDebugLogMode(n1,dlm_Echo);
 SetDebugLogMode(n2,dlm_Echo);
 // List DebugLog channels.
 Echo(ListDebugLogChannels);
 // Start thread to make log output.
 Tester:=TTestDebugLogThread.Create(true);
 Tester.FreeOnTerminate:=true;
 Tester.Suspended:=false;
end;

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

procedure Init_crw_dbglog;
begin
 InitDebugLogChannels;
end;

procedure Free_crw_dbglog;
begin
 FreeDebugLogChannels;
end;

initialization

 Init_crw_dbglog;

finalization

 Free_crw_dbglog;

end.

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

