MyLog/MyLog.pas

{$I+}
unit MyLog;
{*******************************} interface {**********************************}
Uses
  System.SysUtils,
  System.Variants,
  System.IOUtils,
  System.SyncObjs,
  System.Diagnostics,
  System.Classes,
  System.TypInfo;


  {$define bUseAppendMode}
  // (defined) Append mode: Single-file mode. The file is opened only when writing.
  // (not defined) Normal mode: The file is open all the time
  {$ifdef bUseAppendMode}
   {$define bAppendMultiThreaded} //If define - file to each thread in append mode
  {$endif bUseAppendMode}

var
  WriteTimeToLog         :Boolean = True;
  WriteMillisecondsToLog :Boolean = False;
  WriteTreadIDToLog      :Boolean = False;
  LogElementsSeparator   :String  = ' ';
Procedure WriteMyLog(const aStr :String); overload;
Procedure WriteMyLog(const aArgs :array of const; const aHeader :String = ''); overload;
// Using: WriteMyLogEx(['vMin',vMin,'vMax',vMax], 'Testing') -> Testing vMin=20 vMax=40

// Set<->String miscellaneous functions
function SetToString(Info :PTypeInfo; const SetParam; Brackets :Boolean = true) :String;
// Using: S:=SetToString(TypeInfo(TMySet), MSet, True);
procedure StringToSet(Info :PTypeInfo; var SetParam; const Value :String);
{*****************************} implementation {*******************************}
var
  fInLog       : TCriticalSection;
  fFS          : TFormatSettings;
  fStopWatch   : TStopwatch;
  fLogFile     : TextFile;
  fLogOpened   : Boolean;
  fLogFileName : string;
 {$ifndef bUseAppendMode}
  fFileBuf     : array[1..4096] of Char;
 {$endif bUseAppendMode}

procedure AddStr(var aStr :String; const aAddStr :String); inline;
begin
  aStr := aStr + aAddStr;
end;

{$region 'WriteMyLog'}
Procedure WriteMyLog(const aStr :String); overload;
begin
  if not fLogOpened then
    Exit;
  var vFullStr :String;
  if WriteTimeToLog or WriteMillisecondsToLog then begin
    vFullStr := '[';
    if WriteTimeToLog then
      AddStr(vFullStr, DateTimeToStr(Now, fFS));
    if WriteMillisecondsToLog then begin
      if WriteTimeToLog then
        AddStr(vFullStr, '-');
      AddStr(vFullStr, IntToStr(fStopWatch.ElapsedMilliseconds));
    end;
    AddStr(vFullStr, ']' + aStr);
  end else
    vFullStr := aStr;

  if WriteTreadIDToLog then
    AddStr(vFullStr, '{' + TThread.CurrentThread.ToString + '_' + UIntToStr(TThread.CurrentThread.ThreadID) + '}');

  fInLog.Acquire;
  try
    try
      {$ifdef bUseAppendMode}
       {$ifdef bAppendMultiThreaded}
        var vLogFileName := fLogFileName + '_'+ TThread.CurrentThread.ToString + '_' + UIntToStr(TThread.CurrentThread.ThreadID)+'.log';
       {$else bAppendMultiThreaded}
        var vLogFileName := fLogFileName;
       {$endif bAppendMultiThreaded}
        AssignFile(fLogFile, vLogFileName);
        if FileExists(vLogFileName) then
          Append(fLogFile)
        else
          Rewrite(fLogFile);
        try
          Writeln(fLogFile, vFullStr);
        finally
          CloseFile(fLogFile);
        end;
      {$else bUseAppendMode}
        Writeln(fLogFile, vFullStr);
        Flush(fLogFile);
      {$endif bUseAppendMode}
    except
      // Ignoring all exceptions
    end;{try}
  finally
    fInLog.Release;
  end;
end;


Procedure WriteMyLog(const aArgs :array of const; const aHeader :String = ''); overload;
var
  vArgument :Boolean;
  vStr      :String;

  procedure locIncStr(const aAddStr :String);
  begin
    if vArgument then
      AddStr(vStr, aAddStr)
    else
      AddStr(vStr, '=' + aAddStr + LogElementsSeparator);
  end;

  function locPointerToStr(aPtr :Pointer) :String;
  begin
    if aPtr = nil then
      Exit('nil')
    else
      Exit(IntToHex(UIntPtr(aPtr)));
  end;

  function locObjectToStr(aObj :TObject) :String;
  begin
    if aObj=nil then
      Exit('[]nil')
    else
      Exit('[' + aObj.ClassName + ']' + locPointerToStr(aObj));
  end;

begin
  if not fLogOpened then
    Exit;
  vArgument := True;
  vStr := aHeader;
  if vStr<>'' then
    AddStr(vStr, LogElementsSeparator);
  for var I := Low(aArgs) to High(aArgs) do begin
    with aArgs[I] do begin
      case VType of
          vtUnicodeString : locIncStr(String(UnicodeString(VUnicodeString)));
          vtAnsiString    : locIncStr(String(AnsiString(VAnsiString)));
          vtWideString    : locIncStr(String(WideString(VWideString)));
          vtString        : locIncStr(String(VString^));

          vtInteger       : locIncStr(IntToStr(VInteger));
          vtInt64         : locIncStr(IntToStr(VInt64^));
          vtExtended      : locIncStr(FloatToStr(VExtended^, fFS));
          vtBoolean       : locIncStr(BoolToStr(VBoolean, true));
          vtCurrency      : locIncStr(CurrToStr(VCurrency^, fFS));
          vtObject        : locIncStr(locObjectToStr(VObject));
          vtClass         : locIncStr(VClass.ClassName);
          vtPointer       : locIncStr(locPointerToStr(vPointer));
          vtVariant       : locIncStr(VarToStr(VVariant^));
          vtInterface     : locIncStr(locPointerToStr(vInterface));

          vtChar          : locIncStr(String(AnsiString(VChar)));
          vtPChar         : locIncStr(String(AnsiString(VPChar^)));
          vtWideChar      : locIncStr(String(WideString(VWideChar)));
          vtPWideChar     : locIncStr(String(WideString(VPWideChar^)));
      end;{case}
    end;{with}
    vArgument := not vArgument;
  end;{for i}
  WriteMyLog(vStr);
