/jcl/experts/stacktraceviewer/JclStackTraceViewerClasses.pas

https://github.com/the-Arioch/jcl · Pascal · 638 lines · 493 code · 93 blank · 52 comment · 11 complexity · cba4b7b94d2f46d01c213d4b1d566daf MD5 · raw file

  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. unit JclStackTraceViewerClasses;
  29. {$I jcl.inc}
  30. interface
  31. uses
  32. Windows, Classes, Contnrs,
  33. {$IFDEF UNITVERSIONING}
  34. JclUnitVersioning,
  35. {$ENDIF UNITVERSIONING}
  36. JclDebug, JclDebugSerialization, JclStackTraceViewerAPI;
  37. type
  38. TJclStackTraceViewerLocationInfo = class(TJclLocationInfoEx, IJclLocationInfo, IJclPreparedLocationInfo)
  39. private
  40. FFoundFile: Boolean;
  41. FFileName: string;
  42. FProjectName: string;
  43. FRevision: string;
  44. FTranslatedLineNumber: Integer;
  45. protected
  46. procedure AssignTo(Dest: TPersistent); override;
  47. public
  48. { IInterface }
  49. function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
  50. function _AddRef: Integer; stdcall;
  51. function _Release: Integer; stdcall;
  52. { IJclLocationInfo }
  53. function GetAddress: Pointer;
  54. function GetBinaryFileName: string;
  55. function GetLineNumber: Integer;
  56. function GetLineNumberOffsetFromProcedureStart: Integer;
  57. function GetModuleName: string;
  58. function GetOffsetFromLineNumber: Integer;
  59. function GetOffsetFromProcName: Integer;
  60. function GetProcedureName: string;
  61. function GetSourceName: string;
  62. function GetSourceUnitName: string;
  63. function GetUnitVersionDateTime: TDateTime;
  64. function GetUnitVersionExtra: string;
  65. function GetUnitVersionLogPath: string;
  66. function GetUnitVersionRCSfile: string;
  67. function GetUnitVersionRevision: string;
  68. function GetVAddress: Pointer;
  69. function GetValues: Integer;
  70. property Address: Pointer read GetAddress;
  71. property BinaryFileName: string read GetBinaryFileName;
  72. property LineNumber: Integer read GetLineNumber;
  73. property LineNumberOffsetFromProcedureStart: Integer read GetLineNumberOffsetFromProcedureStart;
  74. property ModuleName: string read GetModuleName;
  75. property OffsetFromLineNumber: Integer read GetOffsetFromLineNumber;
  76. property OffsetFromProcName: Integer read GetOffsetFromProcName;
  77. property ProcedureName: string read GetProcedureName;
  78. property SourceName: string read GetSourceName;
  79. property SourceUnitName: string read GetSourceUnitName;
  80. property UnitVersionDateTime: TDateTime read GetUnitVersionDateTime;
  81. property UnitVersionExtra: string read GetUnitVersionExtra;
  82. property UnitVersionLogPath: string read GetUnitVersionLogPath;
  83. property UnitVersionRCSfile: string read GetUnitVersionRCSfile;
  84. property UnitVersionRevision: string read GetUnitVersionRevision;
  85. property VAddress: Pointer read GetVAddress;
  86. property Values: Integer read GetValues;
  87. { IJclPreparedLocationInfo }
  88. function GetFileName: string;
  89. function GetFoundFile: Boolean;
  90. function GetProjectName: string;
  91. function GetRevision: string;
  92. function GetTranslatedLineNumber: Integer;
  93. procedure SetFileName(AValue: string);
  94. procedure SetFoundFile(AValue: Boolean);
  95. procedure SetProjectName(AValue: string);
  96. procedure SetRevision(AValue: string);
  97. procedure SetTranslatedLineNumber(AValue: Integer);
  98. property FileName: string read FFileName write FFileName;
  99. property FoundFile: Boolean read FFoundFile write FFoundFile;
  100. property ProjectName: string read FProjectName write FProjectName;
  101. property Revision: string read FRevision write FRevision;
  102. property TranslatedLineNumber: Integer read FTranslatedLineNumber write FTranslatedLineNumber;
  103. end;
  104. TJclStackTraceViewerLocationInfoList = class(TJclCustomLocationInfoList, IJclLocationInfoList,
  105. IJclPreparedLocationInfoList)
  106. private
  107. FPrepared: Boolean;
  108. FModuleInfoList: IJclModuleInfoList;
  109. function GetItems(AIndex: Integer): TJclStackTraceViewerLocationInfo;
  110. public
  111. constructor Create; override;
  112. function Add(Addr: Pointer): TJclStackTraceViewerLocationInfo;
  113. property Items[AIndex: Integer]: TJclStackTraceViewerLocationInfo read GetItems;
  114. { IInterface }
  115. function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
  116. function _AddRef: Integer; stdcall;
  117. function _Release: Integer; stdcall;
  118. { IJclLocationInfoList }
  119. function GetCount: Integer;
  120. function GetLocationItems(AIndex: Integer): IJclLocationInfo;
  121. property Count: Integer read GetCount;
  122. property LocationItems[AIndex: Integer]: IJclLocationInfo read GetLocationItems; default;
  123. { IJclPreparedLocationInfoList }
  124. function GetPrepared: Boolean;
  125. procedure SetPrepared(AValue: Boolean);
  126. function GetModuleInfoList: IJclModuleInfoList;
  127. property ModuleInfoList: IJclModuleInfoList read FModuleInfoList write FModuleInfoList;
  128. property Prepared: Boolean read FPrepared write FPrepared;
  129. end;
  130. TJclStackTraceViewerThreadInfo = class(TJclCustomThreadInfo)
  131. private
  132. function GetStack(const AIndex: Integer): TJclStackTraceViewerLocationInfoList;
  133. protected
  134. function GetStackClass: TJclCustomLocationInfoListClass; override;
  135. public
  136. property CreationStack: TJclStackTraceViewerLocationInfoList index 1 read GetStack;
  137. property Stack: TJclStackTraceViewerLocationInfoList index 2 read GetStack;
  138. end;
  139. TJclStackTraceViewerThreadInfoList = class(TObject)
  140. private
  141. FItems: TObjectList;
  142. function GetItems(AIndex: Integer): TJclStackTraceViewerThreadInfo;
  143. function GetCount: Integer;
  144. public
  145. constructor Create;
  146. destructor Destroy; override;
  147. function Add: TJclStackTraceViewerThreadInfo;
  148. procedure Clear;
  149. property Count: Integer read GetCount;
  150. property Items[AIndex: Integer]: TJclStackTraceViewerThreadInfo read GetItems; default;
  151. end;
  152. TJclStackTraceViewerModuleModuleInfo = class(TJclSerializableModuleInfo, IJclModuleInfo)
  153. { IInterface }
  154. function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
  155. function _AddRef: Integer; stdcall;
  156. function _Release: Integer; stdcall;
  157. { IJclModuleInfo }
  158. function GetBinFileVersion: string;
  159. function GetModuleName: string;
  160. property BinFileVersion: string read GetBinFileVersion;
  161. property ModuleName: string read GetModuleName;
  162. end;
  163. TJclStackTraceViewerModuleInfoList = class(TInterfacedObject, IInterface, IJclModuleInfoList)
  164. private
  165. FItems: TObjectList;
  166. public
  167. constructor Create;
  168. destructor Destroy; override;
  169. function Add: TJclStackTraceViewerModuleModuleInfo;
  170. procedure Clear;
  171. { IInterface }
  172. // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
  173. function _AddRef: Integer; stdcall;
  174. function _Release: Integer; stdcall;
  175. { IJclModuleInfoList }
  176. function GetModuleCount: Integer;
  177. function GetModuleInfo(AIndex: Integer): IJclModuleInfo;
  178. property Count: Integer read GetModuleCount;
  179. property Items[AIndex: Integer]: IJclModuleInfo read GetModuleInfo; default;
  180. end;
  181. TJclStackTraceViewerExceptionInfo = class(TObject)
  182. private
  183. FException: TJclSerializableException;
  184. FThreadInfoList: TJclStackTraceViewerThreadInfoList;
  185. FModules: TJclStackTraceViewerModuleInfoList;
  186. procedure AddModuleListToStacks;
  187. public
  188. constructor Create;
  189. destructor Destroy; override;
  190. procedure AssignExceptionInfo(AExceptionInfo: TJclSerializableExceptionInfo);
  191. property ThreadInfoList: TJclStackTraceViewerThreadInfoList read FThreadInfoList;
  192. property Exception: TJclSerializableException read FException;
  193. property Modules: TJclStackTraceViewerModuleInfoList read FModules;
  194. end;
  195. {$IFDEF UNITVERSIONING}
  196. const
  197. UnitVersioning: TUnitVersionInfo = (
  198. RCSfile: '$URL$';
  199. Revision: '$Revision$';
  200. Date: '$Date$';
  201. LogPath: 'JCL\experts\stacktraceviewer';
  202. Extra: '';
  203. Data: nil
  204. );
  205. {$ENDIF UNITVERSIONING}
  206. implementation
  207. //=== { TJclStackTraceViewerLocationInfoList } ===============================
  208. function TJclStackTraceViewerLocationInfoList.Add(Addr: Pointer): TJclStackTraceViewerLocationInfo;
  209. begin
  210. Result := TJclStackTraceViewerLocationInfo(InternalAdd(Addr));
  211. end;
  212. constructor TJclStackTraceViewerLocationInfoList.Create;
  213. begin
  214. inherited Create;
  215. FItemClass := TJclStackTraceViewerLocationInfo;
  216. FOptions := [];
  217. FPrepared := False;
  218. end;
  219. function TJclStackTraceViewerLocationInfoList.GetCount: Integer;
  220. begin
  221. Result := FItems.Count;
  222. end;
  223. function TJclStackTraceViewerLocationInfoList.GetItems(AIndex: Integer): TJclStackTraceViewerLocationInfo;
  224. begin
  225. Result := TJclStackTraceViewerLocationInfo(FItems[AIndex]);
  226. end;
  227. function TJclStackTraceViewerLocationInfoList.GetLocationItems(AIndex: Integer): IJclLocationInfo;
  228. begin
  229. FItems[AIndex].GetInterface(IJclLocationInfo, Result);
  230. end;
  231. function TJclStackTraceViewerLocationInfoList.GetModuleInfoList: IJclModuleInfoList;
  232. begin
  233. Result := FModuleInfoList;
  234. end;
  235. function TJclStackTraceViewerLocationInfoList.GetPrepared: Boolean;
  236. begin
  237. Result := FPrepared;
  238. end;
  239. function TJclStackTraceViewerLocationInfoList.QueryInterface(const IID: TGUID; out Obj): HRESULT;
  240. begin
  241. if GetInterface(IID, Obj) then
  242. Result := S_OK
  243. else
  244. Result := E_NOINTERFACE;
  245. end;
  246. procedure TJclStackTraceViewerLocationInfoList.SetPrepared(AValue: Boolean);
  247. begin
  248. FPrepared := AValue;
  249. end;
  250. function TJclStackTraceViewerLocationInfoList._AddRef: Integer;
  251. begin
  252. Result := -1;
  253. end;
  254. function TJclStackTraceViewerLocationInfoList._Release: Integer;
  255. begin
  256. Result := -1;
  257. end;
  258. //=== { TJclStackTraceViewerThreadInfo } =====================================
  259. function TJclStackTraceViewerThreadInfo.GetStack(const AIndex: Integer): TJclStackTraceViewerLocationInfoList;
  260. begin
  261. case AIndex of
  262. 1: Result := TJclStackTraceViewerLocationInfoList(FCreationStack);
  263. 2: Result := TJclStackTraceViewerLocationInfoList(FStack);
  264. else
  265. Result := nil;
  266. end;
  267. end;
  268. function TJclStackTraceViewerThreadInfo.GetStackClass: TJclCustomLocationInfoListClass;
  269. begin
  270. Result := TJclStackTraceViewerLocationInfoList;
  271. end;
  272. //=== { TJclStackTraceViewerThreadInfoList } =================================
  273. constructor TJclStackTraceViewerThreadInfoList.Create;
  274. begin
  275. inherited Create;
  276. FItems := TObjectList.Create;
  277. end;
  278. destructor TJclStackTraceViewerThreadInfoList.Destroy;
  279. begin
  280. FItems.Free;
  281. inherited Destroy;
  282. end;
  283. function TJclStackTraceViewerThreadInfoList.Add: TJclStackTraceViewerThreadInfo;
  284. begin
  285. FItems.Add(TJclStackTraceViewerThreadInfo.Create);
  286. Result := TJclStackTraceViewerThreadInfo(FItems.Last);
  287. end;
  288. procedure TJclStackTraceViewerThreadInfoList.Clear;
  289. begin
  290. FItems.Clear;
  291. end;
  292. function TJclStackTraceViewerThreadInfoList.GetCount: Integer;
  293. begin
  294. Result := FItems.Count;
  295. end;
  296. function TJclStackTraceViewerThreadInfoList.GetItems(AIndex: Integer): TJclStackTraceViewerThreadInfo;
  297. begin
  298. Result := TJclStackTraceViewerThreadInfo(FItems[AIndex]);
  299. end;
  300. //=== { TJclStackTraceViewerExceptionInfo } ==================================
  301. constructor TJclStackTraceViewerExceptionInfo.Create;
  302. begin
  303. inherited Create;
  304. FException := TJclSerializableException.Create;
  305. FThreadInfoList := TJclStackTraceViewerThreadInfoList.Create;
  306. FModules := TJclStackTraceViewerModuleInfoList.Create;
  307. end;
  308. destructor TJclStackTraceViewerExceptionInfo.Destroy;
  309. begin
  310. FModules.Free;
  311. FException.Free;
  312. FThreadInfoList.Free;
  313. inherited Destroy;
  314. end;
  315. procedure TJclStackTraceViewerExceptionInfo.AddModuleListToStacks;
  316. var
  317. I: Integer;
  318. begin
  319. for I := 0 to FThreadInfoList.Count - 1 do
  320. FThreadInfoList[I].CreationStack.ModuleInfoList := FModules;
  321. for I := 0 to FThreadInfoList.Count - 1 do
  322. FThreadInfoList[I].Stack.ModuleInfoList := FModules;
  323. end;
  324. procedure TJclStackTraceViewerExceptionInfo.AssignExceptionInfo(AExceptionInfo: TJclSerializableExceptionInfo);
  325. var
  326. I: Integer;
  327. begin
  328. FException.Assign(AExceptionInfo.Exception);
  329. FThreadInfoList.Clear;
  330. for I := 0 to AExceptionInfo.ThreadInfoList.Count - 1 do
  331. FThreadInfoList.Add.Assign(AExceptionInfo.ThreadInfoList[I]);
  332. FModules.Clear;
  333. for I := 0 to AExceptionInfo.Modules.Count - 1 do
  334. FModules.Add.Assign(AExceptionInfo.Modules[I]);
  335. AddModuleListToStacks;
  336. end;
  337. { TJclStackTraceViewerLocationInfo }
  338. function TJclStackTraceViewerLocationInfo.QueryInterface(const IID: TGUID; out Obj): HRESULT;
  339. begin
  340. if GetInterface(IID, Obj) then
  341. Result := S_OK
  342. else
  343. Result := E_NOINTERFACE;
  344. end;
  345. function TJclStackTraceViewerLocationInfo._AddRef: Integer;
  346. begin
  347. Result := -1;
  348. end;
  349. function TJclStackTraceViewerLocationInfo._Release: Integer;
  350. begin
  351. Result := -1;
  352. end;
  353. procedure TJclStackTraceViewerLocationInfo.AssignTo(Dest: TPersistent);
  354. begin
  355. inherited AssignTo(Dest);
  356. if Dest is TJclStackTraceViewerLocationInfo then
  357. begin
  358. TJclStackTraceViewerLocationInfo(Dest).FFoundFile := FFoundFile;
  359. TJclStackTraceViewerLocationInfo(Dest).FFileName := FFileName;
  360. TJclStackTraceViewerLocationInfo(Dest).FProjectName := FProjectName;
  361. TJclStackTraceViewerLocationInfo(Dest).FRevision := FRevision;
  362. TJclStackTraceViewerLocationInfo(Dest).FTranslatedLineNumber := FTranslatedLineNumber;
  363. end;
  364. end;
  365. function TJclStackTraceViewerLocationInfo.GetAddress: Pointer;
  366. begin
  367. Result := Address;
  368. end;
  369. function TJclStackTraceViewerLocationInfo.GetBinaryFileName: string;
  370. begin
  371. Result := BinaryFileName;
  372. end;
  373. function TJclStackTraceViewerLocationInfo.GetFileName: string;
  374. begin
  375. Result := FFileName;
  376. end;
  377. function TJclStackTraceViewerLocationInfo.GetFoundFile: Boolean;
  378. begin
  379. Result := FFoundFile;
  380. end;
  381. function TJclStackTraceViewerLocationInfo.GetLineNumber: Integer;
  382. begin
  383. Result := LineNumber;
  384. end;
  385. function TJclStackTraceViewerLocationInfo.GetLineNumberOffsetFromProcedureStart: Integer;
  386. begin
  387. Result := LineNumberOffsetFromProcedureStart;
  388. end;
  389. function TJclStackTraceViewerLocationInfo.GetModuleName: string;
  390. begin
  391. Result := ModuleName;
  392. end;
  393. function TJclStackTraceViewerLocationInfo.GetOffsetFromLineNumber: Integer;
  394. begin
  395. Result := OffsetFromLineNumber;
  396. end;
  397. function TJclStackTraceViewerLocationInfo.GetOffsetFromProcName: Integer;
  398. begin
  399. Result := OffsetFromProcName;
  400. end;
  401. function TJclStackTraceViewerLocationInfo.GetProcedureName: string;
  402. begin
  403. Result := ProcedureName;
  404. end;
  405. function TJclStackTraceViewerLocationInfo.GetProjectName: string;
  406. begin
  407. Result := FProjectName;
  408. end;
  409. function TJclStackTraceViewerLocationInfo.GetRevision: string;
  410. begin
  411. Result := FRevision;
  412. end;
  413. function TJclStackTraceViewerLocationInfo.GetSourceName: string;
  414. begin
  415. Result := SourceName;
  416. end;
  417. function TJclStackTraceViewerLocationInfo.GetSourceUnitName: string;
  418. begin
  419. Result := SourceUnitName;
  420. end;
  421. function TJclStackTraceViewerLocationInfo.GetTranslatedLineNumber: Integer;
  422. begin
  423. Result := FTranslatedLineNumber;
  424. end;
  425. function TJclStackTraceViewerLocationInfo.GetUnitVersionDateTime: TDateTime;
  426. begin
  427. Result := UnitVersionDateTime;
  428. end;
  429. function TJclStackTraceViewerLocationInfo.GetUnitVersionExtra: string;
  430. begin
  431. Result := UnitVersionExtra;
  432. end;
  433. function TJclStackTraceViewerLocationInfo.GetUnitVersionLogPath: string;
  434. begin
  435. Result := UnitVersionLogPath;
  436. end;
  437. function TJclStackTraceViewerLocationInfo.GetUnitVersionRCSfile: string;
  438. begin
  439. Result := UnitVersionRCSfile;
  440. end;
  441. function TJclStackTraceViewerLocationInfo.GetUnitVersionRevision: string;
  442. begin
  443. Result := UnitVersionRevision;
  444. end;
  445. function TJclStackTraceViewerLocationInfo.GetVAddress: Pointer;
  446. begin
  447. Result := VAddress;
  448. end;
  449. function TJclStackTraceViewerLocationInfo.GetValues: Integer;
  450. begin
  451. Result := 0;
  452. if lievLocationInfo in (inherited Values) then
  453. Inc(Result, livLocationInfo);
  454. if lievProcedureStartLocationInfo in (inherited Values) then
  455. Inc(Result, livProcedureStartLocationInfo);
  456. if lievUnitVersionInfo in (inherited Values) then
  457. Inc(Result, livUnitVersionInfo);
  458. end;
  459. procedure TJclStackTraceViewerLocationInfo.SetFileName(AValue: string);
  460. begin
  461. FFileName := AValue;
  462. end;
  463. procedure TJclStackTraceViewerLocationInfo.SetFoundFile(AValue: Boolean);
  464. begin
  465. FFoundFile := AValue;
  466. end;
  467. procedure TJclStackTraceViewerLocationInfo.SetProjectName(AValue: string);
  468. begin
  469. FProjectName := AValue;
  470. end;
  471. procedure TJclStackTraceViewerLocationInfo.SetRevision(AValue: string);
  472. begin
  473. FRevision := AValue;
  474. end;
  475. procedure TJclStackTraceViewerLocationInfo.SetTranslatedLineNumber(AValue: Integer);
  476. begin
  477. FTranslatedLineNumber := AValue;
  478. end;
  479. { TJclStackTraceViewerModuleModuleInfo }
  480. function TJclStackTraceViewerModuleModuleInfo.GetBinFileVersion: string;
  481. begin
  482. Result := BinFileVersion;
  483. end;
  484. function TJclStackTraceViewerModuleModuleInfo.GetModuleName: string;
  485. begin
  486. Result := ModuleName;
  487. end;
  488. function TJclStackTraceViewerModuleModuleInfo.QueryInterface(const IID: TGUID; out Obj): HRESULT;
  489. begin
  490. if GetInterface(IID, Obj) then
  491. Result := S_OK
  492. else
  493. Result := E_NOINTERFACE;
  494. end;
  495. function TJclStackTraceViewerModuleModuleInfo._AddRef: Integer;
  496. begin
  497. Result := -1;
  498. end;
  499. function TJclStackTraceViewerModuleModuleInfo._Release: Integer;
  500. begin
  501. Result := -1;
  502. end;
  503. { TJclStackTraceViewerModuleInfoList }
  504. function TJclStackTraceViewerModuleInfoList.Add: TJclStackTraceViewerModuleModuleInfo;
  505. begin
  506. FItems.Add(TJclStackTraceViewerModuleModuleInfo.Create);
  507. Result := TJclStackTraceViewerModuleModuleInfo(FItems.Last);
  508. end;
  509. procedure TJclStackTraceViewerModuleInfoList.Clear;
  510. begin
  511. FItems.Clear;
  512. end;
  513. constructor TJclStackTraceViewerModuleInfoList.Create;
  514. begin
  515. inherited Create;
  516. FItems := TObjectList.Create;
  517. end;
  518. destructor TJclStackTraceViewerModuleInfoList.Destroy;
  519. begin
  520. FItems.Free;
  521. inherited Destroy;
  522. end;
  523. function TJclStackTraceViewerModuleInfoList.GetModuleCount: Integer;
  524. begin
  525. Result := FItems.Count;
  526. end;
  527. function TJclStackTraceViewerModuleInfoList.GetModuleInfo(AIndex: Integer): IJclModuleInfo;
  528. begin
  529. FItems[AIndex].GetInterface(IJclModuleInfo, Result);
  530. end;
  531. function TJclStackTraceViewerModuleInfoList._AddRef: Integer;
  532. begin
  533. Result := -1;
  534. end;
  535. function TJclStackTraceViewerModuleInfoList._Release: Integer;
  536. begin
  537. Result := -1;
  538. end;
  539. {$IFDEF UNITVERSIONING}
  540. initialization
  541. RegisterUnitVersion(HInstance, UnitVersioning);
  542. finalization
  543. UnregisterUnitVersion(HInstance);
  544. {$ENDIF UNITVERSIONING}
  545. end.