tpsystools_4.04/source/StExpEng.pas

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StExpLog.pas 4.03                           *}
{*********************************************************}
{* SysTools: Exception Logging                           *}
{*********************************************************}

{$I StDefine.inc}

unit StExpEng;

interface

uses
  Windows, SysUtils, Classes, StBase, StExpLog;

const
  OnHookInstaller : procedure = nil;

procedure DumpException;

implementation

uses
  Forms;

const
  MaxStackSize  = 48;

type
  TStExceptionHandler = class
  private
    OldOnException : TExceptionEvent;
  protected
    procedure OnException(Sender : TObject; E : Exception);
  end;

  TStExceptionTrace = record
    Count : Integer;
    Trace : array[0..pred(MaxStackSize)] of DWORD;
  end;

const
  EH : TStExceptionHandler = nil;
  WroteInfo : Boolean = False;
  HandlerInstalled : Boolean = False;
  cDelphiException = DWORD($0EEDFADE);
  cCppException = DWORD($0EEFFACE); { used by BCB }

var
  RA2 : procedure (dwExceptionCode, dwExceptionFlags, nNumberOfArguments : DWORD;
    const lpArguments : DWORD); stdcall;
  BaseOfCode, TopOfCode : DWORD;

{ Writes exception to log file }
procedure WriteException(E : Exception);
var
  p1 : Integer;
  RipFileName, S : string;
  FS : TFileStream;
  Buffer : array[0..255] of AnsiChar;
