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
  23   SysUtils;
  24
  25 type
  26   TWriteMode = (WM_NEWFILE,  WM_OLDFILE);
  27   TMsgType = (Fatal, Warning, Notify);
  28
  29
  30 procedure e_InitLog (fFileName: String; fWriteMode: TWriteMode);
  31 procedure e_DeinitLog ();
  32
  33 procedure e_SetSafeSlowLog (slowAndSafe: Boolean);
  34
  35 procedure e_WriteLog (TextLine: String; RecordCategory: TMsgType; WriteTime: Boolean=True);
  36
  37 function DecodeIPV4 (ip: LongWord): string;
  38
  39 // start Write/WriteLn driver. it will write everything to cbuf.
  40 procedure e_InitWritelnDriver ();
  41
  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);
  44
  45
  46 procedure e_WriteStackTrace (const msg: AnsiString);
  47
  48
  49 var
  50   e_WriteToStdOut: Boolean = False;
  51
  52
  53 implementation
  54
  55 uses
  56   {$IFDEF ANDROID}
  57     SDL2,
  58   {$ENDIF}
  59   conbuf, utils;
  60
  61 var
  62   FirstRecord: Boolean;
  63   FileName: String;
  64   driverInited: Boolean = false;
  65
  66
  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;
  71
  72
  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;
  80
  81
  82 procedure e_WriteLog (TextLine: String; RecordCategory: TMsgType; WriteTime: Boolean=True);
  83 begin
  84   e_LogWritefln('%s', [TextLine], RecordCategory, WriteTime, consoleAllow(TextLine));
  85 end;
  86
  87
  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;
  92
  93
  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);
  97
  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);
 109
 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}
 118
 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;
 129
 130
 131 var
 132   xlogFile: TextFile;
 133   xlogFileOpened: Boolean = false;
 134   xlogPrefix: AnsiString;
 135   xlogLastWasEOL: Boolean = false;
 136   xlogWantSpace: Boolean = false;
 137   xlogSlowAndSafe: Boolean = false;
 138
 139
 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;
 149
 150
 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;
 192
 193
 194 procedure e_LogWritefln (const fmt: AnsiString; args: array of const; category: TMsgType=TMsgType.Notify; writeTime: Boolean=true; writeConsole: Boolean=true);
 195
 196   procedure xwrite (const s: AnsiString);
 197   begin
 198     if (Length(s) = 0) then exit;
 199     logwriter(PAnsiChar(s)^, Length(s));
 200   end;
 201
 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;
 212
 213   if (FileName = '') then exit;
 214
 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;
 225
 226   if FirstRecord then
 227   begin
 228     writeln(xlogFile, '--- Log started at ', TimeToStr(Time), ' ---');
 229     FirstRecord := false;
 230   end;
 231
 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);
 243
 244   if xlogSlowAndSafe and xlogFileOpened then
 245   begin
 246     CloseFile(xlogFile);
 247     xlogFileOpened := false;
 248   end;
 249
 250   //if fopened then CloseFile(xlogFile);
 251 end;
 252
 253
 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;
 268
 269
 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;
 286
 287
 288 procedure e_DeinitLog ();
 289 begin
 290   if xlogFileOpened then CloseFile(xlogFile);
 291   xlogFileOpened := false;
 292 end;
 293
 294
 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;
 307
 308 const
 309   udX = 1;
 310   udWasCR = 2;
 311
 312
 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;
 380
 381
 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;
 390
 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;
 403
 404 function DevFlush (var f: TTextRec): Integer;
 405 begin
 406   result := DevInOut(f);
 407 end;
 408
 409 function DevClose (var f: TTextRec): Integer;
 410 begin
 411   result := 0;
 412 end;
 413
 414
 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;
 437
 438
 439 begin
 440   //e_InitWritelnDriver();
 441 end.