← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/lazutils/lazlogger.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/lazutils/lazlogger.pas
 
1
unit LazLogger;
 
2
{$mode objfpc}{$H+}
 
3
 
 
4
interface
 
5
 
 
6
uses
 
7
  Classes, SysUtils, FileUtil, types, math, LazLoggerBase, LazClasses;
 
8
 
 
9
type
 
10
 
 
11
  PLazLoggerLogGroup = LazLoggerBase.PLazLoggerLogGroup;
 
12
 
 
13
{$DEFINE USED_BY_LAZLOGGER}
 
14
{$I LazLoggerIntf.inc}
 
15
 
 
16
 
 
17
function DbgStr(const StringWithSpecialChars: string): string; overload;
 
18
function DbgStr(const StringWithSpecialChars: string; StartPos, Len: PtrInt): string; overload;
 
19
function DbgStr(const p: PChar; Len: PtrInt): string; overload;
 
20
function DbgWideStr(const StringWithSpecialChars: widestring): string; overload;
 
21
 
 
22
function ConvertLineEndings(const s: string): string;
 
23
procedure ReplaceSubstring(var s: string; StartPos, Count: SizeInt;
 
24
                           const Insertion: string);
 
25
 
 
26
type
 
27
 
 
28
  { TLazLoggerFileHandle }
 
29
 
 
30
  TLazLoggerFileHandle = class
 
31
  private
 
32
    FActiveLogText: PText; // may point to stdout
 
33
    FCloseLogFileBetweenWrites: Boolean;
 
34
    FLogName: String;
 
35
    FLogText: Text;
 
36
    FLogTextInUse, FLogTextFailed: Boolean;
 
37
    FUseStdOut: Boolean;
 
38
    procedure DoOpenFile;
 
39
    procedure DoCloseFile;
 
40
    function GetWriteTarget: TLazLoggerWriteTarget;
 
41
    procedure SetCloseLogFileBetweenWrites(AValue: Boolean);
 
42
    procedure SetLogName(AValue: String);
 
43
  public
 
44
    constructor Create;
 
45
    destructor Destroy; override;
 
46
    procedure OpenFile;
 
47
    procedure CloseFile;
 
48
 
 
49
    procedure WriteToFile(const s: string); inline;
 
50
    procedure WriteLnToFile(const s: string); inline;
 
51
 
 
52
    property  LogName: String read FLogName write SetLogName;
 
53
    property  UseStdOut: Boolean read FUseStdOut write FUseStdOut;
 
54
    property  CloseLogFileBetweenWrites: Boolean read FCloseLogFileBetweenWrites write SetCloseLogFileBetweenWrites;
 
55
    property  WriteTarget: TLazLoggerWriteTarget read GetWriteTarget;
 
56
    property  ActiveLogText: PText read FActiveLogText;
 
57
  end;
 
58
 
 
59
  { TLazLoggerFile }
 
60
 
 
61
  TLazLoggerFile = class(TLazLoggerWithGroupParam)
 
62
  private
 
63
    FFileHandle: TLazLoggerFileHandle;
 
64
    FOnDbgOut: TLazLoggerWriteEvent;
 
65
    FOnDebugLn: TLazLoggerWriteEvent;
 
66
 
 
67
 
 
68
    FEnvironmentForLogFileName: String;
 
69
    //FLogName: String;
 
70
 
 
71
    FParamForLogFileName: String;
 
72
    FGetLogFileNameDone: Boolean;
 
73
 
 
74
    FDebugNestLvl: Integer;
 
75
    FDebugIndent: String;
 
76
    FDebugNestAtBOL: Boolean;
 
77
 
 
78
    function  GetFileHandle: TLazLoggerFileHandle;
 
79
    procedure SetEnvironmentForLogFileName(AValue: String);
 
80
    procedure SetFileHandle(AValue: TLazLoggerFileHandle);
 
81
    procedure SetParamForLogFileName(AValue: String);
 
82
    function  GetLogFileName: string;
 
83
  private
 
84
    // forward to TLazLoggerFileHandle
 
85
    function  GetCloseLogFileBetweenWrites: Boolean;
 
