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