end;
{$endregion 'WriteMyLog'}

{$region 'Init/Done'}
procedure InitLogSubSystem;
begin
  fLogOpened := True;
  try
    var vTmpPath := TPath.GetTempPath + PathDelim + 'MyLog';
    CreateDir(vTmpPath);
    AddStr(vTmpPath, PathDelim + ExtractFileName(GetModuleName(HInstance)));
    {$ifdef bUseAppendMode}
      {$ifdef bAppendMultiThreaded}
        fLogFileName := vTmpPath;
      {$else bAppendMultiThreaded}
        fLogFileName := vTmpPath + '.log';
      {$endif bAppendMultiThreaded}
    {$else bUseAppendMode}
      var vInd := 0;
      repeat
        fLogFileName := vTmpPath + '.' + IntToStr(vInd) + '.log';
        inc(vInd);
      until not FileExists(fLogFileName);
      AssignFile(fLogFile, fLogFileName);
      System.SetTextBuf(fLogFile, fFileBuf);
      ReWrite(fLogFile);
    {$endif bUseAppendMode}
    fInLog := TCriticalSection.Create;
  except
    fLogOpened := False;
  end;{try}

  if fLogOpened then begin
    fFS := FormatSettings;
    fFS.DecimalSeparator := '.';
    fFS.DateSeparator    := '/';
    fFS.ShortDateFormat  := 'dd/mm/yy';
    fFS.LongDateFormat   := fFS.ShortDateFormat;
    fFS.TimeSeparator    := ':';
    fFS.ShortTimeFormat  := 'hh:nn:ss';
    fFS.LongTimeFormat   := 'hh:nn:ss';
    fStopWatch := TStopwatch.StartNew;
  end;
end;


procedure DoneLogSystem;
begin
  try
    if fLogOpened then begin
      fLogOpened := False;
     {$ifndef bUseAppendMode}
      CloseFile(fLogFile);
     {$endif bUseAppendMode}
      fInLog.Free;
    end;
  except
    {Ignoring}
  end;
end;
{$endregion 'Init/Done'}


{$region 'Set<->String conversion'}
function GetOrdValue(Info: PTypeInfo; const SetParam): Integer;
begin
  Result := 0;

  case GetTypeData(Info)^.OrdType of
    otSByte, otUByte:
      Result := Byte(SetParam);
    otSWord, otUWord:
      Result := Word(SetParam);
    otSLong, otULong:
      Result := Integer(SetParam);
  end;
end;

procedure SetOrdValue(Info: PTypeInfo; var SetParam; Value: Integer);
begin
  case GetTypeData(Info)^.OrdType of
    otSByte, otUByte:
      Byte(SetParam) := Value;
    otSWord, otUWord:
      Word(SetParam) := Value;
    otSLong, otULong:
      Integer(SetParam) := Value;
  end;
end;

function SetToString(Info :PTypeInfo; const SetParam; Brackets :Boolean = true): String;
begin
  Result := '';
  var S :TIntegerSet;
  Integer(S) := GetOrdValue(Info, SetParam);
  var TypeInfo := GetTypeData(Info)^.CompType^;
  for var I := 0 to SizeOf(Integer) * 8 - 1 do
    if I in S then begin
      if Result <> '' then
        Result := Result + ',';
      Result := Result + GetEnumName(TypeInfo, I);
    end;
  if Brackets then
    Result := '[' + Result + ']';
end;

procedure StringToSet(Info: PTypeInfo; var SetParam; const Value: String);
var
  P :PChar;

  function locNextWord(var aP :PChar): String;
  begin
    var I := 0;
    // scan til whitespace
    while not CharInSet(aP[I],[',', ' ', #0,']']) do
      Inc(I);
    SetString(Result, aP, I);
    // skip whitespace
    while CharInSet(aP[I],[',', ' ',']']) do
      Inc(I);
    Inc(aP, I);
  end;

begin
  SetOrdValue(Info, SetParam, 0);
  if Value = '' then
    Exit;

  P := PChar(Value);
  // skip leading bracket and whitespace
  while CharInSet(P^,['[',' ']) do
    Inc(P);
  var EnumInfo :PTypeInfo := GetTypeData(Info)^.CompType^;
  var SetValue :Longint := 0;
  var EnumName := locNextWord(P);
  while EnumName <> '' do begin
    var EnumValue :Longint := GetEnumValue(EnumInfo, EnumName);
    if EnumValue < 0 then begin
      SetOrdValue(Info, SetParam, 0);
      Exit;
    end;
    Include(TIntegerSet(SetValue), EnumValue);
    EnumName := locNextWord(P);
  end;
  SetOrdValue(Info, SetParam, SetValue);
end;
{$endregion 'Set<->String conversion'}

initialization
  InitLogSubSystem;
  WriteMyLog('===================== Start of log ============================');
finalization
  WriteMyLog('===================== End of log ==============================');
  DoneLogSystem;
end.