src/engine/e_log.pas

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