rtclog.pas

Delphi快速开发Web Server

{
  @html(<b>)
  Log File Creation
  @html(</b>)
  - Copyright (c) Danijel Tkalcec
  @html(<br><br>)

  This unit gives you thread-safe Log writing support.
}
unit rtcLog;

{$INCLUDE rtcDefs.inc}

interface

uses
  rtcTrashcan,
  SysUtils, Windows,

  {$IFDEF IDE_1}
  FileCtrl,
  {$ENDIF}

  rtcSyncObjs;

var
  { Write Logged exception into the Log file?
    Dafault=True. By changing this to False will remove any
    Connection component exceptions from the Log file. }
  LOG_EXCEPTIONS:boolean=True;

  { Sub-Folder inside AppFileName's directory where all LOG files will be stored.
    If you want LOG files to be created in the same folder as AppFile (EXE/DLL),
    set LOG_FOLDER to an empty string before calling "StartLog".
    For this value to have any effect, you need to set it before calling "StartLog". }
  LOG_FOLDER:string='LOG';

{ Write exception with a short string description into the Global App Log file.
  This procedure will have no effect if Log writer not started
  (by calling StartLog) or LOG_EXCEPTIONS is @false }
procedure Log(s:string; E:Exception; const name:string=''); overload;

{ Write message into the Global App Log file.
  This procedure will have no effect if Log writer not started. }
procedure Log(s:string; const name:string=''); overload;

{ Write message into the Log file for the current date.
  This procedure will have no effect if Log writer not started. }
procedure XLog(s:string; const name:string=''); overload;

{ Before Log() procedures will have any effect,
  you have to call this procedure to start the Log writer.
  Without it, no Log file. }
procedure StartLog;

{ To stop Log file creation, simply call this procedure.
  To continue log writing, call StartLog. }
procedure StopLog;

implementation

uses
  rtcInfo;

var
  ThrCS:TRtcCritSec;
  doLog:boolean=False;
  MyLogFolder:string='';

procedure StartLog;
  begin
  ThrCS.Enter;
  try
    doLog:=True;
  finally
    ThrCS.Leave;
    end;
  end;

procedure StopLog;
  begin
  ThrCS.Enter;
  try
    doLog:=False;
  finally
    ThrCS.Leave;
    end;
  end;

procedure OpenLogFile(var f:TextFile; s:string);
  begin
  if MyLogFolder='' then
    begin
    MyLogFolder:=ExtractFilePath(AppFileName);
    if Copy(MyLogFolder,length(MyLogFolder),1)<>'\' then
      MyLogFolder:=MyLogFolder+'\';

    if LOG_FOLDER<>'' then
      begin
      MyLogFolder:=MyLogFolder+LOG_FOLDER;

      if not DirectoryExists(MyLogFolder) then
        if not CreateDir(MyLogFolder) then
          begin
          MyLogFolder:=GetTempDirectory;
          if Copy(myLogFolder,length(MyLogFolder),1)<>'\' then
            MyLogFolder:=MyLogFolder+'\';
          MyLogFolder:=MyLogFolder+LOG_FOLDER;
          if not DirectoryExists(MyLogFolder) then
            CreateDir(MyLogFolder);
          end;
      end;
    end;
  Assign(f,myLogFolder+'\'+ExtractFileName(AppFileName)+'.'+s);
  {$I-}
  Append(f);
  {$I+}
  if IOREsult<>0 then
    begin
    Rewrite(f);
    end;
  end;

procedure XLog(s:string; const name:string='');
  var
    f:TextFile;
    d:TDateTime;
    fname,
    s2:string;
  begin
  ThrCS.Enter;
  try
    if not doLog then Exit; // Exit here !!!!

    try
      d:=Now;
      s2:=FormatDateTime('yyyy-mm-dd hh:nn:ss; ',d);

      if name<>'' then
        fname:=FormatDateTime('yyyy_mm_dd',d)+'.'+name+'.log'
      else
        fname:=FormatDateTime('yyyy_mm_dd',d)+'.log';

      OpenLogFile(f,fname);
      try
        Writeln(f,s2+s);
      finally
        CloseFile(f);
        end;
    except
      end;

  finally
    ThrCS.Leave;
    end;
  end;

procedure Log(s:string; const name:string='');
  var
    f:TextFile;
    d:TDateTime;
    fname,
    s2:string;
  begin
  ThrCS.Enter;
  try
    if not doLog then Exit; // Exit here !!!!

    try
      d:=Now;
      s2:=FormatDateTime('yyyy-mm-dd hh:nn:ss; ',d);
      if name<>'' then
        fname:=name+'.log'
      else
        fname:='log';

      OpenLogFile(f,fname);
      try
        Writeln(f,s2+s);
      finally
        CloseFile(f);
        end;
    except
      end;

  finally
    ThrCS.Leave;
    end;
  end;

procedure Log(s:string; E:Exception; const name:string='');
  begin
  if LOG_EXCEPTIONS then
    Log(s+' Exception! '+E.ClassName+': '+E.Message,name);
  end;

initialization
ThrCS:=TRtcCritSec.Create;
finalization
Garbage(ThrCS);
end.