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