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	torben	2671	(* *** 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.