utils/uutlLogger.pas

unit uutlLogger;

{ Package:      Utils
  Prefix:       utl - UTiLs
  Beschreibung: diese Unit enthält das Logging-Framework

Anzusprechen über Singleton: utlLogger

Die einzelnen Level sind über die Methoden Debug(), Info(), Warning(), Error() zugänglich.
Sender: entweder eigener Text oder TObject-Referenz, dann wird Klassenname und Adresse ausgegeben.

Log-Zeilen werden nicht weiter behandelt, sondern an Consumer verteilt.
Es können beliebig viele Consumer per RegisterConsumer für bestimmte Level registriert werden.
Jeder davon bekommt die Rohdaten eines Logeintrags auf einer beobachteten Stufe.
Zum einfacheren Ausgeben gibt es eine Hilfsfunktion FormatLine vom Logger.

Vordefinierte Consumer:
  TutlFileLogger      - schreibt in eine Datei
  TutlConsoleLogger   - schreibt auf die Konsole (ggf. mit CriticalSection)
  TutlEventLogger     - ruft beliebiges Event auf
}

{$mode objfpc}{$H+}

interface

uses
  {$IFDEF MSWINDOWS}Windows{$ELSE}unix{$ENDIF},
  Classes, SysUtils, uutlGenerics, syncobjs, uutlCommon;

type
  TutlLogLevel = (llDebug, llInfo, llWarning, llError);
  TutlLogLevels = set of TutlLogLevel;

const
  utlLogLevel_Any     = [low(TutlLogLevel)..high(TutlLogLevel)];
  utlLogLevel_NoDebug = utlLogLevel_Any - [llDebug];
  utlLogLevelStrings: array[TutlLogLevel] of string =
    ('Debug','Info','Warning','Error');

type
  TutlLogger = class;
  IutlLogConsumer = interface(IUnknown)
    procedure WriteLog(const aLogger: TutlLogger; const aTime:TDateTime; const aLevel:TutlLogLevel; const aSender: string; const aMessage: String);
  end;

  TutlLogConsumerList = specialize TutlInterfaceList<IutlLogConsumer>;

  { TutlLogger }

  TutlLogger = class(TObject)
  private
    fConsumersLock: TCriticalSection;
    fConsumers: array[TutlLogLevel] of TutlLogConsumerList;
  protected
    class function FormatTime(const aTime:TDateTime): string;
    function FormatSender(const aSender: TObject): String;
    procedure InternalLog(const aLevel:TutlLogLevel; const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
    procedure InternalLog(const aLevel:TutlLogLevel; const aSender: String; const aMessage: String; const aParams: array of const); overload;
  public
    procedure RegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter:TutlLogLevels=utlLogLevel_Any);
    procedure UnRegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter:TutlLogLevels=utlLogLevel_Any);

    class function FormatLine(const aTime:TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String): string;

    procedure Debug(const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
    procedure Debug(const aSender: String; const aMessage: String; const aParams: array of const); overload;
    procedure Log(const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
    procedure Log(const aSender: String; const aMessage: String; const aParams: array of const); overload;
    procedure Warning(const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
    procedure Warning(const aSender: String; const aMessage: String; const aParams: array of const); overload;
    procedure Error(const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
    procedure Error(const aSender: String; const aMessage: String; const aParams: array of const); overload;
    procedure Error(const aSender: String; const aMessage: String; const aException: Exception); overload;
    procedure Error(const aSender: TObject; const aMessage: String; const aException: Exception); overload;

    constructor Create;
    destructor Destroy; override;
  end;

  { TutlFileLogger }

  TutlFileLoggerMode = (flmCreateNew, flmAppend);
  TutlFileLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer)
  private
    fStream: TFileStream;
    fAutoFlush: boolean;
  protected
    procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
  public
    constructor Create(const aFilename: String; const aMode: TutlFileLoggerMode);
    destructor Destroy; override;

    procedure Flush(); overload;
  published
    property AutoFlush:boolean read fAutoFlush write fAutoFlush;
  end;

  { TutlConsoleLogger }

  TutlConsoleLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer)
  private
    fFreeConsoleCS: boolean;
    fConsoleCS: TCriticalSection;
    fOnBeforeLog: TNotifyEvent;
    fOnAfterLog: TNotifyEvent;
  protected
    procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String); virtual;
  public
    property ConsoleCS: TCriticalSection read fConsoleCS;
    property OnBeforeLog: TNotifyEvent read fOnBeforeLog write fOnBeforeLog;
    property OnAfterLog: TNotifyEvent read fOnAfterLog write fOnAfterLog;

    constructor Create(const aSection: TCriticalSection = nil);
    destructor Destroy; override;
  end;

  { TutlEventLogger }
  TutlWriteLogEvent = procedure (const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String) of object;
  TutlEventLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer)
  private
    fWriteLogEvt: TutlWriteLogEvent;
  protected
    procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
  public
    constructor Create(const aEvent: TutlWriteLogEvent);
  end;