86
    function  GetLogName: String;
 
87
    function  GetUseStdOut: Boolean;
 
88
    procedure SetCloseLogFileBetweenWrites(AValue: Boolean);
 
89
    procedure SetLogName(AValue: String);
 
90
    procedure SetUseStdOut(AValue: Boolean);
 
91
  protected
 
92
    procedure DoInit; override;
 
93
    procedure DoFinsh; override;
 
94
 
 
95
    procedure IncreaseIndent; overload; override;
 
96
    procedure DecreaseIndent; overload; override;
 
97
    procedure IncreaseIndent(LogGroup: PLazLoggerLogGroup); overload; override;
 
98
    procedure DecreaseIndent(LogGroup: PLazLoggerLogGroup); overload; override;
 
99
    procedure IndentChanged; override;
 
100
    procedure CreateIndent; virtual;
 
101
 
 
102
    procedure DoDbgOut(const s: string); override;
 
103
    procedure DoDebugLn(const s: string); override;
 
104
    procedure DoDebuglnStack(const s: string); override;
 
105
 
 
106
    property FileHandle: TLazLoggerFileHandle read GetFileHandle write SetFileHandle;
 
107
  public
 
108
    constructor Create;
 
109
    destructor Destroy; override;
 
110
    procedure Assign(Src: TLazLogger); override;
 
111
    // A param on the commandline, that may contain the name (if not already set)
 
112
    // example/default: --debug-log=
 
113
    property  ParamForLogFileName: String read FParamForLogFileName write SetParamForLogFileName;
 
114
    // Environment to specify log file name (* replaced by param(0))
 
115
    // example/default: *_debuglog
 
116
    property  EnvironmentForLogFileName: String read FEnvironmentForLogFileName write SetEnvironmentForLogFileName; // "*" will be replaced by appname
 
117
 
 
118
    property  OnDebugLn: TLazLoggerWriteEvent read FOnDebugLn write FOnDebugLn;
 
119
    property  OnDbgOut:  TLazLoggerWriteEvent read FOnDbgOut write FOnDbgOut;
 
120
 
 
121
    // forward to TLazLoggerFileHandle
 
122
    property  LogName: String read GetLogName write SetLogName;
 
123
    property  UseStdOut: Boolean read GetUseStdOut write SetUseStdOut;
 
124
    property  CloseLogFileBetweenWrites: Boolean read GetCloseLogFileBetweenWrites write SetCloseLogFileBetweenWrites;
 
125
  end;
 
126
 
 
127
function GetDebugLogger: TLazLoggerFile; inline;
 
128
procedure SetDebugLogger(ALogger: TLazLoggerFile);
 
129
 
 
130
property DebugLogger: TLazLoggerFile read GetDebugLogger write SetDebugLogger;
 
131
 
 
132
implementation
 
133
 
 
134
{$I LazLoggerImpl.inc}
 
135
 
 
136
{$ifdef wince}
 
137
const
 
138
  Str_LCL_Debug_File = 'lcldebug.log';
 
139
{$endif}
 
140
 
 
141
(* Creation / Access *)
 
142
 
 
143
function CreateDebugLogger: TRefCountedObject;
 
144
begin
 
145
  Result := TLazLoggerFile.Create;
 
146
  TLazLoggerFile(Result).Assign(GetExistingDebugLogger);
 
147
end;
 
148
 
 
149
function GetDebugLogger: TLazLoggerFile; inline;
 
150
begin
 
151
  Result := TLazLoggerFile(LazLoggerBase.DebugLogger);
 
152
end;
 
153
 
 
154
procedure SetDebugLogger(ALogger: TLazLoggerFile);
 
155
begin
 
156
  LazLoggerBase.DebugLogger := ALogger;
 
157
end;
 
158
 
 
159
(* ArgV *)
 
160
 
 
161
 
 
162
{ TLazLoggerFileHandle }
 
163
 
 
164
procedure TLazLoggerFileHandle.DoOpenFile;
 
165
var
 
166
  fm: Byte;
 
167
begin
 
168
  if FActiveLogText <> nil then exit;
 
169
 
 
170
  if (not FLogTextFailed) and (length(FLogName)>0)
 
