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