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