171
     {$ifNdef WinCE}
 
172
     and (DirPathExists(ExtractFileDir(FLogName)))
 
173
     {$endif}
 
174
  then begin
 
175
    fm:=Filemode;
 
176
    try
 
177
      {$ifdef WinCE}
 
178
        Assign(FLogText, FLogName);
 
179
        {$I-}
 
180
        Append(FLogText);
 
181
        if IOResult <> 0 then
 
182
          Rewrite(FLogText);
 
183
        {$I+}
 
184
      {$else}
 
185
        Filemode:=fmShareDenyNone;
 
186
        Assign(FLogText, FLogName);
 
187
        if FileExistsUTF8(FLogName) then
 
188
          Append(FLogText)
 
189
        else
 
190
          Rewrite(FLogText);
 
191
      {$endif}
 
192
      FActiveLogText := @FLogText;
 
193
      FLogTextInUse := true;
 
194
    except
 
195
      FLogTextInUse := false;
 
196
      FActiveLogText := nil;
 
197
      FLogTextFailed := True;
 
198
      // Add extra line ending: a dialog will be shown in windows gui application
 
199
      writeln(StdOut, 'Cannot open file: ', FLogName+LineEnding);
 
200
    end;
 
201
    Filemode:=fm;
 
202
  end;
 
203
 
 
204
  if (not FLogTextInUse) and (FUseStdOut) then
 
205
  begin
 
206
    if not(TextRec(Output).Mode=fmClosed) then
 
207
      FActiveLogText := @Output;
 
208
  end;
 
209
end;
 
210
 
 
211
procedure TLazLoggerFileHandle.DoCloseFile;
 
212
begin
 
213
  if FLogTextInUse then begin
 
214
    try
 
215
      Close(FLogText);
 
216
    except
 
217
    end;
 
218
    FLogTextInUse := false;
 
219
  end;
 
220
  FActiveLogText := nil;
 
221
end;
 
222
 
 
223
function TLazLoggerFileHandle.GetWriteTarget: TLazLoggerWriteTarget;
 
224
begin
 
225
  Result := lwtNone;
 
226
  if FActiveLogText = @Output then
 
227
    Result := lwtStdOut
 
228
  else
 
229
  if FLogTextInUse then
 
230
    Result := lwtTextFile;
 
231
end;
 
232
 
 
233
procedure TLazLoggerFileHandle.SetCloseLogFileBetweenWrites(AValue: Boolean);
 
234
begin
 
235
  if FCloseLogFileBetweenWrites = AValue then Exit;
 
236
  FCloseLogFileBetweenWrites := AValue;
 
237
  if FCloseLogFileBetweenWrites then
 
238
    DoCloseFile;
 
239
end;
 
240
 
 
241
procedure TLazLoggerFileHandle.SetLogName(AValue: String);
 
242
begin
 
243
  if FLogName = AValue then Exit;
 
244
  DoCloseFile;
 
245
 
 
246
  FLogName := AValue;
 
247
 
 
248
  FLogTextFailed := False;
 
249
end;
 
250
 
 
251
constructor TLazLoggerFileHandle.Create;
 
252
begin
 
253
  FLogTextInUse := False;
 
254
  FLogTextFailed := False;
 
255
  {$ifdef WinCE}
 
256
  FLogName := ExtractFilePath(ParamStr(0)) + Str_LCL_Debug_File;
 
257
  FUseStdOut := False;
 
258
  FCloseLogFileBetweenWrites := True;
 
259
  {$else}
 
260
  FLogName := '';
 
261
  FUseStdOut := True;
 
262
  FCloseLogFileBetweenWrites := False;
 
263
  {$endif}
 
264
end;
 
265
 
 
266
destructor TLazLoggerFileHandle.Destroy;
 
267
begin
 
268
  inherited Destroy;
 
269
  DoCloseFile;
 
270
end;
 
271
 
 
272
procedure TLazLoggerFileHandle.OpenFile;
 
273
begin
 
274
  if not CloseLogFileBetweenWrites then
 
275
    DoOpenFile;
 
276
end;
 
