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