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     if wcr then
 140     begin
 141       wcr := false;
 142       if buf^ = #10 then continue;
 143     end;
 144     // look for some special char
 145     ep := buf;
 146     f := 0;
 147     while f < count do
 148     begin
 149       ch := ep^;
 150       if (ch = #13) or (ch = #10) or (ch = #9) or (ch = #8) then break;
 151       Inc(ep);
 152       Inc(f);
 153 {$IFDEF CBLOG}
 154       write(stderr, ch);
 155 {$ENDIF}
 156     end;
 157     if f > 0 then
 158     begin
 159       cbufPutChars(buf, f);
 160       Inc(buf, f);
 161       Dec(count, f);
 162       Inc(x, f);
 163       continue;
 164     end;
 165     // process special chars
 166     ch := buf^;
 167     Inc(buf);
 168     Dec(count);
 169     // tab
 170     if ch = #9 then
 171     begin
 172 {$IFDEF CBLOG}
 173       write(stderr, ch);
 174 {$ENDIF}
 175       repeat
 176         cbufPut(' ');
 177         Inc(x);
 178       until (x mod 4) = 0;
 179       continue;
 180     end;
 181     // cr, lf
 182     if (ch = #13) or (ch = #10) then
 183     begin
 184 {$IFDEF CBLOG}
 185       writeln(stderr);
 186 {$ENDIF}
 187       wcr := (ch = #13);
 188       x := 0;
 189       cbufPut(#10);
 190       continue;
 191     end;
 192   end;
 193   tf.userData[udX] := x;
 194   tf.userData[udWasCR] := ord(wcr);
 195 end;
 196
 197
 198 function DevOpen (var f: TTextRec): Integer;
 199 begin
 200   f.userData[udX] := 0;
 201   f.userData[udWasCR] := 0;
 202   f.bufPos := 0;
 203   f.bufEnd := 0;
 204   result := 0;
 205 end;
 206
 207 function DevInOut (var f: TTextRec): Integer;
 208 var
 209   buf: PChar;
 210   sz: Integer;
 211 begin
 212   result := 0;
 213   buf := Pointer(f.BufPtr);
 214   sz := f.BufPos;
 215   if sz > 0 then ProcessOutput(f, buf, sz);
 216   f.bufPos := 0;
 217   f.bufEnd := 0;
 218 end;
 219
 220 function DevFlush (var f: TTextRec): Integer;
 221 begin
 222   result := DevInOut(f);
 223 end;
 224
 225 function DevClose (var f: TTextRec): Integer;
 226 begin
 227   result := 0;
 228 end;
 229
 230
 231 procedure e_InitWritelnDriver ();
 232 begin
 233   if not driverInited then
 234   begin
 235     driverInited := true;
 236     with TTextRec(output) do
 237     begin
 238       Mode := fmClosed;
 239       if BufPtr = nil then
 240       begin
 241         BufSize := SizeOf(Buffer);
 242         BufPtr := @Buffer;
 243       end;
 244       OpenFunc := @DevOpen;
 245       InOutFunc := @DevInOut;
 246       FlushFunc := @DevFlush;
 247       CloseFunc := @DevClose;
 248       Name[0] := #0;
 249     end;
 250     Rewrite(output);
 251   end;
 252 end;
 253
 254
 255 begin
 256   e_InitWritelnDriver();
 257 end.