277
 
 
278
procedure TLazLoggerFileHandle.CloseFile;
 
279
begin
 
280
  DoCloseFile;
 
281
  FLogTextFailed := False;
 
282
end;
 
283
 
 
284
procedure TLazLoggerFileHandle.WriteToFile(const s: string);
 
285
begin
 
286
  DoOpenFile;
 
287
  if FActiveLogText = nil then exit;
 
288
 
 
289
  Write(FActiveLogText^, s);
 
290
 
 
291
  if FCloseLogFileBetweenWrites then
 
292
    DoCloseFile;
 
293
end;
 
294
 
 
295
procedure TLazLoggerFileHandle.WriteLnToFile(const s: string);
 
296
begin
 
297
  DoOpenFile;
 
298
  if FActiveLogText = nil then exit;
 
299
 
 
300
  WriteLn(FActiveLogText^, s);
 
301
 
 
302
  if FCloseLogFileBetweenWrites then
 
303
    DoCloseFile;
 
304
end;
 
305
 
 
306
{ TLazLoggerFile }
 
307
 
 
308
function TLazLoggerFile.GetFileHandle: TLazLoggerFileHandle;
 
309
begin
 
310
  if FFileHandle = nil then
 
311
    FFileHandle := TLazLoggerFileHandle.Create;
 
312
  Result := FFileHandle;
 
313
end;
 
314
 
 
315
procedure TLazLoggerFile.SetEnvironmentForLogFileName(AValue: String);
 
316
begin
 
317
  if FEnvironmentForLogFileName = AValue then Exit;
 
318
  Finish;
 
319
  FGetLogFileNameDone := False;
 
320
  FEnvironmentForLogFileName := AValue;
 
321
end;
 
322
 
 
323
procedure TLazLoggerFile.SetFileHandle(AValue: TLazLoggerFileHandle);
 
324
begin
 
325
  if FFileHandle = AValue then Exit;
 
326
  Finish;
 
327
  FreeAndNil(FFileHandle);
 
328
  FFileHandle := AValue;
 
329
end;
 
330
 
 
331
procedure TLazLoggerFile.SetParamForLogFileName(AValue: String);
 
332
begin
 
333
  if FParamForLogFileName = AValue then Exit;
 
334
  Finish;
 
335
  FGetLogFileNameDone := False;
 
336
  FParamForLogFileName := AValue;
 
337
end;
 
338
 
 
339
function TLazLoggerFile.GetCloseLogFileBetweenWrites: Boolean;
 
340
begin
 
341
  Result := FileHandle.CloseLogFileBetweenWrites;
 
342
end;
 
343
 
 
344
function TLazLoggerFile.GetLogName: String;
 
345
begin
 
346
  Result := FileHandle.LogName;
 
347
end;
 
348
 
 
349
function TLazLoggerFile.GetUseStdOut: Boolean;
 
350
begin
 
351
  Result := FileHandle.UseStdOut;
 
352
end;
 
353
 
 
354
procedure TLazLoggerFile.SetCloseLogFileBetweenWrites(AValue: Boolean);
 
355
begin
 
356
  FileHandle.CloseLogFileBetweenWrites := AValue;
 
357
end;
 
358
 
 
359
procedure TLazLoggerFile.SetLogName(AValue: String);
 
360
begin
 
361
  if FileHandle.LogName = AValue then Exit;
 
362
  Finish;
 
363
  FileHandle.LogName := AValue;
 
364
end;
 
365
 
 
366
procedure TLazLoggerFile.SetUseStdOut(AValue: Boolean);
 
367
begin
 
368
  FileHandle.UseStdOut := AValue;
 
369
end;
 
370
 
 
371
procedure TLazLoggerFile.DoInit;
 
372
begin
 
373
  inherited DoInit;
 
374
 
 
375
  FDebugNestLvl := 0;
 
376
  FDebugNestAtBOL := True;
 
377
  if (LogName = '') and not FGetLogFileNameDone then
 
378
    LogName := GetLogFileName;
 
379
 
 
380
  FileHandle.OpenFile;
 
381
end;
 
382
 
 
383
procedure TLazLoggerFile.DoFinsh;
 
384
begin
 