begin
  if Assigned(ExpLog) then
    RipFileName := ExpLog.FileName;

  if RipFileName = '' then begin
    GetModuleFileName(HInstance, Buffer, SizeOf(Buffer));
    RipFileName := ChangeFileExt(PChar(@Buffer),'.RIP');
  end;

  { Open file stream }
  if FileExists(RipFileName) then begin
    FS := TFileStream.Create(RipFileName, fmOpenReadWrite or fmShareDenyWrite);
    FS.Seek(0, soFromEnd);
    S := #13#10#13#10;
    FS.Write(S[1], Length(S));
  end else begin
    FS := TFileStream.Create(RipFileName, fmCreate or fmShareDenyWrite);
  end;

  try
    { Write info if necessary }
    if not WroteInfo and Assigned(ExpLog) then begin
      if (ExpLog.RipInfo <> '') then begin
        S := ExpLog.RipInfo + #13#10#13#10;
        FS.Write(S[1], Length(S));
      end;
      WroteInfo := True;
    end;

    { Write dump info from E.Message }
    p1 := Pos(#0, E.Message);
    S := Copy(E.Message, p1+1, MaxInt) + #13#10;
    FS.Write(S[1], Length(S));

    { Restore E.Message }
    S := E.Message;
    SetLength(S, P1-1);
    E.Message := S;

  finally
    FS.Free;
  end;
end;

{ Dumps Exception }
procedure DumpException;
var
  PutInLog : Boolean;
begin
  PutInLog := True;
  if Assigned(ExpLog) then
    ExpLog.DoExceptionFilter(Exception(ExceptObject),PutInLog);
  if PutInLog then
    WriteException(Exception(ExceptObject));
end;

{ TStExceptionHandler }

procedure TStExceptionHandler.OnException(Sender : TObject; E : Exception);
begin
  DumpException;
  if Assigned(OldOnException) then
    OldOnException(Sender, E)
  else
    Application.ShowException(Exception(ExceptObject));
end;

var
  SaveGetExceptionObject : function(P : PExceptionRecord) : Exception;

procedure HookInstaller;
begin
  EH := TStExceptionHandler.Create;
  EH.OldOnException := Application.OnException;
  Application.OnException := EH.OnException;
end;

procedure StackDump(E : Exception; Root : DWORD);
var
  P : PDWORD;
  C, D, StackTop, N, Prev : DWORD;
  Trace : TStExceptionTrace;
  I : Integer;
  Store : Boolean;
  MsgPtr : PChar;
  MsgLen : Integer;
begin
  if not HandlerInstalled then begin
    if Assigned(OnHookInstaller) then
      OnHookInstaller;
    HandlerInstalled := True;
  end;

  if Root = 0 then
    Trace.Count := 0
  else begin
    Trace.Count := 1;
    Trace.Trace[0] := Root;
  end;

  asm
    mov P,ebp
    mov eax,fs:[4]
    mov [StackTop],eax
  end;

  Prev := 0;
  C := 0;

  while DWORD(P) < DWORD(StackTop) do begin
    D := P^;
    N := 0;
    if (D >= BaseOfCode) and (D < TopOfCode) then
      if (PByte(D-5)^ = $E8)
      or ((PByte(D-6)^ = $FF) and (((PByte(D-5)^ and $38) = $10)))
      or ((PByte(D-4)^ = $FF) and (((PByte(D-3)^ and $38) = $10)))
      or ((PByte(D-3)^ = $FF) and (((PByte(D-2)^ and $38) = $10)))
      or ((PByte(D-2)^ = $FF) and (((PByte(D-1)^ and $38) = $10))) then
        N := D-BaseOfCode;
    if (N <> 0) and (N <> Prev) then begin
     if (Root = 0) then
        Store := C > 0
      else
        Store := C > 1;
      if Store then
        begin
          Trace.Trace[Trace.Count] := N;
          Inc(Trace.Count);
        end;
      Inc(C);
      if C > MaxStackSize then Break;
      Prev := N;
    end;
    Inc(P);
  end;

  if C > 0 then begin
    MsgPtr := PChar(E.Message);
    MsgLen := StrLen(MsgPtr);
    if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then
      E.Message := E.Message + '.';
    E.Message := E.Message  + #0 + Format('Fault : %s'#13#10'Date/time : %s %s'#13#10'Stack dump'#13#10+
      '----------'#13#10,[E.Message,DateToStr(Now),TimeToStr(Now)]);
    for i := 0 to pred(Trace.Count) do
      E.Message := E.Message + Format('%8.8x'#13#10,[Trace.Trace[i]]);
  end;
end;

procedure LRE(dwExceptionCode, dwExceptionFlags, nNumberOfArguments : DWORD;
  const lpArguments : DWORD); stdcall;
var
  E : Exception;
begin
  if (dwExceptionCode = cDelphiException) or (dwExceptionCode = cCppException) then begin
    asm
      push ebx
      mov  ebx,lpArguments
      mov  eax,ss:[ebx+4]
      mov  E,eax
      pop  ebx
    end;
    if assigned(E) then
      StackDump(E, 0);
  end;
  if Assigned(RA2) then
    RA2(dwExceptionCode, dwExceptionFlags, nNumberOfArguments, lpArguments);
end;

function HookGetExceptionObject(P : PExceptionRecord) : Exception;
begin
  Result := SaveGetExceptionObject(P);
  StackDump(Result, DWORD(P^.ExceptionAddress)-BaseOfCode);
end;

procedure InitializeEng;
const
  ImageNumberofDirectoryEntries = 16;
  ImageDirectoryEntryImport     = 1;

type

  PImageImportByName = ^TImageImportByName;
  TImageImportByName = packed record
    Hint : WORD;
    Name : array[0..255] of char;
  end;

  PImageThunkData = ^TImageThunkData;
  TImageThunkData = packed record
    case Integer of
    1 : (Funct : ^DWORD);
    2 : (Ordinal : DWORD);
    3 : (AddressOfData : PImageImportByName);
  end;

  PImageImportDescriptor = ^TImageImportDescriptor;
  TImageImportDescriptor = packed record
    Characteristics : DWORD;
    TimeDateStamp : DWORD;
    ForwarderChain : DWORD;
    Name : DWORD;
    FirstThunk : PImageThunkData;
  end;

  PImageDosHeader = ^TImageDosHeader;
  TImageDosHeader = packed record
    e_magic : WORD;
    e_cblp : WORD;
    e_cp : WORD;
    e_crlc : WORD;
    e_cparhdr : WORD;
    e_minalloc : WORD;
    e_maxalloc : WORD;
    e_ss : WORD;
    e_sp : WORD;
    e_csum : WORD;
    e_ip : WORD;
    e_cs : WORD;
    e_lfarlc : WORD;
    e_ovno : WORD;
    e_res : array [0..3] of WORD;
    e_oemid : WORD;
    e_oeminfo : WORD;
    e_res2 : array [0..9] of WORD;
    e_lfanew : DWORD;
  end;

var
  OriginalProc : Pointer;
  NTHeader : PImageNTHeaders;
  ImportDesc : PImageImportDescriptor;
  Thunk : PImageThunkData;

begin
  RA2 := nil;
  OriginalProc := GetProcAddress(GetModuleHandle('kernel32.dll'), 'RaiseException');

  if OriginalProc <> nil then begin
    NTHeader := PImageNTHeaders(DWORD(hInstance) + PImageDosHeader(hInstance).e_lfanew);
    ImportDesc := PImageImportDescriptor(DWORD(hInstance) +
      NTHeader.OptionalHeader.DataDirectory[ImageDirectoryEntryImport].VirtualAddress);

    BaseOfCode := DWORD(hInstance) + NTHeader.OptionalHeader.BaseOfCode;
    TopOfCode := BaseOfCode + NTHeader.OptionalHeader.SizeOfCode;

    while ImportDesc.Name <> 0 do begin
      if StriComp(PChar(DWORD(hInstance) + ImportDesc.Name), 'kernel32.dll') = 0 then begin
        Thunk := PImageThunkData(DWORD(hInstance) + DWORD(ImportDesc.FirstThunk));
        while Thunk.Funct <> nil do begin
          if Thunk.Funct = OriginalProc then
            Thunk.Funct := @LRE;
          Inc(Thunk);
        end;
      end;
      Inc(ImportDesc);
    end;
    RA2 := OriginalProc;
  end;
  SaveGetExceptionObject := ExceptObjProc;
  ExceptObjProc := @HookGetExceptionObject;
end;

initialization
  OnHookInstaller := HookInstaller;
  {$WARNINGS OFF}  { Yeah, we know DebugHook is platform specific }
  if DebugHook = 0 then InitializeEng;
  {$WARNINGS ON}

finalization
  EH.Free;

end.
1	(* *** BEGIN LICENSE BLOCK ***
2	* Version: MPL 1.1
3	*
4	* The contents of this file are subject to the Mozilla Public License Version
5	* 1.1 (the "License"); you may not use this file except in compliance with
6	* the License. You may obtain a copy of the License at
7	* http://www.mozilla.org/MPL/
8	*
9	* Software distributed under the License is distributed on an "AS IS" basis,
10	* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
11	* for the specific language governing rights and limitations under the
12	* License.
13	*
14	* The Original Code is TurboPower SysTools
15	*
16	* The Initial Developer of the Original Code is
17	* TurboPower Software
18	*
19	* Portions created by the Initial Developer are Copyright (C) 1996-2002
20	* the Initial Developer. All Rights Reserved.
21	*
22	* Contributor(s):
23	*
24	* *** END LICENSE BLOCK *** *)
25
26	{*********************************************************}
27	{* SysTools: StExpLog.pas 4.03 *}
28	{*********************************************************}
29	{* SysTools: Exception Logging *}
30	{*********************************************************}
31
32	{$I StDefine.inc}
33
34	unit StExpEng;
35
36	interface
37
38	uses
39	Windows, SysUtils, Classes, StBase, StExpLog;
40
41	const
42	OnHookInstaller : procedure = nil;
43
44	procedure DumpException;
45
46	implementation
47
48	uses
49	Forms;
50
51	const
52	MaxStackSize = 48;
53
54	type
55	TStExceptionHandler = class
56	private
57	OldOnException : TExceptionEvent;
58	protected
59	procedure OnException(Sender : TObject; E : Exception);
60	end;
61
62	TStExceptionTrace = record
63	Count : Integer;
64	Trace : array[0..pred(MaxStackSize)] of DWORD;
65	end;
66
67	const
68	EH : TStExceptionHandler = nil;
69	WroteInfo : Boolean = False;
70	HandlerInstalled : Boolean = False;
71	cDelphiException = DWORD($0EEDFADE);
72	cCppException = DWORD($0EEFFACE); { used by BCB }
73
74	var
75	RA2 : procedure (dwExceptionCode, dwExceptionFlags, nNumberOfArguments : DWORD;
76	const lpArguments : DWORD); stdcall;
77	BaseOfCode, TopOfCode : DWORD;
78
79	{ Writes exception to log file }
80	procedure WriteException(E : Exception);
81	var
82	p1 : Integer;
83	RipFileName, S : string;
84	FS : TFileStream;
85	Buffer : array[0..255] of AnsiChar;
86	begin
87	if Assigned(ExpLog) then
88	RipFileName := ExpLog.FileName;
89
90	if RipFileName = '' then begin
91	GetModuleFileName(HInstance, Buffer, SizeOf(Buffer));
92	RipFileName := ChangeFileExt(PChar(@Buffer),'.RIP');
93	end;
94
95	{ Open file stream }
96	if FileExists(RipFileName) then begin
97	FS := TFileStream.Create(RipFileName, fmOpenReadWrite or fmShareDenyWrite);
98	FS.Seek(0, soFromEnd);
99	S := #13#10#13#10;
100	FS.Write(S[1], Length(S));
101	end else begin
102	FS := TFileStream.Create(RipFileName, fmCreate or fmShareDenyWrite);
103	end;
104
105	try
106	{ Write info if necessary }
107	if not WroteInfo and Assigned(ExpLog) then begin
108	if (ExpLog.RipInfo <> '') then begin
109	S := ExpLog.RipInfo + #13#10#13#10;
110	FS.Write(S[1], Length(S));
111	end;
112	WroteInfo := True;
113	end;
114
115	{ Write dump info from E.Message }
116	p1 := Pos(#0, E.Message);
117	S := Copy(E.Message, p1+1, MaxInt) + #13#10;
118	FS.Write(S[1], Length(S));
119
120	{ Restore E.Message }
121	S := E.Message;
122	SetLength(S, P1-1);
123	E.Message := S;
124
125	finally
126	FS.Free;
127	end;
128	end;
129
130	{ Dumps Exception }
131	procedure DumpException;
132	var
133	PutInLog : Boolean;
134	begin
135	PutInLog := True;
136	if Assigned(ExpLog) then
137	ExpLog.DoExceptionFilter(Exception(ExceptObject),PutInLog);
138	if PutInLog then
139	WriteException(Exception(ExceptObject));
140	end;
141
142	{ TStExceptionHandler }
143
144	procedure TStExceptionHandler.OnException(Sender : TObject; E : Exception);
145	begin
146	DumpException;
147	if Assigned(OldOnException) then
148	OldOnException(Sender, E)
149	else
150	Application.ShowException(Exception(ExceptObject));
151	end;
152
153	var
154	SaveGetExceptionObject : function(P : PExceptionRecord) : Exception;
155
156	procedure HookInstaller;
157	begin
158	EH := TStExceptionHandler.Create;
159	EH.OldOnException := Application.OnException;
160	Application.OnException := EH.OnException;
161	end;
162
163	procedure StackDump(E : Exception; Root : DWORD);
164	var
165	P : PDWORD;
166	C, D, StackTop, N, Prev : DWORD;
167	Trace : TStExceptionTrace;
168	I : Integer;
169	Store : Boolean;
170	MsgPtr : PChar;
171	MsgLen : Integer;
172	begin
173	if not HandlerInstalled then begin
174	if Assigned(OnHookInstaller) then
175	OnHookInstaller;
176	HandlerInstalled := True;
177	end;
178
179	if Root = 0 then
180	Trace.Count := 0
181	else begin
182	Trace.Count := 1;
183	Trace.Trace[0] := Root;
184	end;
185
186	asm
187	mov P,ebp
188	mov eax,fs:[4]
189	mov [StackTop],eax
190	end;
191
192	Prev := 0;
193	C := 0;
194
195	while DWORD(P) < DWORD(StackTop) do begin
196	D := P^;
197	N := 0;
198	if (D >= BaseOfCode) and (D < TopOfCode) then
199	if (PByte(D-5)^ = $E8)
200	or ((PByte(D-6)^ = $FF) and (((PByte(D-5)^ and $38) = $10)))
201	or ((PByte(D-4)^ = $FF) and (((PByte(D-3)^ and $38) = $10)))
202	or ((PByte(D-3)^ = $FF) and (((PByte(D-2)^ and $38) = $10)))
203	or ((PByte(D-2)^ = $FF) and (((PByte(D-1)^ and $38) = $10))) then
204	N := D-BaseOfCode;
205	if (N <> 0) and (N <> Prev) then begin
206	if (Root = 0) then
207	Store := C > 0
208	else
209	Store := C > 1;
210	if Store then
211	begin
212	Trace.Trace[Trace.Count] := N;
213	Inc(Trace.Count);
214	end;
215	Inc(C);
216	if C > MaxStackSize then Break;
217	Prev := N;
218	end;
219	Inc(P);
220	end;
221
222	if C > 0 then begin
223	MsgPtr := PChar(E.Message);
224	MsgLen := StrLen(MsgPtr);
225	if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then
226	E.Message := E.Message + '.';
227	E.Message := E.Message + #0 + Format('Fault : %s'#13#10'Date/time : %s %s'#13#10'Stack dump'#13#10+
228	'----------'#13#10,[E.Message,DateToStr(Now),TimeToStr(Now)]);
229	for i := 0 to pred(Trace.Count) do
230	E.Message := E.Message + Format('%8.8x'#13#10,[Trace.Trace[i]]);
231	end;
232	end;
233
234	procedure LRE(dwExceptionCode, dwExceptionFlags, nNumberOfArguments : DWORD;
235	const lpArguments : DWORD); stdcall;
236	var
237	E : Exception;
238	begin
239	if (dwExceptionCode = cDelphiException) or (dwExceptionCode = cCppException) then begin
240	asm
241	push ebx
242	mov ebx,lpArguments
243	mov eax,ss:[ebx+4]
244	mov E,eax
245	pop ebx
246	end;
247	if assigned(E) then
248	StackDump(E, 0);
249	end;
250	if Assigned(RA2) then
251	RA2(dwExceptionCode, dwExceptionFlags, nNumberOfArguments, lpArguments);
252	end;
253
254	function HookGetExceptionObject(P : PExceptionRecord) : Exception;
255	begin
256	Result := SaveGetExceptionObject(P);
257	StackDump(Result, DWORD(P^.ExceptionAddress)-BaseOfCode);
258	end;
259
260	procedure InitializeEng;
261	const
262	ImageNumberofDirectoryEntries = 16;
263	ImageDirectoryEntryImport = 1;
264
265	type
266
267	PImageImportByName = ^TImageImportByName;
268	TImageImportByName = packed record
269	Hint : WORD;
270	Name : array[0..255] of char;
271	end;
272
273	PImageThunkData = ^TImageThunkData;
274	TImageThunkData = packed record
275	case Integer of
276	1 : (Funct : ^DWORD);
277	2 : (Ordinal : DWORD);
278	3 : (AddressOfData : PImageImportByName);
279	end;
280
281	PImageImportDescriptor = ^TImageImportDescriptor;
282	TImageImportDescriptor = packed record
283	Characteristics : DWORD;
284	TimeDateStamp : DWORD;
285	ForwarderChain : DWORD;
286	Name : DWORD;
287	FirstThunk : PImageThunkData;
288	end;
289
290	PImageDosHeader = ^TImageDosHeader;
291	TImageDosHeader = packed record
292	e_magic : WORD;
293	e_cblp : WORD;
294	e_cp : WORD;
295	e_crlc : WORD;
296	e_cparhdr : WORD;
297	e_minalloc : WORD;
298	e_maxalloc : WORD;
299	e_ss : WORD;
300	e_sp : WORD;
301	e_csum : WORD;
302	e_ip : WORD;
303	e_cs : WORD;
304	e_lfarlc : WORD;
305	e_ovno : WORD;
306	e_res : array [0..3] of WORD;
307	e_oemid : WORD;
308	e_oeminfo : WORD;
309	e_res2 : array [0..9] of WORD;
310	e_lfanew : DWORD;
311	end;
312
313	var
314	OriginalProc : Pointer;
315	NTHeader : PImageNTHeaders;
316	ImportDesc : PImageImportDescriptor;
317	Thunk : PImageThunkData;
318
319	begin
320	RA2 := nil;
321	OriginalProc := GetProcAddress(GetModuleHandle('kernel32.dll'), 'RaiseException');
322
323	if OriginalProc <> nil then begin
324	NTHeader := PImageNTHeaders(DWORD(hInstance) + PImageDosHeader(hInstance).e_lfanew);
325	ImportDesc := PImageImportDescriptor(DWORD(hInstance) +
326	NTHeader.OptionalHeader.DataDirectory[ImageDirectoryEntryImport].VirtualAddress);
327
328	BaseOfCode := DWORD(hInstance) + NTHeader.OptionalHeader.BaseOfCode;
329	TopOfCode := BaseOfCode + NTHeader.OptionalHeader.SizeOfCode;
330
331	while ImportDesc.Name <> 0 do begin
332	if StriComp(PChar(DWORD(hInstance) + ImportDesc.Name), 'kernel32.dll') = 0 then begin
333	Thunk := PImageThunkData(DWORD(hInstance) + DWORD(ImportDesc.FirstThunk));
334	while Thunk.Funct <> nil do begin
335	if Thunk.Funct = OriginalProc then
336	Thunk.Funct := @LRE;
337	Inc(Thunk);
338	end;
339	end;
340	Inc(ImportDesc);
341	end;
342	RA2 := OriginalProc;
343	end;
344	SaveGetExceptionObject := ExceptObjProc;
345	ExceptObjProc := @HookGetExceptionObject;
346	end;
347
348	initialization
349	OnHookInstaller := HookInstaller;
350	{$WARNINGS OFF} { Yeah, we know DebugHook is platform specific }
351	if DebugHook = 0 then InitializeEng;
352	{$WARNINGS ON}
353
354	finalization
355	EH.Free;
356
357	end.