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

SPackGui (common files)
Copyright (C) 2009-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>

http://www.geoffray-levasseur.org/
http://0.tuxfamilly.org/

This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software.  You can  use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".

As a counterpart to the access to the source code and  rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty  and the software's author,  the holder of the
economic rights,  and the successive licensors  have only  limited
liability.

In this respect, the user's attention is drawn to the risks associated
with loading,  using,  modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean  that it is complicated to manipulate,  and  that  also
therefore means  that it is reserved for developers  and  experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and,  more generally, to use and operate it in the
same conditions as regards security.

The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.

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

Description:
   Console debuging facilities

********************************************************************************
}
unit uDebug;

{$include defines.inc}

interface

uses
  Classes, syncobjs, SysUtils, CustApp;

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

  THandleException = class
  private
    FHandleExceptionLock: TCriticalSection;
    FHandleExceptionMessage: String;
    FHandleExceptionBackTrace: TStringList;
    FOldExceptionHandler: TExceptionEvent;
    procedure ShowException;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
    procedure HandleException(Sender: TObject; E: Exception);
    procedure ThreadException(E: Exception; AThread: TThread);
  end;

var
  iDebugLevel: Integer;
  vlVerboseLevel: TVerboseLevel;
  bLogError: Boolean;
  sLogFileName: string;
  tLogFile: Text;

  heHandleException: THandleException;
  ExceptionProc: TExceptionEvent;
  DebugLock: TCriticalSection;

// 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);

// handle manual exceptions when we want
procedure HandleManualException(E: Exception);

// show the call stack
procedure DumpCallStack;

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

implementation

uses
  Crt, Dialogs, Forms, uStrings;

procedure DumpCallStack;
var
  I: Longint;
  prevbp: Pointer;
  CallerFrame, CallerAddress, bp: Pointer;
  Report: TStringList;
const
  MaxDepth = 30;
begin
  Report := TStringList.Create;
  bp := get_frame;
  // This trick skip SendCallstack item
  // bp:= get_caller_frame(get_frame);
  try
    prevbp := bp - 1;
    I := 0;
    while bp > prevbp do
    begin
      CallerAddress := get_caller_addr(bp);
      CallerFrame := get_caller_frame(bp);
      if CallerAddress = nil then
        Break;
      Report.Add(BackTraceStrFunc(CallerAddress));
      Inc(I);
      if (I >= MaxDepth) or (CallerFrame = nil) then
        Break;
      prevbp := bp;
      bp := CallerFrame;
    end;
  except
    { prevent endless dump if an exception occured }
  end;
  PrintLnDbg(Report, vlNone);
  Report.Free;
end;

procedure DumpExceptionCallStack(E: Exception);
var
  I: Integer;
  Frames: PPointer;
  Report: TStringList;
begin
  Report := TStringList.Create;
  Report.Add(rsErrorUnhandledException);
  if E <> nil then
  begin
    Report.Add(rsExceptionClass + E.ClassName);
    Report.Add(rsMessage + E.Message);
  end;
  Report.Add(rsStackTrace);
  Report.Add(BackTraceStrFunc(ExceptAddr));
  Frames := ExceptFrames;
  for I := 0 to ExceptFrameCount - 1 do
    Report.Add(BackTraceStrFunc(Frames[I]));
  PrintLnDbg(Report, vlNone);
  Report.Free;
  {$IFNDEF Debug}
     Halt; // End of program execution (if not debugging)
  {$ENDIF}
end;


procedure HandleManualException(E: Exception);
begin
  heHandleException.HandleException(nil, E);
end;

constructor THandleException.Create;
begin
  FHandleExceptionLock := TCriticalSection.Create;
  FOldExceptionHandler := ExceptionProc;
  ExceptionProc := @HandleException;
end;

destructor THandleException.Destroy;
begin
  inherited;
  ExceptionProc := FOldExceptionHandler;
  FreeAndNil(FHandleExceptionLock);
end;

procedure THandleException.HandleException(Sender: TObject; E: Exception);
begin
  if MainThreadID = GetCurrentThreadId then
  begin
    DumpExceptionCallStack(E);
    MessageDlg(E.Message, mtError, [MBOK], 0); //create something better
  end else
  begin
    FHandleExceptionLock.Acquire;
    try
      FHandleExceptionMessage := E.Message;
      DumpExceptionCallStack(E);
      DumpCallStack;
      MessageDlg(FHandleExceptionMessage, mtError, [MBOK], 0); //same
    finally
      FHandleExceptionLock.Release;
    end;
  end;
end;

procedure THandleException.ThreadException(E: Exception; AThread: TThread);
var
  Frames: PPointer;
  I: Integer;
