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