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 e_amodes.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_WriteLog (TextLine: String; RecordCategory: TRecordCategory; WriteTime: Boolean=True);
  33 function DecodeIPV4 (ip: LongWord): string;
  34
  35
  36 // start Write/WriteLn driver. it will write everything to cbuf.
  37 procedure e_InitWritelnDriver ();
  38
  39
  40 var
  41   e_WriteToStdOut: Boolean = False;
  42
  43
  44 implementation
  45
  46 uses
  47   conbuf;
  48
  49
  50 var
  51   FirstRecord: Boolean;
  52   FileName: String;
  53   driverInited: Boolean = false;
  54
  55
  56 function DecodeIPV4 (ip: LongWord): string;
  57 begin
  58   Result := Format('%d.%d.%d.%d', [ip and $FF, (ip shr 8) and $FF, (ip shr 16) and $FF, (ip shr 24)]);
  59 end;
  60
  61
  62 procedure e_WriteLog (TextLine: String; RecordCategory: TRecordCategory; WriteTime: Boolean=True);
  63 var
  64   LogFile: TextFile;
  65   Prefix: ShortString = '';
  66   OutStr: String;
  67 begin
  68   if driverInited and (length(TextLine) > 0) then
  69   begin
  70     case RecordCategory of
  71       MSG_FATALERROR: write('FATAL: ');
  72       MSG_WARNING: write('WARNING: ');
  73     end;
  74     writeln(TextLine);
  75   end;
  76
  77   if FileName = '' then Exit;
  78
  79   Assign(LogFile, FileName);
  80   try
  81     if FileExists(FileName) then
  82       Append(LogFile)
  83     else
  84       Rewrite(LogFile);
  85     try
  86       if FirstRecord then
  87       begin
  88         Writeln(LogFile, '--- Log started at '+TimeToStr(Time)+' ---');
  89         FirstRecord := False;
  90       end;
  91       case RecordCategory of
  92         MSG_FATALERROR: Prefix := '!!!';
  93         MSG_WARNING:    Prefix := '!  ';
  94         MSG_NOTIFY:     Prefix := '***';
  95       end;
  96       if WriteTime then
  97         OutStr := '['+TimeToStr(Time)+'] '+Prefix+' '+TextLine
  98       else
  99         OutStr := Prefix+' '+TextLine;
 100       Writeln(LogFile, OutStr);
 101       if e_WriteToStdOut then
 102         Writeln(OutStr);
 103     finally
 104       Close(LogFile);
 105     end;
 106   except // sorry
 107   end;
 108 end;
 109
 110
 111 procedure e_InitLog (fFileName: String; fWriteMode: TWriteMode);
 112 begin
 113  FileName := fFileName;
 114  if fWriteMode = WM_NEWFILE then
 115  begin
 116    try
 117      if FileExists(FileName) then DeleteFile(FileName);
 118    except // sorry
 119    end;
 120  end;
 121  FirstRecord := True;
 122 end;
 123
 124
 125 // ////////////////////////////////////////////////////////////////////////// //
 126 (* Write/WriteLn driver *)
 127 //
 128 // control codes:
 129 //   CR, LF, BS
 130 //   TAB: tab space = 4
 131 //
 132 //   userData[1]: current x (for tabs)
 133 //   userData[2]: #13 was eaten, we should skip next #10
 134 //
 135 type
 136   TDevFunc = function (var f: TTextRec): Integer;
 137
 138 const
 139   udX = 1;
 140   udWasCR = 2;
 141
 142
 143 procedure ProcessOutput (var tf: TTextRec; buf: PChar; count: Integer);
 144 var
 145   wcr: Boolean;
 146   ep: PChar;
 147   f, x: Integer;
 148   ch: Char;
 149 begin
 150   x := tf.userData[udX];
 151   wcr := (tf.userData[udWasCR] <> 0);
 152   while count > 0 do
 153   begin
 154     // look for some special char
 155     ep := buf;
 156     f := 0;
 157     while f < count do
 158     begin
 159       ch := ep^;
 160       if (ch = #13) or (ch = #10) or (ch = #9) or (ch = #8) then break;
 161       Inc(ep);
 162       Inc(f);
 163 {$IFDEF CBLOG}
 164       write(stderr, ch);
 165 {$ENDIF}
 166     end;
 167     if f > 0 then
 168     begin
 169       wcr := false;
 170       cbufPutChars(buf, f);
 171       Inc(buf, f);
 172       Dec(count, f);
 173       Inc(x, f);
 174       continue;
 175     end;
 176     // process special chars
 177     ch := buf^;
 178     Inc(buf);
 179     Dec(count);
 180     // tab
 181     if ch = #9 then
 182     begin
 183 {$IFDEF CBLOG}
 184       write(stderr, ch);
 185 {$ENDIF}
 186       repeat
 187         cbufPut(' ');
 188         Inc(x);
 189       until (x mod 4) = 0;
 190       continue;
 191     end;
 192     // cr, lf
 193     if (ch = #13) or (ch = #10) then
 194     begin
 195 {$IFDEF CBLOG}
 196       writeln(stderr);
 197 {$ENDIF}
 198       if not wcr or (ch <> #10) then
 199       begin
 200         wcr := (ch = #13);
 201         x := 0;
 202         cbufPut(#10);
 203       end;
 204       continue;
 205     end;
 206   end;
 207   tf.userData[udX] := x;
 208   tf.userData[udWasCR] := ord(wcr);
 209 end;
 210
 211
 212 function DevOpen (var f: TTextRec): Integer;
 213 begin
 214   f.userData[udX] := 0;
 215   f.userData[udWasCR] := 0;
 216   f.bufPos := 0;
 217   f.bufEnd := 0;
 218   result := 0;
 219 end;
 220
 221 function DevInOut (var f: TTextRec): Integer;
 222 var
 223   buf: PChar;
 224   sz: Integer;
 225 begin
 226   result := 0;
 227   buf := Pointer(f.BufPtr);
 228   sz := f.BufPos;
 229   if sz > 0 then ProcessOutput(f, buf, sz);
 230   f.bufPos := 0;
 231   f.bufEnd := 0;
 232 end;
 233
 234 function DevFlush (var f: TTextRec): Integer;
 235 begin
 236   result := DevInOut(f);
 237 end;
 238
 239 function DevClose (var f: TTextRec): Integer;
 240 begin
 241   result := 0;
 242 end;
 243
 244
 245 procedure e_InitWritelnDriver ();
 246 begin
 247   if not driverInited then
 248   begin
 249     driverInited := true;
 250     with TTextRec(output) do
 251     begin
 252       Mode := fmClosed;
 253       if BufPtr = nil then
 254       begin
 255         BufSize := SizeOf(Buffer);
 256         BufPtr := @Buffer;
 257       end;
 258       OpenFunc := @DevOpen;
 259       InOutFunc := @DevInOut;
 260       FlushFunc := @DevFlush;
 261       CloseFunc := @DevClose;
 262       Name[0] := #0;
 263     end;
 264     Rewrite(output);
 265   end;
 266 end;
 267
 268
 269 begin
 270   //e_InitWritelnDriver();
 271 end.