1 | // You have to turn on generating of detailed map file!
|
---|
2 | // Release date 24.2.2006
|
---|
3 |
|
---|
4 | unit ULogExceptions;
|
---|
5 |
|
---|
6 | interface
|
---|
7 |
|
---|
8 | uses
|
---|
9 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
---|
10 | Dialogs, StdCtrls, Sockets, ExtCtrls, Registry, UMapFile, WinSock, MemCheck;
|
---|
11 |
|
---|
12 | const
|
---|
13 | ErrorLogHost = 'www.zdechov.net';
|
---|
14 | ErrorLogScript = 'jirihajda/error.php';
|
---|
15 | NazevSouboru = 'Error.txt';
|
---|
16 |
|
---|
17 | type
|
---|
18 | TStoreError = class(TThread)
|
---|
19 | Bezi: Boolean;
|
---|
20 | procedure Execute; override;
|
---|
21 | end;
|
---|
22 |
|
---|
23 | TRadekInfoVyjimky = record
|
---|
24 | Popis: string;
|
---|
25 | Text: string;
|
---|
26 | end;
|
---|
27 |
|
---|
28 | TLogExceptions = class(TForm)
|
---|
29 | Label1: TLabel;
|
---|
30 | Button1: TButton;
|
---|
31 | Edit1: TEdit;
|
---|
32 | Label2: TLabel;
|
---|
33 | Button2: TButton;
|
---|
34 | Memo1: TMemo;
|
---|
35 | Image1: TImage;
|
---|
36 | CheckBox1: TCheckBox;
|
---|
37 | TcpClient1: TTcpClient;
|
---|
38 | procedure Button2Click(Sender: TObject);
|
---|
39 | procedure FormShow(Sender: TObject);
|
---|
40 | procedure Button1Click(Sender: TObject);
|
---|
41 | procedure FormCreate(Sender: TObject);
|
---|
42 | procedure FormClose(Sender: TObject; var Action: TCloseAction);
|
---|
43 | procedure FormDestroy(Sender: TObject);
|
---|
44 | private
|
---|
45 | FMapFile: TMapFile;
|
---|
46 | // Report: string;
|
---|
47 | StoreError: TStoreError;
|
---|
48 | Data: array of TRadekInfoVyjimky;
|
---|
49 | Vyska: Integer;
|
---|
50 | procedure Send;
|
---|
51 | public
|
---|
52 | Stav: string; // Obsah lokálních promìnných
|
---|
53 | NazevAplikace: string; // Název aplikace
|
---|
54 | AppReleaseDate: string;
|
---|
55 | AppVersion: string;
|
---|
56 | procedure Obsluha(Sender : TObject; E : Exception );
|
---|
57 | procedure Pridat(NovyPopis, NovyText: string);
|
---|
58 | end;
|
---|
59 |
|
---|
60 | var
|
---|
61 | LogExceptions: TLogExceptions;
|
---|
62 |
|
---|
63 | implementation
|
---|
64 |
|
---|
65 | {$R *.dfm}
|
---|
66 |
|
---|
67 | { TOsetreniVyjimek }
|
---|
68 |
|
---|
69 | function ReturnAddr(Index: Integer): Pointer;
|
---|
70 | asm
|
---|
71 | MOV EAX,[EBP + Index * 4]
|
---|
72 | end;
|
---|
73 |
|
---|
74 | procedure TLogExceptions.Obsluha(Sender: TObject; E: Exception);
|
---|
75 | var
|
---|
76 | // ExtRec: PExceptionRecord;
|
---|
77 | // Log: string;
|
---|
78 | Soubor: TextFile;
|
---|
79 | I: Integer;
|
---|
80 | Stack: TCallStack;
|
---|
81 | begin
|
---|
82 | FMapFile.LoadExceptionData;
|
---|
83 | // ShowMessage();
|
---|
84 | Pridat('Èas', DateTimeToStr(Now));
|
---|
85 | Pridat('Aplikace', NazevAplikace);
|
---|
86 | Pridat('Verze', AppVersion);
|
---|
87 | Pridat('Datum vydání', AppReleaseDate);
|
---|
88 | Pridat('Text chyby', E.Message);
|
---|
89 | Pridat('Tøída vyjímky', E.ClassName);
|
---|
90 | Pridat('Adresa', Format('%p', [ReturnAddr(6)]));
|
---|
91 | Pridat('Jednotka', FMapFile.ExceptUnitName);
|
---|
92 | Pridat('Metoda', FMapFile.ExceptMethodName);
|
---|
93 | Pridat('Øádek', IntToStr(FMapFile.ExceptLineNumber));
|
---|
94 | Pridat('Stavové informace', Stav);
|
---|
95 | Pridat('Zásobník volání', TextualDebugInfoForAddress(Cardinal(ReturnAddr(6))));
|
---|
96 |
|
---|
97 | FillCallStack(Stack, 0);
|
---|
98 | Pridat('Callstack', CallStackTextualRepresentation(Stack, ''));
|
---|
99 | for I := 0 to Length(Stack) - 1 do begin
|
---|
100 | FMapFile.LoadExceptionData(Stack[I]);
|
---|
101 | Pridat('CallStackAddress', Format('%p', [Stack[I]]));
|
---|
102 | Pridat('Adresa', Format('%p', [ReturnAddr(6)]));
|
---|
103 | Pridat('Jednotka', FMapFile.ExceptUnitName);
|
---|
104 | Pridat('Metoda', FMapFile.ExceptMethodName);
|
---|
105 | Pridat('Øádek', IntToStr(FMapFile.ExceptLineNumber));
|
---|
106 | end;
|
---|
107 |
|
---|
108 | ShowModal; // Uka dialog
|
---|
109 |
|
---|
110 | if Edit1.Text <> '' then Pridat('Komentáø uivatele', Edit1.Text);
|
---|
111 |
|
---|
112 | // Uloit chybu do souboru
|
---|
113 | AssignFile(Soubor, NazevSouboru);
|
---|
114 | try
|
---|
115 | if FileExists(NazevSouboru) then Append(Soubor) else Rewrite(Soubor);
|
---|
116 | WriteLn(Soubor);
|
---|
117 | for I := 0 to High(Data) do WriteLn(Soubor, Data[I].Popis + ': ' + Data[I].Text);
|
---|
118 | finally
|
---|
119 | CloseFile(Soubor);
|
---|
120 | end;
|
---|
121 | StoreError.Execute;
|
---|
122 | end;
|
---|
123 |
|
---|
124 | procedure TLogExceptions.Pridat(NovyPopis, NovyText: string);
|
---|
125 | begin
|
---|
126 | SetLength(Data, Length(Data) + 1);
|
---|
127 | with Data[High(Data)] do begin
|
---|
128 | Popis := NovyPopis;
|
---|
129 | Text := NovyText;
|
---|
130 | end;
|
---|
131 | end;
|
---|
132 |
|
---|
133 | procedure TLogExceptions.Send;
|
---|
134 | var
|
---|
135 | I: Integer;
|
---|
136 | //II: Integer;
|
---|
137 | Hlaseni: string;
|
---|
138 | //Buf: array[0..10000] of Char;
|
---|
139 | //Pocet: Integer;
|
---|
140 | // Radek: string;
|
---|
141 | UseProxy: Boolean;
|
---|
142 | ProxyServer: string;
|
---|
143 | ProxyPort: string;
|
---|
144 | HostHTTP: string;
|
---|
145 | begin
|
---|
146 | // Check if proxy server enabled
|
---|
147 | with TRegistry.Create do try
|
---|
148 | RootKey := HKEY_CURRENT_USER;
|
---|
149 | OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings', False);
|
---|
150 | UseProxy := ReadBool('ProxyEnable');
|
---|
151 | ProxyServer := ReadString('ProxyServer');
|
---|
152 | finally
|
---|
153 | Free;
|
---|
154 | end;
|
---|
155 |
|
---|
156 | // Generate report
|
---|
157 | Hlaseni := '';
|
---|
158 | for I := 0 to High(Data) do with Data[I] do
|
---|
159 | Hlaseni := Hlaseni + '&' + Popis + '=' + Text;
|
---|
160 | Delete(Hlaseni, 1, 1);
|
---|
161 |
|
---|
162 | // Replace blank spaces by special char %20
|
---|
163 | while Pos(' ', Hlaseni) > 0 do
|
---|
164 | Hlaseni := Copy(Hlaseni, 1, Pos(' ', Hlaseni)-1) + '%20' + Copy(Hlaseni, Pos(' ', Hlaseni) + 1, Length(Hlaseni));
|
---|
165 |
|
---|
166 | if UseProxy then begin
|
---|
167 | ProxyPort := Copy(ProxyServer,Pos(':', ProxyServer) + 1, 255);
|
---|
168 | Delete(ProxyServer,Pos(':', ProxyServer), 255);
|
---|
169 | TcpClient1.RemoteHost := ProxyServer;
|
---|
170 | TcpClient1.RemotePort := ProxyPort;
|
---|
171 | end else begin
|
---|
172 | TcpClient1.RemoteHost := ErrorLogHost;
|
---|
173 | TcpClient1.RemotePort := '80';
|
---|
174 | end;
|
---|
175 |
|
---|
176 | HostHTTP := 'http://' + ErrorLogHost + '/' + ErrorLogScript;
|
---|
177 | with TcpClient1 do begin
|
---|
178 | Connect;
|
---|
179 | if Connected then begin
|
---|
180 | SendLn('GET ' + HostHTTP + '?' + Hlaseni + ' HTTP/1.0');
|
---|
181 | SendLn('Accept: text/html');
|
---|
182 | SendLn('Content-Type: text/plain; charset="iso-8859-2"');
|
---|
183 | Hlaseni := '';
|
---|
184 | SendLn('Content-length: '+IntToStr(Length(Hlaseni)));
|
---|
185 | if UseProxy then SendLn('Host: ' + ErrorLogHost);
|
---|
186 | SendLn('');
|
---|
187 | SendLn(Hlaseni);
|
---|
188 | // Memo1.Lines.Add(Hlaseni);
|
---|
189 |
|
---|
190 | //for I := 0 to 100 do
|
---|
191 | // Memo1.Lines.Add(Receiveln);
|
---|
192 | Close;
|
---|
193 | end; // else ShowMessage('Nepodaøilo se pøipojit k serveru');
|
---|
194 | end;
|
---|
195 | SetLength(Data,0);
|
---|
196 | end;
|
---|
197 |
|
---|
198 | procedure TLogExceptions.Button2Click(Sender: TObject);
|
---|
199 | begin
|
---|
200 | if Height = Vyska then Height := Vyska + Memo1.Height + 8 else Height := Vyska;
|
---|
201 | end;
|
---|
202 |
|
---|
203 | procedure TLogExceptions.FormShow(Sender: TObject);
|
---|
204 | var
|
---|
205 | I: Integer;
|
---|
206 | begin
|
---|
207 | Vyska := Height;
|
---|
208 | Memo1.Clear;
|
---|
209 | for I := 0 to High(Data) do with Data[I] do
|
---|
210 | Memo1.Lines.Add(Popis + ': ' + Text);
|
---|
211 | Edit1.Text := '';
|
---|
212 | //Send;
|
---|
213 | end;
|
---|
214 |
|
---|
215 | procedure TLogExceptions.Button1Click(Sender: TObject);
|
---|
216 | begin
|
---|
217 | if CheckBox1.Checked then Application.Terminate;
|
---|
218 | Close;
|
---|
219 | end;
|
---|
220 |
|
---|
221 | { TOdeslani }
|
---|
222 |
|
---|
223 | procedure TStoreError.Execute;
|
---|
224 | begin
|
---|
225 | Bezi := True;
|
---|
226 | LogExceptions.Send;
|
---|
227 | Bezi := False;
|
---|
228 | end;
|
---|
229 |
|
---|
230 | procedure TLogExceptions.FormCreate(Sender: TObject);
|
---|
231 | begin
|
---|
232 | (*
|
---|
233 | StoreError := TStoreError.Create(True);
|
---|
234 | NazevAplikace := Application.Title;
|
---|
235 | Application.OnException := Obsluha;
|
---|
236 | FMapFile := TMapFile.Create;
|
---|
237 | FMapFile.MapFileName := ChangeFileExt(Application.ExeName, '.map');
|
---|
238 | *)
|
---|
239 | end;
|
---|
240 |
|
---|
241 | procedure TLogExceptions.FormClose(Sender: TObject;
|
---|
242 | var Action: TCloseAction);
|
---|
243 | begin
|
---|
244 | Height := Vyska;
|
---|
245 | end;
|
---|
246 |
|
---|
247 | procedure TLogExceptions.FormDestroy(Sender: TObject);
|
---|
248 | begin
|
---|
249 | FreeAndNil(StoreError);
|
---|
250 | FreeAndNil(FMapFile);
|
---|
251 | end;
|
---|
252 |
|
---|
253 | end.
|
---|