function utlLogger: TutlLogger;
function utlCreateStackTrace(const aMessage: String; const aException: Exception): String;

implementation

var
  utlLogger_Singleton: TutlLogger;

function utlLogger: TutlLogger;
begin
  if not Assigned(utlLogger_Singleton) then
    utlLogger_Singleton:= TutlLogger.Create;
  Result:= utlLogger_Singleton;
end;

function utlCreateStackTrace(const aMessage: String; const aException: Exception): String;
var
  i: Integer;
  frames: PPointer;
begin
  result := aMessage;
  if Assigned(aException) then
    result := result + sLineBreak +
    '  Exception: ' + aException.ClassName + sLineBreak +
    '  Message:   ' + aException.Message + sLineBreak +
    '  Thread:    ' + IntToStr(GetCurrentThreadId) + sLineBreak +
    '  StackTrace:' + sLineBreak +
    '    ' + BackTraceStrFunc(ExceptAddr)
  else
    result := result + 'no Exception passed';
  frames := ExceptFrames;
  for i := 0 to ExceptFrameCount-1 do
    result := result + sLineBreak + '    ' + BackTraceStrFunc(frames[i]);
end;

{ TutlFileLogger }

function FileFlush(Handle: THandle): Boolean;
begin
  {$IFDEF MSWINDOWS}
  Result:= FlushFileBuffers(Handle);
  {$ELSE}
  Result:= (fpfsync(Handle) = 0);
  {$ENDIF}
end;

procedure TutlFileLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime;
  const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
var
  buf: AnsiString;
begin
  if Assigned(fStream) then begin
    buf:= aLogger.FormatLine(aTime, aLevel, aSender, aMessage)+sLineBreak;
    fStream.Write(buf[1], Length(buf));
    if AutoFlush then
      FileFlush(fStream.Handle);
  end;
end;

constructor TutlFileLogger.Create(const aFilename: String; const aMode: TutlFileLoggerMode);
const
  RIGHTS: Cardinal = {$IFNDEF UNIX}fmShareDenyWrite{$ELSE}%0100100100 {-r--r--r--}{$ENDIF};
begin
  try
    if (aMode = flmCreateNew) or not FileExists(aFilename) then begin
      if FileExists(aFilename) then
        DeleteFile(aFilename);
      fStream := TFileStream.Create(aFilename, fmCreate{$IFNDEF UNIX} or RIGHTS{$ENDIF}, RIGHTS)
    end else
      fStream := TFileStream.Create(aFilename, fmOpenReadWrite{$IFNDEF UNIX} or RIGHTS{$ENDIF}, RIGHTS);
    fStream.Position := fStream.Size;
  except
    on e: EStreamError do begin
      fStream:= nil;
      utlLogger.Error('Logger', 'Could not open log file "%s"',[aFilename]);
    end else
      raise;
  end;
  AutoFlush:=true;
end;

destructor TutlFileLogger.Destroy;
begin
  FreeAndNil(fStream);
  inherited Destroy;
end;

procedure TutlFileLogger.Flush;
begin
  if Assigned(fStream) then
    FileFlush(fStream.Handle);
end;

{ TutlConsoleLogger }

procedure TutlConsoleLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime;
  const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
begin
  fConsoleCS.Acquire;
  try
    if Assigned(fOnBeforeLog) then
      fOnBeforeLog(Self);
    WriteLn(aLogger.FormatLine(aTime, aLevel, aSender, aMessage));
    if Assigned(fOnAfterLog) then
      fOnAfterLog(Self);
  finally
    fConsoleCS.Release;
  end;
end;

constructor TutlConsoleLogger.Create(const aSection: TCriticalSection);
begin
  inherited Create;
  if Assigned(aSection) then
    fConsoleCS:= aSection
  else
    fConsoleCS:= TCriticalSection.Create;
  fFreeConsoleCS:= not Assigned(aSection);
end;

destructor TutlConsoleLogger.Destroy;
begin
  if fFreeConsoleCS then
    FreeAndNil(fConsoleCS);
  inherited Destroy;
end;

{ TutlEventLogger }

procedure TutlEventLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime;
  const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
begin
  fWriteLogEvt(aLogger,aTime, aLevel, aSender, aMessage);
end;

constructor TutlEventLogger.Create(const aEvent: TutlWriteLogEvent);
begin
  inherited Create;
  fWriteLogEvt:= aEvent;
end;

{ TutlLogger }

procedure TutlLogger.RegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter: TutlLogLevels);
var
  ll: TutlLogLevel;
