1{ 2 ***************************************************************************** 3 This file is part of the Lazarus Component Library (LCL) 4 5 See the file COPYING.modifiedLGPL.txt, included in this distribution, 6 for details about the license. 7 ***************************************************************************** 8} 9unit UTrace; 10 11{$mode objfpc}{$H+} 12 13 14interface 15 16uses 17 sysutils, 18 // LazUtils 19 LazFileUtils; 20 21type 22 TAssertErrorAddrType = Pointer; 23 24 TAssertErrorProc = procedure(Const Msg,FN :ShortString; 25 LineNo: LongInt; TheAddr: TAssertErrorAddrType); 26 27var 28 TraceFileName : string; 29 OldProcPointer : TAssertErrorProc; // the current Assert Error Handler 30 31 32implementation 33 34procedure TraceAssertHandler(Const Msg,FN : ShortString; 35 LineNo: LongInt; TheAddr: TAssertErrorAddrType); 36var 37 fileH : Text; 38begin 39 40 if LowerCase(LeftStr(Msg, 6)) = 'trace:' then 41 begin 42 Assign(fileH, TraceFileName); 43 {$I-} 44 if TraceFileName <> '' then 45 if FileExistsUTF8(TraceFileName) = False then 46 begin 47 Rewrite(fileH); 48 Close(fileH); 49 end; 50 51 Append(fileH); 52 53 if ioresult = 0 then 54 Writeln(fileH, RightStr(Msg, Length(Msg) - 6)); 55 56 Close(fileH); 57 {$I+} 58 end 59 else 60 oldProcPointer(Msg, FN, LineNo, TheAddr); 61 62end; 63 64 65initialization 66 67 TraceFileName := ''; 68 OldProcPointer := AssertErrorProc; // the current Assert Error Handler 69 AssertErrorProc := @TraceAssertHandler // set to new Assert Error Handler 70 71end. 72