385
  inherited DoFinsh;
 
386
 
 
387
  FileHandle.CloseFile;
 
388
end;
 
389
 
 
390
procedure TLazLoggerFile.IncreaseIndent;
 
391
begin
 
392
  inc(FDebugNestLvl);
 
393
  CreateIndent;
 
394
end;
 
395
 
 
396
procedure TLazLoggerFile.DecreaseIndent;
 
397
begin
 
398
  if not FDebugNestAtBOL then DebugLn;
 
399
 
 
400
  if FDebugNestLvl > 0 then
 
401
    dec(FDebugNestLvl);
 
402
  CreateIndent;
 
403
end;
 
404
 
 
405
procedure TLazLoggerFile.IncreaseIndent(LogGroup: PLazLoggerLogGroup);
 
406
begin
 
407
  if (LogGroup <> nil) then begin
 
408
    if (not LogGroup^.Enabled) then exit;
 
409
    inc(LogGroup^.FOpenedIndents);
 
410
    IncreaseIndent;
 
411
  end
 
412
  else
 
413
    IncreaseIndent;
 
414
end;
 
415
 
 
416
procedure TLazLoggerFile.DecreaseIndent(LogGroup: PLazLoggerLogGroup);
 
417
begin
 
418
  if (LogGroup <> nil) then begin
 
419
    // close what was opened, even if now disabled
 
420
    // only close, if opened by this group
 
421
    if (LogGroup^.FOpenedIndents <= 0) then exit;
 
422
    dec(LogGroup^.FOpenedIndents);
 
423
    DecreaseIndent;
 
424
  end
 
425
  else
 
426
    DecreaseIndent;
 
427
end;
 
428
 
 
429
procedure TLazLoggerFile.IndentChanged;
 
430
begin
 
431
  CreateIndent;
 
432
end;
 
433
 
 
434
procedure TLazLoggerFile.CreateIndent;
 
435
var
 
436
  s: String;
 
437
  NewLen: Integer;
 
438
begin
 
439
  NewLen := FDebugNestLvl * NestLvlIndent;
 
440
  if NewLen < 0 then NewLen := 0;
 
441
  if (NewLen >= MaxNestPrefixLen) then begin
 
442
    s := IntToStr(FDebugNestLvl);
 
443
    NewLen := MaxNestPrefixLen - Length(s);
 
444
    if NewLen < 1 then
 
445
      NewLen := 1;
 
446
  end else
 
447
    s := '';
 
448
 
 
449
  if NewLen <> Length(FDebugIndent) then
 
450
    FDebugIndent := s + StringOfChar(' ', NewLen);
 
451
end;
 
452
 
 
453
procedure TLazLoggerFile.DoDbgOut(const s: string);
 
454
var
 
455
  Handled: Boolean;
 
456
begin
 
457
  if not IsInitialized then Init;
 
458
 
 
459
  if OnDbgOut <> nil then
 
460
  begin
 
461
    Handled := False;
 
462
    if FDebugNestAtBOL and (s <> '') then
 
463
      OnDbgOut(Self, FDebugIndent + s, Handled)
 
464
    else
 
465
      OnDbgOut(Self, s, Handled);
 
466
    if Handled then
 
467
      Exit;
 
468
  end;
 
469
 
 
470
  if OnWidgetSetDbgOut <> nil then
 
471
  begin
 
472
    Handled := False;
 
473
    if FDebugNestAtBOL and (s <> '') then
 
474
      OnWidgetSetDbgOut(Self, FDebugIndent + s, Handled,
 
475
                        FileHandle.WriteTarget, FileHandle.ActiveLogText)
 
476
    else
 
477
      OnWidgetSetDbgOut(Self, s, Handled, FileHandle.WriteTarget, FileHandle.ActiveLogText);
 
478
    if Handled then
 
479
      Exit;
 
480
  end;
 
481
 
 
482
  if FDebugNestAtBOL and (s <> '') then
 
483
    FileHandle.WriteToFile(FDebugIndent + s)
 
484
  else
 
485
    FileHandle.WriteToFile(s);
 
