yapetavi/udebug.pas

{
********************************************************************************

YaPeTaVi - Yet another Periodic Table Viewer
Copyright (C) 2000-2012 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
All rights reserved.
http://www.geoffray-levasseur.org/

This program is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free Software
Foundation; either version 3 of the License, or (at your option) any later
version.

This program is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
Place - Suite 330, Boston, MA  02111-1307, USA.

********************************************************************************

Description:
   Console debuging facilities

}
unit uDebug;

{$mode objfpc}{$H+}

interface

uses
  Classes;

type
  TVerboseLevel = (vlFull, vlHigh, vlLow, vlNone);

var
  DebugLevel: Integer;
  VerboseLevel: TVerboseLevel;
  LogError: Boolean;
  sLogFileName: string;
  FLogFile: Text;

// init logging facilities
function InitDbg(const FileName: string): Boolean;

// close logging file
procedure TerminateDbg;

// print and log messages
procedure PrintDbg(Mes: string; Verbosity: TVerboseLevel);
procedure PrintDbg(Mes: string);
procedure PrintLnDbg(Mes: string; Verbosity: TVerboseLevel);
procedure PrintLnDbg(Mes: TStringList; Verbosity: TVerboseLevel);
procedure PrintLnDbg(Verbosity: TVerboseLevel);
procedure PrintLnDbg(Mes: string);
procedure PrintDbgStat(Stat: Boolean; Verbosity: TVerboseLevel);
procedure PrintDbgResult(Res: Boolean; Verbosity: TVerboseLevel);
procedure PrintDbgResult(Res: string; Verbosity: TVerboseLevel);

// put full informations about heap inside a string
function GetHeapStatus(aHS: THeapStatus): string;

implementation

uses
  Crt, SysUtils;

const
  dbgStatOk = '-';
  dbgStatWarn = '!';
  dbgOk = 'Ok';
  dbgFail = 'Fail';
  sTimeJump = '           '; //number of space = time length with braces

resourcestring
  rsErrorBase = '*** ERROR: ';
  rsWarningBase = '! WARNING: ';
  rsInfoBase = 'Info: ';
  rsDebugBase = '[Debug]: ';

  rsErrorLogrotate = 'E logrotate failed on file %s';
  rsErrorButLogrotate = 'E logrotate worked but the log file %s still exists';
  rsErrorCreatingLogfile = 'E could not create log file %s';
  rsErrorWritingLogFile = 'E unable to write in logfile %s';
  rsWarningNoLogfile = 'W no log file will be created, ' +
    'logging on stdout (console) only';
  rsInfoLoggingStarted = 'Logging started: %s';
  rsInfoLoggingTerminated = 'Closing log file %s: application terminated';

procedure LoggingError(Msg: string);
begin
  LogError := True;
  PrintLnDbg(Msg, vlLow);
  PrintLnDbg(rsWarningNoLogfile, vlLow);
end;

//create logfile and rotate old ones (10 max)
function InitDbg(const FileName: string): Boolean;
var
  Count: Byte;
  I: Integer;
  F: File;
  Orig, Dest: string;
