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