begin
  fConsumersLock.Acquire;
  try
    for ll:= low(ll) to high(ll) do
      if (ll in aFilter) and (fConsumers[ll].IndexOf(aConsumer)<0) then
        fConsumers[ll].Add(aConsumer);
  finally
    fConsumersLock.Release;
  end;
  if llDebug in aFilter then
    aConsumer.WriteLog(Self, Now, llDebug, 'System', 'Attached to Logger');
end;

procedure TutlLogger.UnRegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter: TutlLogLevels);
var
  ll: TutlLogLevel;
begin
  fConsumersLock.Acquire;
  try
    for ll:= low(ll) to high(ll) do
      if ll in aFilter then
        fConsumers[ll].Remove(aConsumer);
  finally
    fConsumersLock.Release;
  end;
end;

class function TutlLogger.FormatTime(const aTime: TDateTime): string;
begin
  Result:= FormatDateTime('hh:nn:ss.zzz',aTime);
end;

function TutlLogger.FormatSender(const aSender: TObject): String;
begin
  if Assigned(aSender) then
    result := format('%s[0x%P]', [aSender.ClassName, Pointer(aSender)])
  else
    result := '';
end;

class function TutlLogger.FormatLine(const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String): string;
begin
  if (aSender <> '') then
    Result:= Format('%s %-9s %s: %s', [FormatTime(aTime), UpperCase(utlLogLevelStrings[aLevel]), aSender, aMessage])
  else
    Result:= Format('%s %-9s %s', [FormatTime(aTime), UpperCase(utlLogLevelStrings[aLevel]), aMessage]);
end;

procedure TutlLogger.InternalLog(const aLevel: TutlLogLevel; const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
  InternalLog(aLevel, FormatSender(aSender), aMessage, aParams);
end;

procedure TutlLogger.InternalLog(const aLevel: TutlLogLevel; const aSender: String; const aMessage: String; const aParams: array of const);
var
  msg: string;
  when: TDateTime;
  i: integer;
begin
  if length(aParams) = 0 then
    msg:= aMessage
  else
    msg:= Format(aMessage, aParams);
  when:= Now;

  fConsumersLock.Acquire;
  try
    for i:= 0 to fConsumers[aLevel].Count-1 do begin
      fConsumers[aLevel][i].WriteLog(Self, when, aLevel, aSender, msg);
    end;
  finally
    fConsumersLock.Release;
  end;
end;

procedure TutlLogger.Debug(const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
  InternalLog(llDebug, aSender, aMessage, aParams);
end;

procedure TutlLogger.Debug(const aSender: String; const aMessage: String; const aParams: array of const);
begin
  InternalLog(llDebug, aSender, aMessage, aParams);
end;

procedure TutlLogger.Log(const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
  InternalLog(llInfo, aSender, aMessage, aParams);
end;

procedure TutlLogger.Log(const aSender: String; const aMessage: String; const aParams: array of const);
begin
  InternalLog(llInfo, aSender, aMessage, aParams);
end;

procedure TutlLogger.Warning(const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
  InternalLog(llWarning, aSender, aMessage, aParams);
end;

procedure TutlLogger.Warning(const aSender: String; const aMessage: String; const aParams: array of const);
begin
  InternalLog(llWarning, aSender, aMessage, aParams);
end;

procedure TutlLogger.Error(const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
  InternalLog(llError, aSender, aMessage, aParams);
end;

procedure TutlLogger.Error(const aSender: String; const aMessage: String; const aParams: array of const);
begin
  InternalLog(llError, aSender, aMessage, aParams);
end;

procedure TutlLogger.Error(const aSender: String; const aMessage: String; const aException: Exception);
begin
  InternalLog(llError, aSender, utlCreateStackTrace(aMessage, aException), []);
end;

procedure TutlLogger.Error(const aSender: TObject; const aMessage: String; const aException: Exception);
begin
  InternalLog(llError, aSender, utlCreateStackTrace(aMessage, aException), []);
end;

constructor TutlLogger.Create;
var
  ll: TutlLogLevel;
begin
  inherited Create;
  fConsumersLock:= TCriticalSection.Create;
  fConsumersLock.Acquire;
  try
    for ll:= low(ll) to high(ll) do begin
      fConsumers[ll]:= TutlLogConsumerList.Create;
    end;
  finally
    fConsumersLock.Release;
  end;
end;

destructor TutlLogger.Destroy;
var
  ll: TutlLogLevel;
begin
  fConsumersLock.Acquire;
  try
    for ll:= low(ll) to high(ll) do begin
      fConsumers[ll].Clear;
      FreeAndNil(fConsumers[ll]);
    end;
  finally
    fConsumersLock.Release;
  end;
  FreeAndNil(fConsumersLock);
  inherited Destroy;
end;

finalization
  FreeAndNil(utlLogger_Singleton);

end.