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