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