begin
  PrintLnDbg(Format(rsErrorInThread, [AThread.ClassName]));
  if MainThreadID = GetCurrentThreadId then
  begin
    DumpExceptionCallStack(E);
    MessageDlg(E.Message, mtError, [MBOK], 0); //create something better
  end else
  begin
    FHandleExceptionLock.Acquire;
    try
      FHandleExceptionBackTrace := TStringList.Create;
      FHandleExceptionMessage := E.Message;
      FHandleExceptionBackTrace.Add(rsErrorUnhandledException);
      if E <> nil then
      begin
        FHandleExceptionBackTrace.Add(rsExceptionClass + E.ClassName);
        FHandleExceptionBackTrace.Add(rsMessage + E.Message);
      end;
      FHandleExceptionBackTrace.Add(rsStackTrace);
      FHandleExceptionBackTrace.Add(BackTraceStrFunc(ExceptAddr));
      Frames := ExceptFrames;
      for I := 0 to ExceptFrameCount - 1 do
        FHandleExceptionBackTrace.Add(BackTraceStrFunc(Frames[I]));
      TThread.Synchronize(AThread, @ShowException);
    finally
      FHandleExceptionLock.Release;
    end;
  end;
end;

procedure THandleException.ShowException;
begin
  PrintLnDbg(FHandleExceptionBackTrace, vlNone);
  MessageDlg(FHandleExceptionMessage, mtError, [MBOK], 0); //create something better
end;

procedure LoggingError(Msg: string);
begin
  bLogError := 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(tLogFile, Trim(FileName));
  {$I-}
  Rewrite(tLogFile);
  {$I+}
  if IOResult <> 0 then
  begin
    LoggingError(Format(rsErrorCreatingLogfile, [Trim(FileName)]));
    Result := False;
    Exit;
  end;
  //third step: write header and assign vars
  bLogError := False;
  sLogFileName := Trim(FileName);
  PrintLnDbg(Format(rsInfoLoggingStarted, [sLogFileName]), vlLow);
end;

procedure TerminateDbg;
begin
  PrintLnDbg(Format(rsInfoLoggingTerminated, [sLogFileName]), vlLow);
  if (not bLogError) and (Trim(sLogFileName) <> '') then
    CloseFile(tLogFile);
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(vlVerboseLevel) then
    Exit;
  //init error state
  {$I-}
  Err := False;
  DebugLock.Acquire;
  //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 bLogError) and (Trim(sLogFileName) <> '') then
      begin
        Write(tLogFile, '[' + TimeToStr(Time) + '] ');
        Err := (IOResult <> 0) or Err;
      end;
      //this is used in case where indentation is needed in log
      if iDebugLevel > 0 then
        for I := 0 to iDebugLevel do
        begin
          Write('   '); //this is 3 spaces
          if (not bLogError) and (Trim(sLogFileName) <> '') then
          begin
            Write(tLogFile, '   '); //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'{$IFDEF Debug}, 'D'{$ENDIF}]) then
    begin
      C := Mes[1];
      Mes := Copy(Mes, 3, Length(Mes) - 2);
      case C of
        'E': Mes := rsBaseError + Mes;
        'W': Mes := rsBaseWarning + Mes;
        'i': Mes := rsBaseInfo + Mes;
        {$IFDEF Debug}
        'D': Mes := rsBaseDebug + Mes;
        {$ENDIF}
      end;
    end;
    //write the message
    Write(Mes);
    if (not bLogError) and (Trim(sLogFileName) <> '') then
    begin
      Write(tLogFile, Mes);
      Err := (IOResult <> 0) or Err;
    end;
  except
    Err := True;
  end;
  {$I+}
  //if error occurs somewhere, trigger an error
  if Err then
    LoggingError(Format(rsErrorWritingLogFile, [sLogFileName]));
  //force truely writing the file
  if (not bLogError) and (Trim(sLogFileName) <> '') then
    Flush(tLogFile);
  DebugLock.Release;
end;

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

procedure PrintLnDbg(Mes: TStringList; Verbosity: TVerboseLevel);
var
  I: Integer;
begin
  if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) 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(vlVerboseLevel) then
    Exit;
  PrintDbg(Mes + sLineBreak, Verbosity);
end;

procedure PrintLnDbg(Verbosity: TVerboseLevel);
begin
  if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) then
    Exit;
  Writeln;
  if (not bLogError) and (Trim(sLogFileName) <> '') then
    Writeln(tLogFile);
end;

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

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

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

function GetHeapStatus(aHS: THeapStatus): string;
begin
  Result := Format(rsHeapStatusDetails,
    [aHS.TotalAddrSpace, aHS.TotalUncommitted, aHS.TotalCommitted,
    aHS.TotalAllocated, aHS.TotalFree, aHS.FreeSmall, aHS.FreeBig,
    aHS.Unused, aHS.Overhead, aHS.HeapErrorCode]);
end;

initialization
  ExceptionProc := Application.OnException;
  {$IFDEF DEBUG}
    vlVerboseLevel := vlFull;
  {$ELSE}
    vlVerboseLevel := vlLow;
  {$ENDIF}
  iDebugLevel := 0;
  bLogError := True; //means that we can't write in the log file as it's not opened
  sLogFileName := '';
  heHandleException := THandleException.Create;
  DebugLock := TCriticalSection.Create;
finalization
  DebugLock.Free;
  FreeAndNil(heHandleException);
end.