/jcl/experts/stacktraceviewer/JclStackTraceViewerClasses.pas
Pascal | 638 lines | 493 code | 93 blank | 52 comment | 11 complexity | cba4b7b94d2f46d01c213d4b1d566daf MD5 | raw file
Possible License(s): BSD-3-Clause
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.