File: utrace.pp

package info (click to toggle)
lazarus 2.0.10%2Bdfsg-4
  • links: PTS, VCS
  • area: main
  • in suites: bullseye
  • size: 219,188 kB
  • sloc: pascal: 1,867,962; xml: 265,716; cpp: 56,595; sh: 3,005; java: 609; makefile: 568; perl: 297; sql: 222; ansic: 137
file content (71 lines) | stat: -rw-r--r-- 1,525 bytes parent folder | download | duplicates (6)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
{
 *****************************************************************************
  This file is part of the Lazarus Component Library (LCL)

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************
}
unit UTrace;

{$mode objfpc}{$H+}


interface

uses
  sysutils,
  // LazUtils
  LazFileUtils;

type
  TAssertErrorAddrType = Pointer;

  TAssertErrorProc = procedure(Const Msg,FN :ShortString;
        LineNo: LongInt; TheAddr: TAssertErrorAddrType);

var
  TraceFileName : string;
  OldProcPointer : TAssertErrorProc;  // the current Assert Error Handler


implementation

procedure TraceAssertHandler(Const Msg,FN : ShortString;
  LineNo: LongInt; TheAddr: TAssertErrorAddrType);
var
   fileH  : Text;
begin

   if LowerCase(LeftStr(Msg, 6)) = 'trace:' then
   begin
      Assign(fileH, TraceFileName);
      {$I-}
      if TraceFileName <> '' then
         if FileExistsUTF8(TraceFileName) = False then
         begin
            Rewrite(fileH);
            Close(fileH);
         end;

      Append(fileH);

      if ioresult = 0 then
         Writeln(fileH, RightStr(Msg, Length(Msg) - 6));

      Close(fileH);
      {$I+}
   end
   else
      oldProcPointer(Msg, FN, LineNo, TheAddr);

end;


initialization

   TraceFileName := '';
   OldProcPointer := AssertErrorProc;  // the current Assert Error Handler
   AssertErrorProc := @TraceAssertHandler  // set to new Assert Error Handler

end.