DEADSOFTWARE

net: oops; reconnection to failed master was totally broken
[d2df-sdl.git] / src / engine / e_log.pas
1 (* Copyright (C) Doom 2D: Forever Developers
2 *
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, version 3 of the License ONLY.
6 *
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * GNU General Public License for more details.
11 *
12 * You should have received a copy of the GNU General Public License
13 * along with this program. If not, see <http://www.gnu.org/licenses/>.
14 *)
15 {$INCLUDE ../shared/a_modes.inc}
16 {$R-}
17 { $DEFINE CBLOG}
18 unit e_log;
20 interface
22 uses
23 SysUtils;
25 type
26 TWriteMode = (WM_NEWFILE, WM_OLDFILE);
27 TMsgType = (Fatal, Warning, Notify);
30 procedure e_InitLog (fFileName: String; fWriteMode: TWriteMode);
31 procedure e_DeinitLog ();
33 procedure e_SetSafeSlowLog (slowAndSafe: Boolean);
35 procedure e_WriteLog (TextLine: String; RecordCategory: TMsgType; WriteTime: Boolean=True);
37 function DecodeIPV4 (ip: LongWord): string;
39 // start Write/WriteLn driver. it will write everything to cbuf.
40 procedure e_InitWritelnDriver ();
42 procedure e_LogWritefln (const fmt: AnsiString; args: array of const; category: TMsgType=TMsgType.Notify; writeTime: Boolean=true; writeConsole: Boolean=true);
43 procedure e_LogWriteln (const s: AnsiString; category: TMsgType=TMsgType.Notify; writeTime: Boolean=true);
46 procedure e_WriteStackTrace (const msg: AnsiString);
49 var
50 e_WriteToStdOut: Boolean = False;
53 implementation
55 uses
56 {$IFDEF ANDROID}
57 SDL2,
58 {$ENDIF}
59 conbuf, utils;
61 var
62 FirstRecord: Boolean;
63 FileName: String;
64 driverInited: Boolean = false;
67 function DecodeIPV4 (ip: LongWord): string;
68 begin
69 Result := Format('%d.%d.%d.%d', [ip and $FF, (ip shr 8) and $FF, (ip shr 16) and $FF, (ip shr 24)]);
70 end;
73 function consoleAllow (const s: String): Boolean;
74 begin
75 Result := False;
76 if Pos('[Chat] ', s) = 1 then
77 Exit;
78 Result := True;
79 end;
82 procedure e_WriteLog (TextLine: String; RecordCategory: TMsgType; WriteTime: Boolean=True);
83 begin
84 e_LogWritefln('%s', [TextLine], RecordCategory, WriteTime, consoleAllow(TextLine));
85 end;
88 procedure e_LogWriteln (const s: AnsiString; category: TMsgType=TMsgType.Notify; writeTime: Boolean=true);
89 begin
90 e_LogWritefln('%s', [s], category, writeTime, consoleAllow(s));
91 end;
94 // returns formatted string if `writerCB` is `nil`, empty string otherwise
95 //function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
96 //TFormatStrFCallback = procedure (constref buf; len: SizeUInt);
98 procedure conwriter (constref buf; len: SizeUInt);
99 var
100 ss: ShortString;
101 slen: Integer;
102 b: PByte;
103 {$IFDEF ANDROID}
104 cstr: PChar;
105 {$ENDIF}
106 begin
107 if (len < 1) then exit;
108 b := PByte(@buf);
110 {$IFDEF ANDROID}
111 cstr := GetMem(len + 1);
112 for slen := 0 to len - 1 do
113 cstr[slen] := Chr(b[slen]);
114 cstr[len] := #0;
115 SDL_Log(cstr, []);
116 Dispose(cstr);
117 {$ENDIF}
119 while (len > 0) do
120 begin
121 if (len > 255) then slen := 255 else slen := Integer(len);
122 Move(b^, ss[1], slen);
123 ss[0] := AnsiChar(slen);
124 write(ss);
125 b += slen;
126 len -= slen;
127 end;
128 end;
131 var
132 xlogFile: TextFile;
133 xlogFileOpened: Boolean = false;
134 xlogPrefix: AnsiString;
135 xlogLastWasEOL: Boolean = false;
136 xlogWantSpace: Boolean = false;
137 xlogSlowAndSafe: Boolean = false;
140 procedure e_SetSafeSlowLog (slowAndSafe: Boolean);
141 begin
142 xlogSlowAndSafe := slowAndSafe;
143 if xlogSlowAndSafe and xlogFileOpened then
144 begin
145 CloseFile(xlogFile);
146 xlogFileOpened := false;
147 end;
148 end;
151 procedure logwriter (constref buf; len: SizeUInt);
152 var
153 ss: ShortString;
154 slen: Integer;
155 b: PByte;
156 begin
157 if (len < 1) then exit;
158 b := PByte(@buf);
159 if xlogLastWasEOL then
160 begin
161 write(xlogFile, xlogPrefix);
162 xlogLastWasEOL := false;
163 xlogWantSpace := true;
164 end;
165 while (len > 0) do
166 begin
167 slen := 0;
168 while (slen < len) and (b[slen] <> 13) and (b[slen] <> 10) do Inc(slen);
169 if (slen > 255) then slen := 255;
170 // print string
171 if (slen > 0) then
172 begin
173 if xlogWantSpace then begin write(xlogFile, ' '); xlogWantSpace := false; end;
174 Move(b^, ss[1], slen);
175 ss[0] := AnsiChar(slen);
176 write(xlogFile, ss);
177 b += slen;
178 len -= slen;
179 continue;
180 end;
181 // process newline
182 if (len > 0) and ((b[0] = 13) or (b[0] = 10)) then
183 begin
184 if (b[0] = 13) then begin len -= 1; b += 1; end;
185 if (len > 0) and (b[0] = 10) then begin len -= 1; b += 1; end;
186 xlogLastWasEOL := false;
187 writeln(xlogFile, '');
188 write(xlogFile, xlogPrefix);
189 end;
190 end;
191 end;
194 procedure e_LogWritefln (const fmt: AnsiString; args: array of const; category: TMsgType=TMsgType.Notify; writeTime: Boolean=true; writeConsole: Boolean=true);
196 procedure xwrite (const s: AnsiString);
197 begin
198 if (Length(s) = 0) then exit;
199 logwriter(PAnsiChar(s)^, Length(s));
200 end;
202 begin
203 if driverInited and (length(fmt) > 0) and writeConsole then
204 begin
205 case category of
206 TMsgType.Fatal: write('FATAL: ');
207 TMsgType.Warning: write('WARNING: ');
208 end;
209 formatstrf(fmt, args, conwriter);
210 writeln;
211 end;
213 if (FileName = '') then exit;
215 if not xlogFileOpened then
216 begin
217 AssignFile(xlogFile, FileName);
218 try
219 if FileExists(FileName) then Append(xlogFile) else Rewrite(xlogFile);
220 xlogFileOpened := true;
221 except // sorry
222 exit;
223 end;
224 end;
226 if FirstRecord then
227 begin
228 writeln(xlogFile, '--- Log started at ', TimeToStr(Time), ' ---');
229 FirstRecord := false;
230 end;
232 xlogPrefix := '';
233 if writeTime then begin xlogPrefix += '['; xlogPrefix += TimeToStr(Time); xlogPrefix += '] '; end;
234 case category of
235 TMsgType.Fatal: xlogPrefix += '!!!';
236 TMsgType.Warning: xlogPrefix += '! ';
237 TMsgType.Notify: xlogPrefix += '***';
238 end;
239 xlogLastWasEOL := true; // to output prefix
240 xlogWantSpace := true; // after prefix
241 formatstrf(fmt, args, logwriter);
242 if not xlogLastWasEOL then writeln(xlogFile, '') else writeln(xlogFile, xlogPrefix);
244 if xlogSlowAndSafe and xlogFileOpened then
245 begin
246 CloseFile(xlogFile);
247 xlogFileOpened := false;
248 end;
250 //if fopened then CloseFile(xlogFile);
251 end;
254 procedure e_InitLog (fFileName: String; fWriteMode: TWriteMode);
255 begin
256 if xlogFileOpened then CloseFile(xlogFile);
257 xlogFileOpened := false;
258 FileName := fFileName;
259 if (fWriteMode = TWriteMode.WM_NEWFILE) then
260 begin
261 try
262 if FileExists(FileName) then DeleteFile(FileName);
263 except // sorry
264 end;
265 end;
266 FirstRecord := true;
267 end;
270 {$I-}
271 procedure e_WriteStackTrace (const msg: AnsiString);
272 var
273 tfo: TextFile;
274 begin
275 e_LogWriteln(msg, TMsgType.Fatal);
276 if (Length(FileName) > 0) then
277 begin
278 if xlogFileOpened then CloseFile(xlogFile);
279 xlogFileOpened := false;
280 AssignFile(tfo, FileName);
281 Append(tfo);
282 if (IOResult <> 0) then Rewrite(tfo);
283 if (IOResult = 0) then begin writeln(tfo, '====================='); DumpExceptionBackTrace(tfo); CloseFile(tfo); end;
284 end;
285 end;
288 procedure e_DeinitLog ();
289 begin
290 if xlogFileOpened then CloseFile(xlogFile);
291 xlogFileOpened := false;
292 end;
295 // ////////////////////////////////////////////////////////////////////////// //
296 (* Write/WriteLn driver *)
297 //
298 // control codes:
299 // CR, LF, BS
300 // TAB: tab space = 4
301 //
302 // userData[1]: current x (for tabs)
303 // userData[2]: #13 was eaten, we should skip next #10
304 //
305 type
306 TDevFunc = function (var f: TTextRec): Integer;
308 const
309 udX = 1;
310 udWasCR = 2;
313 procedure ProcessOutput (var tf: TTextRec; buf: PChar; count: Integer);
314 var
315 wcr: Boolean;
316 ep: PChar;
317 f, x: Integer;
318 ch: Char;
319 begin
320 x := tf.userData[udX];
321 wcr := (tf.userData[udWasCR] <> 0);
322 while count > 0 do
323 begin
324 // look for some special char
325 ep := buf;
326 f := 0;
327 while f < count do
328 begin
329 ch := ep^;
330 if (ch = #13) or (ch = #10) or (ch = #9) or (ch = #8) then break;
331 Inc(ep);
332 Inc(f);
333 {$IFDEF CBLOG}
334 write(stderr, ch);
335 {$ENDIF}
336 end;
337 if f > 0 then
338 begin
339 wcr := false;
340 cbufPutChars(buf, f);
341 Inc(buf, f);
342 Dec(count, f);
343 Inc(x, f);
344 continue;
345 end;
346 // process special chars
347 ch := buf^;
348 Inc(buf);
349 Dec(count);
350 // tab
351 if ch = #9 then
352 begin
353 {$IFDEF CBLOG}
354 write(stderr, ch);
355 {$ENDIF}
356 repeat
357 cbufPut(' ');
358 Inc(x);
359 until (x mod 4) = 0;
360 continue;
361 end;
362 // cr, lf
363 if (ch = #13) or (ch = #10) then
364 begin
365 {$IFDEF CBLOG}
366 writeln(stderr);
367 {$ENDIF}
368 if not wcr or (ch <> #10) then
369 begin
370 wcr := (ch = #13);
371 x := 0;
372 cbufPut(#10);
373 end;
374 continue;
375 end;
376 end;
377 tf.userData[udX] := x;
378 tf.userData[udWasCR] := ord(wcr);
379 end;
382 function DevOpen (var f: TTextRec): Integer;
383 begin
384 f.userData[udX] := 0;
385 f.userData[udWasCR] := 0;
386 f.bufPos := 0;
387 f.bufEnd := 0;
388 result := 0;
389 end;
391 function DevInOut (var f: TTextRec): Integer;
392 var
393 buf: PChar;
394 sz: Integer;
395 begin
396 result := 0;
397 buf := Pointer(f.BufPtr);
398 sz := f.BufPos;
399 if sz > 0 then ProcessOutput(f, buf, sz);
400 f.bufPos := 0;
401 f.bufEnd := 0;
402 end;
404 function DevFlush (var f: TTextRec): Integer;
405 begin
406 result := DevInOut(f);
407 end;
409 function DevClose (var f: TTextRec): Integer;
410 begin
411 result := 0;
412 end;
415 procedure e_InitWritelnDriver ();
416 begin
417 if not driverInited then
418 begin
419 driverInited := true;
420 with TTextRec(output) do
421 begin
422 Mode := fmClosed;
423 if BufPtr = nil then
424 begin
425 BufSize := SizeOf(Buffer);
426 BufPtr := @Buffer;
427 end;
428 OpenFunc := @DevOpen;
429 InOutFunc := @DevInOut;
430 FlushFunc := @DevFlush;
431 CloseFunc := @DevClose;
432 Name[0] := #0;
433 end;
434 Rewrite(output);
435 end;
436 end;
439 begin
440 //e_InitWritelnDriver();
441 end.