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