begin
  {$I-}
  //init some vars
  Count := 1;
  Result := True;
  //first step: do the logrotate (10 logfile max fixed)
  if FileExists(Trim(FileName)) then
    while FileExists(Trim(FileName) + '.' + IntToStr(Count)) do
      Inc(Count)
  else
    Count := 0;
  if Count > 0 then
    for I := Count downto 1 do
    begin
      Assign(F, Trim(FileName) + '.' + IntToStr(I - 1));
      if I = 1 then
        Orig := Trim(FileName)
      else
        Orig := Trim(FileName) + '.' + IntToStr(I - 1);
      Dest := Trim(FileName) + '.' + IntToStr(I);
      if I >= 10 then
        if not FileIsReadOnly(Orig) then
          Erase(F)
        else
        begin
          LoggingError(Format(rsErrorLogrotate, [Trim(FileName)]));
          Result := False;
          Exit;
        end
      else
        if (not FileIsReadOnly(Orig)) and (not FileExists(Dest)) then
          RenameFile(Orig, Dest)
        else
        begin
          LoggingError(Format(rsErrorLogrotate, [Trim(FileName)]));
          Result := False;
          Exit;
        end;
    end;
  {$I+}
  //second step: check if file can be safely created and create it
  if FileExists(Trim(FileName)) then
  begin
    LoggingError(Format(rsErrorButLogrotate, [Trim(FileName)]));
    Result := False;
    Exit;
  end;
  Assign(FLogFile, Trim(FileName));
  {$I-}
  Rewrite(FLogFile);
  {$I+}
  if IOResult <> 0 then
  begin
    LoggingError(Format(rsErrorCreatingLogfile, [Trim(FileName)]));
    Result := False;
    Exit;
  end;
  //third step: write header and assign vars
  LogError := False;
  sLogFileName := Trim(FileName);
  PrintLnDbg(Format(rsInfoLoggingStarted, [sLogFileName]), vlLow);
end;

procedure TerminateDbg;
begin
  PrintLnDbg(Format(rsInfoLoggingTerminated, [sLogFileName]), vlLow);
  if (not LogError) and (Trim(sLogFileName) <> '') then
    CloseFile(FLogFile);
end;

function VerbosityToInt(V: TVerboseLevel): integer;
begin
  Result := 4; //default is all the messages to be shown
  case V of
    vlFull: Result := 4;
    vlHigh: Result := 2;
    vlLow: Result := 1;
    vlNone: Result := 0; //nothing is displayed
  end;
end;

procedure PrintDbg(Mes: string; Verbosity: TVerboseLevel);
var
  I: integer;
  Err: Boolean;
  C: Char;
  LineBegining: Boolean;
begin
  //showing debugging message only if Debug is defined
  {$IFNDEF Debug}
  if LineBegining and (Length(Mes) > 2) and (Mes[2] = ' ') and
    (Mes[1] = 'D') then
    Exit;
  {$ENDIF}
  //if it's not meant to be displayed get out of here
  if VerbosityToInt(Verbosity) > VerbosityToInt(VerboseLevel) then
    Exit;
  //init error state
  {$I-}
  Err := False;
  //display time only if we are on a new line
  try
    LineBegining := WhereX <= 1;
    if LineBegining or ((Length(Mes) > Length(sTimeJump)) and
      (Copy(Mes, 1, Length(sTimeJump)) = sTimeJump)) then
    begin
      Write('[' + TimeToStr(Time) + '] ');
      if (not LogError) and (Trim(sLogFileName) <> '') then
      begin
        Write(FLogFile, '[' + TimeToStr(Time) + '] ');
        Err := (IOResult <> 0) or Err;
      end;
      //this is used in case where indentation is needed in log
      if DebugLevel > 0 then
        for I := 0 to DebugLevel do
        begin
          Write('   '); //this is 3 spaces
          if (not LogError) and (Trim(sLogFileName) <> '') then
          begin
            Write(FLogFile, '   '); //this is 3 spaces
            Err := (IOResult <> 0) or Err;
          end;
        end;
    end;
    // we use the first char to know if it's error warning or info
    if LineBegining and (Length(Mes) > 2) and (Mes[2] = ' ') and
      (Mes[1] in ['E', 'W', 'i', 'D']) then
    begin
      C := Mes[1];
      Mes := Copy(Mes, 3, Length(Mes) - 2);
      case C of
        'E': Mes := rsErrorBase + Mes;
        'W': Mes := rsWarningBase + Mes;
        'i': Mes := rsInfoBase + Mes;
        'D': Mes := rsDebugBase + Mes;
      end;
    end;
    //write the message
    Write(Mes);
    if (not LogError) and (Trim(sLogFileName) <> '') then
    begin
      Write(FLogFile, Mes);
      Err := (IOResult <> 0) or Err;
    end;
  except
    Err := True;
  end;
  {$I+}
  //force truely writing the file
  if not LogError then
    Flush(FLogFile);
  //if error occurs somewhere, trigger an error
  if Err then
    LoggingError(Format(rsErrorWritingLogFile, [sLogFileName]));
