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