/jcl/experts/stacktraceviewer/JclStackTraceViewerClasses.pas

  1{**************************************************************************************************}
  2{                                                                                                  }
  3{ Project JEDI Code Library (JCL)                                                                  }
  4{                                                                                                  }
  5{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
  6{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
  7{ License at http://www.mozilla.org/MPL/                                                           }
  8{                                                                                                  }
  9{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
 10{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
 11{ and limitations under the License.                                                               }
 12{                                                                                                  }
 13{ The Original Code is JclStackTraceViewerClasses.pas.                                             }
 14{                                                                                                  }
 15{ The Initial Developer of the Original Code is Uwe Schuster.                                      }
 16{ Portions created by Uwe Schuster are Copyright (C) 2009 Uwe Schuster. All rights reserved.       }
 17{                                                                                                  }
 18{ Contributor(s):                                                                                  }
 19{   Uwe Schuster (uschuster)                                                                       }
 20{                                                                                                  }
 21{**************************************************************************************************}
 22{                                                                                                  }
 23{ Last modified: $Date::                                                                         $ }
 24{ Revision:      $Rev::                                                                          $ }
 25{ Author:        $Author::                                                                       $ }
 26{                                                                                                  }
 27{**************************************************************************************************}
 28
 29unit JclStackTraceViewerClasses;
 30
 31{$I jcl.inc}
 32
 33interface
 34
 35uses
 36  Windows, Classes, Contnrs,
 37  {$IFDEF UNITVERSIONING}
 38  JclUnitVersioning,
 39  {$ENDIF UNITVERSIONING}
 40  JclDebug, JclDebugSerialization, JclStackTraceViewerAPI;
 41
 42type
 43  TJclStackTraceViewerLocationInfo = class(TJclLocationInfoEx, IJclLocationInfo, IJclPreparedLocationInfo)
 44  private
 45    FFoundFile: Boolean;
 46    FFileName: string;
 47    FProjectName: string;
 48    FRevision: string;
 49    FTranslatedLineNumber: Integer;
 50  protected
 51    procedure AssignTo(Dest: TPersistent); override;
 52  public
 53    { IInterface }
 54    function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
 55    function _AddRef: Integer; stdcall;
 56    function _Release: Integer; stdcall;
 57    { IJclLocationInfo }
 58    function GetAddress: Pointer;
 59    function GetBinaryFileName: string;
 60    function GetLineNumber: Integer;
 61    function GetLineNumberOffsetFromProcedureStart: Integer;
 62    function GetModuleName: string;
 63    function GetOffsetFromLineNumber: Integer;
 64    function GetOffsetFromProcName: Integer;
 65    function GetProcedureName: string;
 66    function GetSourceName: string;
 67    function GetSourceUnitName: string;
 68    function GetUnitVersionDateTime: TDateTime;
 69    function GetUnitVersionExtra: string;
 70    function GetUnitVersionLogPath: string;
 71    function GetUnitVersionRCSfile: string;
 72    function GetUnitVersionRevision: string;
 73    function GetVAddress: Pointer;
 74    function GetValues: Integer;
 75    property Address: Pointer read GetAddress;
 76    property BinaryFileName: string read GetBinaryFileName;
 77    property LineNumber: Integer read GetLineNumber;
 78    property LineNumberOffsetFromProcedureStart: Integer read GetLineNumberOffsetFromProcedureStart;
 79    property ModuleName: string read GetModuleName;
 80    property OffsetFromLineNumber: Integer read GetOffsetFromLineNumber;
 81    property OffsetFromProcName: Integer read GetOffsetFromProcName;
 82    property ProcedureName: string read GetProcedureName;
 83    property SourceName: string read GetSourceName;
 84    property SourceUnitName: string read GetSourceUnitName;
 85    property UnitVersionDateTime: TDateTime read GetUnitVersionDateTime;
 86    property UnitVersionExtra: string read GetUnitVersionExtra;
 87    property UnitVersionLogPath: string read GetUnitVersionLogPath;
 88    property UnitVersionRCSfile: string read GetUnitVersionRCSfile;
 89    property UnitVersionRevision: string read GetUnitVersionRevision;
 90    property VAddress: Pointer read GetVAddress;
 91    property Values: Integer read GetValues;
 92    { IJclPreparedLocationInfo }
 93    function GetFileName: string;
 94    function GetFoundFile: Boolean;
 95    function GetProjectName: string;
 96    function GetRevision: string;
 97    function GetTranslatedLineNumber: Integer;
 98    procedure SetFileName(AValue: string);
 99    procedure SetFoundFile(AValue: Boolean);
100    procedure SetProjectName(AValue: string);
101    procedure SetRevision(AValue: string);
102    procedure SetTranslatedLineNumber(AValue: Integer);
103    property FileName: string read FFileName write FFileName;
104    property FoundFile: Boolean read FFoundFile write FFoundFile;
105    property ProjectName: string read FProjectName write FProjectName;
106    property Revision: string read FRevision write FRevision;
107    property TranslatedLineNumber: Integer read FTranslatedLineNumber write FTranslatedLineNumber;
108  end;
109
110  TJclStackTraceViewerLocationInfoList = class(TJclCustomLocationInfoList, IJclLocationInfoList,
111    IJclPreparedLocationInfoList)
112  private
113    FPrepared: Boolean;
114    FModuleInfoList: IJclModuleInfoList;
115    function GetItems(AIndex: Integer): TJclStackTraceViewerLocationInfo;
116  public
117    constructor Create; override;
118    function Add(Addr: Pointer): TJclStackTraceViewerLocationInfo;
119    property Items[AIndex: Integer]: TJclStackTraceViewerLocationInfo read GetItems;
120
121    { IInterface }
122    function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
123    function _AddRef: Integer; stdcall;
124    function _Release: Integer; stdcall;
125    { IJclLocationInfoList }
126    function GetCount: Integer;
127    function GetLocationItems(AIndex: Integer): IJclLocationInfo;
128    property Count: Integer read GetCount;
129    property LocationItems[AIndex: Integer]: IJclLocationInfo read GetLocationItems; default;
130    { IJclPreparedLocationInfoList }
131    function GetPrepared: Boolean;
132    procedure SetPrepared(AValue: Boolean);
133    function GetModuleInfoList: IJclModuleInfoList;
134    property ModuleInfoList: IJclModuleInfoList read FModuleInfoList write FModuleInfoList;
135    property Prepared: Boolean read FPrepared write FPrepared;
136  end;
137
138  TJclStackTraceViewerThreadInfo = class(TJclCustomThreadInfo)
139  private
140    function GetStack(const AIndex: Integer): TJclStackTraceViewerLocationInfoList;
141  protected
142    function GetStackClass: TJclCustomLocationInfoListClass; override;
143  public
144    property CreationStack: TJclStackTraceViewerLocationInfoList index 1 read GetStack;
145    property Stack: TJclStackTraceViewerLocationInfoList index 2 read GetStack;
146  end;
147
148  TJclStackTraceViewerThreadInfoList = class(TObject)
149  private
150    FItems: TObjectList;
151    function GetItems(AIndex: Integer): TJclStackTraceViewerThreadInfo;
152    function GetCount: Integer;
153  public
154    constructor Create;
155    destructor Destroy; override;
156    function Add: TJclStackTraceViewerThreadInfo;
157    procedure Clear;
158    property Count: Integer read GetCount;
159    property Items[AIndex: Integer]: TJclStackTraceViewerThreadInfo read GetItems; default;
160  end;
161
162  TJclStackTraceViewerModuleModuleInfo = class(TJclSerializableModuleInfo, IJclModuleInfo)
163    { IInterface }
164    function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
165    function _AddRef: Integer; stdcall;
166    function _Release: Integer; stdcall;
167    { IJclModuleInfo }
168    function GetBinFileVersion: string;
169    function GetModuleName: string;
170    property BinFileVersion: string read GetBinFileVersion;
171    property ModuleName: string read GetModuleName;
172  end;
173
174  TJclStackTraceViewerModuleInfoList = class(TInterfacedObject, IInterface, IJclModuleInfoList)
175  private
176    FItems: TObjectList;
177  public
178    constructor Create;
179    destructor Destroy; override;
180    function Add: TJclStackTraceViewerModuleModuleInfo;
181    procedure Clear;
182
183    { IInterface }
184    // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
185    function _AddRef: Integer; stdcall;
186    function _Release: Integer; stdcall;
187    { IJclModuleInfoList }
188    function GetModuleCount: Integer;
189    function GetModuleInfo(AIndex: Integer): IJclModuleInfo;
190    property Count: Integer read GetModuleCount;
191    property Items[AIndex: Integer]: IJclModuleInfo read GetModuleInfo; default;
192  end;
193
194  TJclStackTraceViewerExceptionInfo = class(TObject)
195  private
196    FException: TJclSerializableException;
197    FThreadInfoList: TJclStackTraceViewerThreadInfoList;
198    FModules: TJclStackTraceViewerModuleInfoList;
199    procedure AddModuleListToStacks;
200  public
201    constructor Create;
202    destructor Destroy; override;
203    procedure AssignExceptionInfo(AExceptionInfo: TJclSerializableExceptionInfo);
204    property ThreadInfoList: TJclStackTraceViewerThreadInfoList read FThreadInfoList;
205    property Exception: TJclSerializableException read FException;
206    property Modules: TJclStackTraceViewerModuleInfoList read FModules;
207  end;
208
209{$IFDEF UNITVERSIONING}
210const
211  UnitVersioning: TUnitVersionInfo = (
212    RCSfile: '$URL$';
213    Revision: '$Revision$';
214    Date: '$Date$';
215    LogPath: 'JCL\experts\stacktraceviewer';
216    Extra: '';
217    Data: nil
218    );
219{$ENDIF UNITVERSIONING}
220
221implementation
222
223//=== { TJclStackTraceViewerLocationInfoList } ===============================
224
225function TJclStackTraceViewerLocationInfoList.Add(Addr: Pointer): TJclStackTraceViewerLocationInfo;
226begin
227  Result := TJclStackTraceViewerLocationInfo(InternalAdd(Addr));
228end;
229
230constructor TJclStackTraceViewerLocationInfoList.Create;
231begin
232  inherited Create;
233  FItemClass := TJclStackTraceViewerLocationInfo;
234  FOptions := [];
235  FPrepared := False;
236end;
237
238function TJclStackTraceViewerLocationInfoList.GetCount: Integer;
239begin
240  Result := FItems.Count;
241end;
242
243function TJclStackTraceViewerLocationInfoList.GetItems(AIndex: Integer): TJclStackTraceViewerLocationInfo;
244begin
245  Result := TJclStackTraceViewerLocationInfo(FItems[AIndex]);
246end;
247
248function TJclStackTraceViewerLocationInfoList.GetLocationItems(AIndex: Integer): IJclLocationInfo;
249begin
250  FItems[AIndex].GetInterface(IJclLocationInfo, Result);
251end;
252
253function TJclStackTraceViewerLocationInfoList.GetModuleInfoList: IJclModuleInfoList;
254begin
255  Result := FModuleInfoList;
256end;
257
258function TJclStackTraceViewerLocationInfoList.GetPrepared: Boolean;
259begin
260  Result := FPrepared;
261end;
262
263function TJclStackTraceViewerLocationInfoList.QueryInterface(const IID: TGUID; out Obj): HRESULT;
264begin
265  if GetInterface(IID, Obj) then
266    Result := S_OK
267  else
268    Result := E_NOINTERFACE;
269end;
270
271procedure TJclStackTraceViewerLocationInfoList.SetPrepared(AValue: Boolean);
272begin
273  FPrepared := AValue;
274end;
275
276function TJclStackTraceViewerLocationInfoList._AddRef: Integer;
277begin
278  Result := -1;
279end;
280
281function TJclStackTraceViewerLocationInfoList._Release: Integer;
282begin
283  Result := -1;
284end;
285
286//=== { TJclStackTraceViewerThreadInfo } =====================================
287
288function TJclStackTraceViewerThreadInfo.GetStack(const AIndex: Integer): TJclStackTraceViewerLocationInfoList;
289begin
290  case AIndex of
291    1: Result := TJclStackTraceViewerLocationInfoList(FCreationStack);
292    2: Result := TJclStackTraceViewerLocationInfoList(FStack);
293    else
294      Result := nil;
295  end;
296end;
297
298function TJclStackTraceViewerThreadInfo.GetStackClass: TJclCustomLocationInfoListClass;
299begin
300  Result := TJclStackTraceViewerLocationInfoList;
301end;
302
303//=== { TJclStackTraceViewerThreadInfoList } =================================
304
305constructor TJclStackTraceViewerThreadInfoList.Create;
306begin
307  inherited Create;
308  FItems := TObjectList.Create;
309end;
310
311destructor TJclStackTraceViewerThreadInfoList.Destroy;
312begin
313  FItems.Free;
314  inherited Destroy;
315end;
316
317function TJclStackTraceViewerThreadInfoList.Add: TJclStackTraceViewerThreadInfo;
318begin
319  FItems.Add(TJclStackTraceViewerThreadInfo.Create);
320  Result := TJclStackTraceViewerThreadInfo(FItems.Last);
321end;
322
323procedure TJclStackTraceViewerThreadInfoList.Clear;
324begin
325  FItems.Clear;
326end;
327
328function TJclStackTraceViewerThreadInfoList.GetCount: Integer;
329begin
330  Result := FItems.Count;
331end;
332
333function TJclStackTraceViewerThreadInfoList.GetItems(AIndex: Integer): TJclStackTraceViewerThreadInfo;
334begin
335  Result := TJclStackTraceViewerThreadInfo(FItems[AIndex]);
336end;
337
338//=== { TJclStackTraceViewerExceptionInfo } ==================================
339
340constructor TJclStackTraceViewerExceptionInfo.Create;
341begin
342  inherited Create;
343  FException := TJclSerializableException.Create;
344  FThreadInfoList := TJclStackTraceViewerThreadInfoList.Create;
345  FModules := TJclStackTraceViewerModuleInfoList.Create;
346end;
347
348destructor TJclStackTraceViewerExceptionInfo.Destroy;
349begin
350  FModules.Free;
351  FException.Free;
352  FThreadInfoList.Free;
353  inherited Destroy;
354end;
355
356procedure TJclStackTraceViewerExceptionInfo.AddModuleListToStacks;
357var
358  I: Integer;
359begin
360  for I := 0 to FThreadInfoList.Count - 1 do
361    FThreadInfoList[I].CreationStack.ModuleInfoList := FModules;
362  for I := 0 to FThreadInfoList.Count - 1 do
363    FThreadInfoList[I].Stack.ModuleInfoList := FModules;
364end;
365
366procedure TJclStackTraceViewerExceptionInfo.AssignExceptionInfo(AExceptionInfo: TJclSerializableExceptionInfo);
367var
368  I: Integer;
369begin
370  FException.Assign(AExceptionInfo.Exception);
371  FThreadInfoList.Clear;
372  for I := 0 to AExceptionInfo.ThreadInfoList.Count - 1 do
373    FThreadInfoList.Add.Assign(AExceptionInfo.ThreadInfoList[I]);
374  FModules.Clear;
375  for I := 0 to AExceptionInfo.Modules.Count - 1 do
376    FModules.Add.Assign(AExceptionInfo.Modules[I]);
377  AddModuleListToStacks;
378end;
379
380{ TJclStackTraceViewerLocationInfo }
381
382function TJclStackTraceViewerLocationInfo.QueryInterface(const IID: TGUID; out Obj): HRESULT;
383begin
384  if GetInterface(IID, Obj) then
385    Result := S_OK
386  else
387    Result := E_NOINTERFACE;
388end;
389
390function TJclStackTraceViewerLocationInfo._AddRef: Integer;
391begin
392  Result := -1;
393end;
394
395function TJclStackTraceViewerLocationInfo._Release: Integer;
396begin
397  Result := -1;
398end;
399
400procedure TJclStackTraceViewerLocationInfo.AssignTo(Dest: TPersistent);
401begin
402  inherited AssignTo(Dest);
403  if Dest is TJclStackTraceViewerLocationInfo then
404  begin
405    TJclStackTraceViewerLocationInfo(Dest).FFoundFile := FFoundFile;
406    TJclStackTraceViewerLocationInfo(Dest).FFileName := FFileName;
407    TJclStackTraceViewerLocationInfo(Dest).FProjectName := FProjectName;
408    TJclStackTraceViewerLocationInfo(Dest).FRevision := FRevision;
409    TJclStackTraceViewerLocationInfo(Dest).FTranslatedLineNumber := FTranslatedLineNumber;
410  end;
411end;
412
413function TJclStackTraceViewerLocationInfo.GetAddress: Pointer;
414begin
415  Result := Address;
416end;
417
418function TJclStackTraceViewerLocationInfo.GetBinaryFileName: string;
419begin
420  Result := BinaryFileName;
421end;
422
423function TJclStackTraceViewerLocationInfo.GetFileName: string;
424begin
425  Result := FFileName;
426end;
427
428function TJclStackTraceViewerLocationInfo.GetFoundFile: Boolean;
429begin
430  Result := FFoundFile;
431end;
432
433function TJclStackTraceViewerLocationInfo.GetLineNumber: Integer;
434begin
435  Result := LineNumber;
436end;
437
438function TJclStackTraceViewerLocationInfo.GetLineNumberOffsetFromProcedureStart: Integer;
439begin
440  Result := LineNumberOffsetFromProcedureStart;
441end;
442
443function TJclStackTraceViewerLocationInfo.GetModuleName: string;
444begin
445  Result := ModuleName;
446end;
447
448function TJclStackTraceViewerLocationInfo.GetOffsetFromLineNumber: Integer;
449begin
450  Result := OffsetFromLineNumber;
451end;
452
453function TJclStackTraceViewerLocationInfo.GetOffsetFromProcName: Integer;
454begin
455  Result := OffsetFromProcName;
456end;
457
458function TJclStackTraceViewerLocationInfo.GetProcedureName: string;
459begin
460  Result := ProcedureName;
461end;
462
463function TJclStackTraceViewerLocationInfo.GetProjectName: string;
464begin
465  Result := FProjectName;
466end;
467
468function TJclStackTraceViewerLocationInfo.GetRevision: string;
469begin
470  Result := FRevision;
471end;
472
473function TJclStackTraceViewerLocationInfo.GetSourceName: string;
474begin
475  Result := SourceName;
476end;
477
478function TJclStackTraceViewerLocationInfo.GetSourceUnitName: string;
479begin
480  Result := SourceUnitName;
481end;
482
483function TJclStackTraceViewerLocationInfo.GetTranslatedLineNumber: Integer;
484begin
485  Result := FTranslatedLineNumber;
486end;
487
488function TJclStackTraceViewerLocationInfo.GetUnitVersionDateTime: TDateTime;
489begin
490  Result := UnitVersionDateTime;
491end;
492
493function TJclStackTraceViewerLocationInfo.GetUnitVersionExtra: string;
494begin
495  Result := UnitVersionExtra;
496end;
497
498function TJclStackTraceViewerLocationInfo.GetUnitVersionLogPath: string;
499begin
500  Result := UnitVersionLogPath;
501end;
502
503function TJclStackTraceViewerLocationInfo.GetUnitVersionRCSfile: string;
504begin
505  Result := UnitVersionRCSfile;
506end;
507
508function TJclStackTraceViewerLocationInfo.GetUnitVersionRevision: string;
509begin
510  Result := UnitVersionRevision;
511end;
512
513function TJclStackTraceViewerLocationInfo.GetVAddress: Pointer;
514begin
515  Result := VAddress;
516end;
517
518function TJclStackTraceViewerLocationInfo.GetValues: Integer;
519begin
520  Result := 0;
521  if lievLocationInfo in (inherited Values) then
522    Inc(Result, livLocationInfo);
523  if lievProcedureStartLocationInfo in (inherited Values) then
524    Inc(Result, livProcedureStartLocationInfo);
525  if lievUnitVersionInfo in (inherited Values) then
526    Inc(Result, livUnitVersionInfo);
527end;
528
529procedure TJclStackTraceViewerLocationInfo.SetFileName(AValue: string);
530begin
531  FFileName := AValue;
532end;
533
534procedure TJclStackTraceViewerLocationInfo.SetFoundFile(AValue: Boolean);
535begin
536  FFoundFile := AValue;
537end;
538
539procedure TJclStackTraceViewerLocationInfo.SetProjectName(AValue: string);
540begin
541  FProjectName := AValue;
542end;
543
544procedure TJclStackTraceViewerLocationInfo.SetRevision(AValue: string);
545begin
546  FRevision := AValue;
547end;
548
549procedure TJclStackTraceViewerLocationInfo.SetTranslatedLineNumber(AValue: Integer);
550begin
551  FTranslatedLineNumber := AValue;
552end;
553
554
555{ TJclStackTraceViewerModuleModuleInfo }
556
557function TJclStackTraceViewerModuleModuleInfo.GetBinFileVersion: string;
558begin
559  Result := BinFileVersion;
560end;
561
562function TJclStackTraceViewerModuleModuleInfo.GetModuleName: string;
563begin
564  Result := ModuleName;
565end;
566
567function TJclStackTraceViewerModuleModuleInfo.QueryInterface(const IID: TGUID; out Obj): HRESULT;
568begin
569  if GetInterface(IID, Obj) then
570    Result := S_OK
571  else
572    Result := E_NOINTERFACE;
573end;
574
575function TJclStackTraceViewerModuleModuleInfo._AddRef: Integer;
576begin
577  Result := -1;
578end;
579
580function TJclStackTraceViewerModuleModuleInfo._Release: Integer;
581begin
582  Result := -1;
583end;
584
585{ TJclStackTraceViewerModuleInfoList }
586
587function TJclStackTraceViewerModuleInfoList.Add: TJclStackTraceViewerModuleModuleInfo;
588begin
589  FItems.Add(TJclStackTraceViewerModuleModuleInfo.Create);
590  Result := TJclStackTraceViewerModuleModuleInfo(FItems.Last);
591end;
592
593procedure TJclStackTraceViewerModuleInfoList.Clear;
594begin
595  FItems.Clear;
596end;
597
598constructor TJclStackTraceViewerModuleInfoList.Create;
599begin
600  inherited Create;
601  FItems := TObjectList.Create;
602end;
603
604destructor TJclStackTraceViewerModuleInfoList.Destroy;
605begin
606  FItems.Free;
607  inherited Destroy;
608end;
609
610function TJclStackTraceViewerModuleInfoList.GetModuleCount: Integer;
611begin
612  Result := FItems.Count;
613end;
614
615function TJclStackTraceViewerModuleInfoList.GetModuleInfo(AIndex: Integer): IJclModuleInfo;
616begin
617  FItems[AIndex].GetInterface(IJclModuleInfo, Result);
618end;
619
620function TJclStackTraceViewerModuleInfoList._AddRef: Integer;
621begin
622  Result := -1;
623end;
624
625function TJclStackTraceViewerModuleInfoList._Release: Integer;
626begin
627  Result := -1;
628end;
629
630{$IFDEF UNITVERSIONING}
631initialization
632  RegisterUnitVersion(HInstance, UnitVersioning);
633
634finalization
635  UnregisterUnitVersion(HInstance);
636{$ENDIF UNITVERSIONING}
637
638end.