initial commit from lost SVN repo
This commit is contained in:
fatalerrors
517
common/udebug.pas
Normal file
517
common/udebug.pas
Normal file
@@ -0,0 +1,517 @@
|
||||
{
|
||||
********************************************************************************
|
||||
|
||||
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.
|
||||
|
||||
Reference in New Issue
Block a user