486
  FDebugNestAtBOL := (s = '') or (s[length(s)] in [#10,#13]);
 
487
end;
 
488
 
 
489
procedure TLazLoggerFile.DoDebugLn(const s: string);
 
490
var
 
491
  Handled: Boolean;
 
492
begin
 
493
  if not IsInitialized then Init;
 
494
 
 
495
  if OnDebugLn <> nil then
 
496
  begin
 
497
    Handled := False;
 
498
    if FDebugNestAtBOL and (s <> '') then
 
499
      OnDebugLn(Self, FDebugIndent + s, Handled)
 
500
    else
 
501
      OnDebugLn(Self, s, Handled);
 
502
    if Handled then
 
503
      Exit;
 
504
  end;
 
505
 
 
506
  if OnWidgetSetDebugLn <> nil then
 
507
  begin
 
508
    Handled := False;
 
509
    if FDebugNestAtBOL and (s <> '') then
 
510
      OnWidgetSetDebugLn(Self, FDebugIndent + s, Handled,
 
511
                         FileHandle.WriteTarget, FileHandle.ActiveLogText)
 
512
    else
 
513
      OnWidgetSetDebugLn(Self, s, Handled, FileHandle.WriteTarget, FileHandle.ActiveLogText);
 
514
    if Handled then
 
515
      Exit;
 
516
  end;
 
517
 
 
518
  if FDebugNestAtBOL and (s <> '') then
 
519
    FileHandle.WriteLnToFile(FDebugIndent + ConvertLineEndings(s))
 
520
  else
 
521
    FileHandle.WriteLnToFile(ConvertLineEndings(s));
 
522
  FDebugNestAtBOL := True;
 
523
end;
 
524
 
 
525
procedure TLazLoggerFile.DoDebuglnStack(const s: string);
 
526
begin
 
527
  DebugLn(s);
 
528
  FileHandle.DoOpenFile;
 
529
  if FileHandle.FActiveLogText = nil then exit;
 
530
 
 
531
  Dump_Stack(FileHandle.FActiveLogText^, get_frame);
 
532
 
 
533
  if CloseLogFileBetweenWrites then
 
534
    FileHandle.DoCloseFile;
 
535
end;
 
536
 
 
537
constructor TLazLoggerFile.Create;
 
538
begin
 
539
  inherited;
 
540
  FDebugNestLvl := 0;
 
541
 
 
542
  {$ifdef WinCE}
 
543
  FParamForLogFileName := '';
 
544
  FEnvironmentForLogFileName := '';
 
545
  {$else}
 
546
  FParamForLogFileName := '--debug-log=';
 
547
  FEnvironmentForLogFileName   := '*_debuglog';
 
548
  {$endif}
 
549
end;
 
550
 
 
551
destructor TLazLoggerFile.Destroy;
 
552
begin
 
553
  inherited Destroy;
 
554
  FreeAndNil(FFileHandle);
 
555
end;
 
556
 
 
557
procedure TLazLoggerFile.Assign(Src: TLazLogger);
 
558
begin
 
559
  inherited Assign(Src);
 
560
  if (Src <> nil) and (Src is TLazLoggerFile) then begin
 
561
    FOnDbgOut  := TLazLoggerFile(Src).FOnDbgOut;
 
562
    FOnDebugLn := TLazLoggerFile(Src).FOnDebugLn;;
 
563
 
 
564
    FEnvironmentForLogFileName := TLazLoggerFile(Src).FEnvironmentForLogFileName;
 
565
    FParamForLogFileName       := TLazLoggerFile(Src).FParamForLogFileName;
 
566
    FGetLogFileNameDone        := TLazLoggerFile(Src).FGetLogFileNameDone;
 
567
 
 
568
    LogName   := TLazLoggerFile(Src).LogName;
 
569
    UseStdOut := TLazLoggerFile(Src).UseStdOut;
 
570
    CloseLogFileBetweenWrites := TLazLoggerFile(Src).CloseLogFileBetweenWrites;
 
571
  end;
 
572
end;
 
573
 
 
574
function TLazLoggerFile.GetLogFileName: string;
 
575
var
 
576
  EnvVarName: string;
 
577
begin
 
578
  Result := '';
 
579
  FGetLogFileNameDone := True;
 
580
  if FParamForLogFileName <> '' then begin
 
581
    // first try to find the log file name in the command line parameters
 
582
    Result := GetParamByName(FParamForLogFileName, 0);
 
583
  end;
 
584
  if FEnvironmentForLogFileName <> '' then begin;
 
585
    // if not found yet, then try to find in the environment variables
 
586
    if (length(result)=0) then begin
 
587
      EnvVarName:= ChangeFileExt(ExtractFileName(ParamStrUTF8(0)),'') + FEnvironmentForLogFileName;
 
588
      Result := GetEnvironmentVariableUTF8(EnvVarName);
 
589
    end;
 
590
  end;
 
591
  if (length(result)>0) then
 
592
    Result := ExpandFileNameUTF8(Result);
 
593
end;
 
594
 
 
595
 
 
596
function DbgStr(const StringWithSpecialChars: string): string;
 
597
var
 
598
  i: Integer;
 
599
  s: String;
 
600
  l: Integer;
 
601
begin
 
602
  Result:=StringWithSpecialChars;
 
603
  i:=1;
 
604
  while (i<=length(Result)) do begin
 
605
    case Result[i] of
 
606
    ' '..#126: inc(i);
 
607
    else
 
608
      s:='#'+HexStr(ord(Result[i]),2);
 
609
      // Note: do not use copy, fpc might change broken UTF-8 characters to '?'
 
610
      l:=length(Result)-i;
 
611
      SetLength(Result,length(Result)-1+length(s));
 
612
      if l>0 then
 
613
        system.Move(Result[i+1],Result[i+length(s)],l);
 
614
      system.Move(s[1],Result[i],length(s));
 
615
      inc(i,length(s));
 
616
    end;
 
617
  end;
 
618
end;
 
619
 
 
620
function DbgStr(const StringWithSpecialChars: string; StartPos, Len: PtrInt
 
621
  ): string;
 
622
begin
 
623
  Result:=dbgstr(copy(StringWithSpecialChars,StartPos,Len));
 
624
end;
 
625
 
 
626
function DbgStr(const p: PChar; Len: PtrInt): string;
 
627
const
 
628
  Hex: array[0..15] of char='0123456789ABCDEF';
 
629
var
 
630
  UsedLen: PtrInt;
 
631
  ResultLen: PtrInt;
 
632
  Src: PChar;
 
633
  Dest: PChar;
 
634
  c: Char;
 
635
begin
 
636
  if (p=nil) or (p^=#0) or (Len<=0) then exit('');
 
637
  UsedLen:=0;
 
638
  ResultLen:=0;
 
639
  Src:=p;
 
640
  while Src^<>#0 do begin
 
641
    inc(UsedLen);
 
642
    if Src^ in [' '..#126] then
 
643
      inc(ResultLen)
 
644
    else
 
645
      inc(ResultLen,3);
 
646
    if UsedLen>=Len then break;
 
647
    inc(Src);
 
648
  end;
 
649
  SetLength(Result,ResultLen);
 
650
  Src:=p;
 
651
  Dest:=PChar(Result);
 
652
  while UsedLen>0 do begin
 
653
    dec(UsedLen);
 
654
    c:=Src^;
 
655
    if c in [' '..#126] then begin
 
656
      Dest^:=c;
 
657
      inc(Dest);
 
658
    end else begin
 
659
      Dest^:='#';
 
660
      inc(Dest);
 
661
      Dest^:=Hex[ord(c) shr 4];
 
662
      inc(Dest);
 
663
      Dest^:=Hex[ord(c) and $f];
 
664
      inc(Dest);
 
665
    end;
 
666
    inc(Src);
 
667
  end;
 
668
end;
 
669
 
 
670
function DbgWideStr(const StringWithSpecialChars: widestring): string;
 
671
var
 
672
  s: String;
 
673
  SrcPos: Integer;
 
674
  DestPos: Integer;
 
675
  i: Integer;
 
676
begin
 
677
  SetLength(Result,length(StringWithSpecialChars));
 
678
  SrcPos:=1;
 
679
  DestPos:=1;
 
680
  while SrcPos<=length(StringWithSpecialChars) do begin
 
681
    i:=ord(StringWithSpecialChars[SrcPos]);
 
682
    case i of
 
683
    32..126:
 
684
      begin
 
685
        Result[DestPos]:=chr(i);
 
686
        inc(SrcPos);
 
687
        inc(DestPos);
 
688
      end;
 
689
    else
 
690
      s:='#'+HexStr(i,4);
 
691
      inc(SrcPos);
 
692
      Result:=copy(Result,1,DestPos-1)+s+copy(Result,DestPos+1,length(Result));
 
693
      inc(DestPos,length(s));
 
694
    end;
 
695
  end;
 
696
end;
 
697
 
 
698
function ConvertLineEndings(const s: string): string;
 
699
var
 
700
  i: Integer;
 
701
  EndingStart: LongInt;
 
702
begin
 
703
  Result:=s;
 
704
  i:=1;
 
705
  while (i<=length(Result)) do begin
 
706
    if Result[i] in [#10,#13] then begin
 
707
      EndingStart:=i;
 
708
      inc(i);
 
709
      if (i<=length(Result)) and (Result[i] in [#10,#13])
 
710
      and (Result[i]<>Result[i-1]) then begin
 
711
        inc(i);
 
712
      end;
 
713
      if (length(LineEnding)<>i-EndingStart)
 
714
      or (LineEnding<>copy(Result,EndingStart,length(LineEnding))) then begin
 
715
        // line end differs => replace with current LineEnding
 
716
        Result:=
 
717
          copy(Result,1,EndingStart-1)+LineEnding+copy(Result,i,length(Result));
 
718
        i:=EndingStart+length(LineEnding);
 
719
      end;
 
720
    end else
 
721
      inc(i);
 
722
  end;
 
723
end;
 
724
 
 
725
procedure ReplaceSubstring(var s: string; StartPos, Count: SizeInt;
 
726
  const Insertion: string);
 
727
var
 
728
  MaxCount: SizeInt;
 
729
  InsertionLen: SizeInt;
 
730
  SLen: SizeInt;
 
731
  RestLen: SizeInt;
 
732
  p: PByte;
 
733
begin
 
734
  SLen:=length(s);
 
735
  if StartPos>SLen then
 
736
    StartPos:=SLen;
 
737
  if StartPos<1 then StartPos:=1;
 
738
  if Count<0 then Count:=0;
 
739
  MaxCount:=SLen-StartPos+1;
 
740
  if Count>MaxCount then
 
741
    Count:=MaxCount;
 
742
  InsertionLen:=length(Insertion);
 
743
  if (Count=0) and (InsertionLen=0) then
 
744
    exit; // nothing to do
 
745
  if (Count=InsertionLen) then begin
 
746
    if CompareMem(PByte(s)+StartPos-1,Pointer(Insertion),Count) then
 
747
      // already the same content
 
748
      exit;
 
749
    UniqueString(s);
 
750
  end else begin
 
751
    RestLen:=SLen-StartPos-Count+1;
 
752
    if InsertionLen<Count then begin
 
753
      // shorten
 
754
      if RestLen>0 then begin
 
755
        UniqueString(s);
 
756
        p:=PByte(s)+StartPos-1;
 
757
        System.Move((p+Count)^,(p+InsertionLen)^,RestLen);
 
758
      end;
 
759
      Setlength(s,SLen-Count+InsertionLen);
 
760
    end else begin
 
761
      // longen
 
762
      Setlength(s,SLen-Count+InsertionLen);
 
763
      if RestLen>0 then begin
 
764
        p:=PByte(s)+StartPos-1;
 
765
        System.Move((p+Count)^,(p+InsertionLen)^,RestLen);
 
766
      end;
 
767
    end;
 
768
  end;
 
769
  if InsertionLen>0 then
 
770
    System.Move(PByte(Insertion)^,(PByte(s)+StartPos-1)^,InsertionLen);
 
771
end;
 
772
 
 
773
initialization
 
774
  LazDebugLoggerCreator := @CreateDebugLogger;
 
775
  RecreateDebugLogger
 
776
end.
 
777