end;

procedure PrintDbg(Mes: string);
begin
  PrintDbg(Mes, vlFull);
end;

procedure PrintLnDbg(Mes: TStringList; Verbosity: TVerboseLevel);
var
  I: Integer;
begin
  if VerbosityToInt(Verbosity) > VerbosityToInt(VerboseLevel) then
    Exit;
  for I := 0 to Mes.Count - 1 do
    if I = 0 then
      PrintLnDbg(Mes[I], Verbosity)
    else
      PrintDbg(sTimeJump + Mes[I] + sLineBreak, Verbosity);
end;

procedure PrintLnDbg(Mes: string);
begin
  PrintLnDbg(Mes, vlFull);
end;

procedure PrintLnDbg(Mes: string; Verbosity: TVerboseLevel);
begin
  if VerbosityToInt(Verbosity) > VerbosityToInt(VerboseLevel) then
    Exit;
  PrintDbg(Mes + sLineBreak, Verbosity);
end;

procedure PrintLnDbg(Verbosity: TVerboseLevel);
begin
  if VerbosityToInt(Verbosity) > VerbosityToInt(VerboseLevel) then
    Exit;
  Writeln;
  if (not LogError) and (Trim(sLogFileName) <> '') then
    Writeln(FLogFile);
end;

procedure PrintDbgStat(Stat: Boolean; Verbosity: TVerboseLevel);
begin
  if VerbosityToInt(Verbosity) > VerbosityToInt(VerboseLevel) then
    Exit;
  if Stat then
    PrintDbg(dbgStatOk, Verbosity)
  else
    PrintDbg(dbgStatWarn, Verbosity);
end;

procedure PrintDbgResult(Res: Boolean; Verbosity: TVerboseLevel);
begin
  if VerbosityToInt(Verbosity) > VerbosityToInt(VerboseLevel) then
    Exit;
  if Res then
    PrintLnDbg(dbgOk, Verbosity)
  else
    PrintLnDbg(dbgFail, Verbosity);
end;

procedure PrintDbgResult(Res: string; Verbosity: TVerboseLevel);
begin
  if VerbosityToInt(Verbosity) > VerbosityToInt(VerboseLevel) then
    Exit;
  PrintLnDbg(Res, Verbosity);
end;

function GetHeapStatus(aHS: THeapStatus): string;
begin
  Result := Format(
    'Heap Status:   ' + LineEnding + LineEnding +
    'Addr Space:    ' + #9 + ' %d ' + LineEnding +
    'Uncommitted:   ' + #9 + ' %d ' + LineEnding +
    'Committed:     ' + #9 + ' %d ' + LineEnding +
    'Allocated:     ' + #9 + ' %d ' + LineEnding +
    'Free:          ' + #9 + ' %d ' + LineEnding +
    'Free Small:    ' + #9 + ' %d ' + LineEnding +
    'Free Big:      ' + #9 + ' %d ' + LineEnding +
    'Unused:        ' + #9 + ' %d ' + LineEnding +
    'Overhead:      ' + #9 + ' %d ' + LineEnding +
    'Heap Errorcode:' + #9 + ' %d ',
    [aHS.TotalAddrSpace, aHS.TotalUncommitted, aHS.TotalCommitted,
    aHS.TotalAllocated, aHS.TotalFree, aHS.FreeSmall, aHS.FreeBig,
    aHS.Unused, aHS.Overhead, aHS.HeapErrorCode]);
end;

initialization
  {$IFDEF Debug}
    VerboseLevel := vlFull;
  {$ELSE}
    VerboseLevel := vlLow;
  {$ENDIF}
  DebugLevel := 0;
  LogError := True; //means that we can't write in the log file as it's not opened
end.