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, cTCPClient, UMapFile, WinSock;
|
---|
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 | begin
|
---|
81 | FMapFile.LoadExceptionData;
|
---|
82 | // ShowMessage();
|
---|
83 | Pridat('Èas', DateTimeToStr(Now));
|
---|
84 | Pridat('Aplikace', NazevAplikace);
|
---|
85 | Pridat('Verze', AppVersion);
|
---|
86 | Pridat('Datum vydání', AppReleaseDate);
|
---|
87 | Pridat('Text chyby', E.Message);
|
---|
88 | Pridat('Tøída vyjímky', E.ClassName);
|
---|
89 | Pridat('Adresa', Format('%p',[ReturnAddr(6)]));
|
---|
90 | Pridat('Jednotka', FMapFile.ExceptUnitName);
|
---|
91 | Pridat('Metoda', FMapFile.ExceptMethodName);
|
---|
92 | Pridat('Øádek', IntToStr(FMapFile.ExceptLineNumber));
|
---|
93 | Pridat('Stavové informace', Stav);
|
---|
94 |
|
---|
95 | ShowModal; // Uka dialog
|
---|
96 |
|
---|
97 | if Edit1.Text <> '' then Pridat('Komentáø uivatele', Edit1.Text);
|
---|
98 |
|
---|
99 | // Uloit chybu do souboru
|
---|
100 | AssignFile(Soubor,NazevSouboru);
|
---|
101 | try
|
---|
102 | if FileExists(NazevSouboru) then Append(Soubor) else Rewrite(Soubor);
|
---|
103 | WriteLn(Soubor);
|
---|
104 | for I := 0 to High(Data) do WriteLn(Soubor,Data[I].Popis+': '+Data[I].Text);
|
---|
105 | finally
|
---|
106 | CloseFile(Soubor);
|
---|
107 | end;
|
---|
108 | StoreError.Execute;
|
---|
109 | end;
|
---|
110 |
|
---|
111 | procedure TLogExceptions.Pridat(NovyPopis, NovyText: string);
|
---|
112 | begin
|
---|
113 | SetLength(Data,Length(Data)+1);
|
---|
114 | with Data[High(Data)] do begin
|
---|
115 | Popis := NovyPopis;
|
---|
116 | Text := NovyText;
|
---|
117 | end;
|
---|
118 | end;
|
---|
119 |
|
---|
120 | procedure TLogExceptions.Send;
|
---|
121 | var
|
---|
122 | I: Integer;
|
---|
123 | //II: Integer;
|
---|
124 | Hlaseni: string;
|
---|
125 | //Buf: array[0..10000] of Char;
|
---|
126 | //Pocet: Integer;
|
---|
127 | // Radek: string;
|
---|
128 | UseProxy: Boolean;
|
---|
129 | ProxyServer: string;
|
---|
130 | ProxyPort: string;
|
---|
131 | HostHTTP: string;
|
---|
132 | begin
|
---|
133 | // Check if proxy server enabled
|
---|
134 | with TRegistry.Create do try
|
---|
135 | RootKey := HKEY_CURRENT_USER;
|
---|
136 | OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings', False);
|
---|
137 | UseProxy := ReadBool('ProxyEnable');
|
---|
138 | ProxyServer := ReadString('ProxyServer');
|
---|
139 | finally
|
---|
140 | Free;
|
---|
141 | end;
|
---|
142 |
|
---|
143 | // Generate report
|
---|
144 | Hlaseni := '';
|
---|
145 | for I := 0 to High(Data) do with Data[I] do
|
---|
146 | Hlaseni := Hlaseni + '&' + Popis + '=' + Text;
|
---|
147 | Delete(Hlaseni, 1, 1);
|
---|
148 |
|
---|
149 | // Replace blank spaces by special char %20
|
---|
150 | while Pos(' ', Hlaseni) > 0 do
|
---|
151 | Hlaseni := Copy(Hlaseni, 1, Pos(' ', Hlaseni)-1) + '%20' + Copy(Hlaseni, Pos(' ', Hlaseni) + 1, Length(Hlaseni));
|
---|
152 |
|
---|
153 | if UseProxy then begin
|
---|
154 | ProxyPort := Copy(ProxyServer,Pos(':',ProxyServer)+1,255);
|
---|
155 | Delete(ProxyServer,Pos(':',ProxyServer),255);
|
---|
156 | TcpClient1.RemoteHost := ProxyServer;
|
---|
157 | TcpClient1.RemotePort := ProxyPort;
|
---|
158 | end else begin
|
---|
159 | TcpClient1.RemoteHost := ErrorLogHost;
|
---|
160 | TcpClient1.RemotePort := '80';
|
---|
161 | end;
|
---|
162 |
|
---|
163 | HostHTTP := 'http://' + ErrorLogHost + '/' + ErrorLogScript;
|
---|
164 | with TcpClient1 do begin
|
---|
165 | Connect;
|
---|
166 | if Connected then begin
|
---|
167 | SendLn('GET ' + HostHTTP + '?' + Hlaseni + ' HTTP/1.0');
|
---|
168 | SendLn('Accept: text/html');
|
---|
169 | SendLn('Content-Type: text/plain; charset="iso-8859-2"');
|
---|
170 | Hlaseni := '';
|
---|
171 | SendLn('Content-length: '+IntToStr(Length(Hlaseni)));
|
---|
172 | if UseProxy then SendLn('Host: ' + ErrorLogHost);
|
---|
173 | SendLn('');
|
---|
174 | SendLn(Hlaseni);
|
---|
175 | // Memo1.Lines.Add(Hlaseni);
|
---|
176 |
|
---|
177 | //for I := 0 to 100 do
|
---|
178 | // Memo1.Lines.Add(Receiveln);
|
---|
179 | Close;
|
---|
180 | end; // else ShowMessage('Nepodaøilo se pøipojit k serveru');
|
---|
181 | end;
|
---|
182 | SetLength(Data,0);
|
---|
183 | end;
|
---|
184 |
|
---|
185 | procedure TLogExceptions.Button2Click(Sender: TObject);
|
---|
186 | begin
|
---|
187 | if Height = Vyska then Height := Vyska + Memo1.Height + 8 else Height := Vyska;
|
---|
188 | end;
|
---|
189 |
|
---|
190 | procedure TLogExceptions.FormShow(Sender: TObject);
|
---|
191 | var
|
---|
192 | I: Integer;
|
---|
193 | begin
|
---|
194 | Vyska := Height;
|
---|
195 | Memo1.Clear;
|
---|
196 | for I := 0 to High(Data) do with Data[I] do Memo1.Lines.Add(Popis+': '+Text);
|
---|
197 | Edit1.Text := '';
|
---|
198 | //Send;
|
---|
199 | end;
|
---|
200 |
|
---|
201 | procedure TLogExceptions.Button1Click(Sender: TObject);
|
---|
202 | begin
|
---|
203 | if CheckBox1.Checked then Application.Terminate;
|
---|
204 | Close;
|
---|
205 | end;
|
---|
206 |
|
---|
207 | { TOdeslani }
|
---|
208 |
|
---|
209 | procedure TStoreError.Execute;
|
---|
210 | begin
|
---|
211 | Bezi := True;
|
---|
212 | LogExceptions.Send;
|
---|
213 | Bezi := False;
|
---|
214 | end;
|
---|
215 |
|
---|
216 | procedure TLogExceptions.FormCreate(Sender: TObject);
|
---|
217 | begin
|
---|
218 | StoreError := TStoreError.Create(True);
|
---|
219 | NazevAplikace := Application.Title;
|
---|
220 | Application.OnException := Obsluha;
|
---|
221 | FMapFile := TMapFile.Create;
|
---|
222 | FMapFile.MapFileName := ChangeFileExt(Application.ExeName, '.map');
|
---|
223 | end;
|
---|
224 |
|
---|
225 | procedure TLogExceptions.FormClose(Sender: TObject;
|
---|
226 | var Action: TCloseAction);
|
---|
227 | begin
|
---|
228 | Height := Vyska;
|
---|
229 | end;
|
---|
230 |
|
---|
231 | procedure TLogExceptions.FormDestroy(Sender: TObject);
|
---|
232 | begin
|
---|
233 | FreeAndNil(FMapFile);
|
---|
234 | end;
|
---|
235 |
|
---|
236 | end.
|
---|