1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
|
{
This file is part of the Free Pascal run time library.
Copyright (c) 2003 by the Free Pascal development team
Cross-platform event logging facility.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}
{$h+}
unit eventlog;
interface
uses SysUtils,Classes;
Type
TEventLog = Class;
TLogType = (ltSystem,ltFile);
TLogCodeEvent = Procedure (Sender : TObject; Var Code : DWord) of Object;
TLogCategoryEvent = Procedure (Sender : TObject; Var Code : Word) of Object;
TEventLog = Class(TComponent)
Private
fAppendContent : Boolean;
FEventIDOffset : DWord;
FLogHandle : Pointer;
FStream : TFileStream;
FActive: Boolean;
FRaiseExceptionOnError: Boolean;
FIdentification: String;
FDefaultEventType: TEventType;
FLogtype: TLogType;
FFileName: String;
FTimeStampFormat: String;
FCustomLogType: Word;
FOnGetCustomCategory : TLogCategoryEvent;
FOnGetCustomEventID : TLogCodeEvent;
FOnGetCustomEvent : TLogCodeEvent;
procedure SetActive(const Value: Boolean);
procedure SetIdentification(const Value: String);
procedure SetlogType(const Value: TLogType);
procedure ActivateLog;
procedure DeActivateLog;
procedure ActivateFileLog;
procedure SetFileName(const Value: String);
procedure ActivateSystemLog;
function DefaultFileName: String;
procedure WriteFileLog(EventType : TEventType; const Msg: String);
procedure WriteSystemLog(EventType: TEventType; const Msg: String);
procedure DeActivateFileLog;
procedure DeActivateSystemLog;
procedure CheckIdentification;
Procedure DoGetCustomEventID(Var Code : DWord);
Procedure DoGetCustomEventCategory(Var Code : Word);
Procedure DoGetCustomEvent(Var Code : DWord);
Protected
Procedure CheckInactive;
Procedure EnsureActive;
function MapTypeToEvent(EventType: TEventType): DWord;
Function MapTypeToCategory(EventType : TEventType) : Word;
Function MapTypeToEventID(EventType : TEventType) : DWord;
Public
Destructor Destroy; override;
Function EventTypeToString(E : TEventType) : String;
Function RegisterMessageFile(AFileName : String) : Boolean; virtual;
Function UnRegisterMessageFile : Boolean; virtual;
Procedure Log (EventType : TEventType; const Msg : String); {$ifndef fpc }Overload;{$endif}
Procedure Log (EventType : TEventType; const Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
Procedure Log (const Msg : String); {$ifndef fpc }Overload;{$endif}
Procedure Log (const Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
Procedure Warning (const Msg : String); {$ifndef fpc }Overload;{$endif}
Procedure Warning (const Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
Procedure Error (const Msg : String); {$ifndef fpc }Overload;{$endif}
Procedure Error (const Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
Procedure Debug (const Msg : String); {$ifndef fpc }Overload;{$endif}
Procedure Debug (const Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
Procedure Info (const Msg : String); {$ifndef fpc }Overload;{$endif}
Procedure Info (const Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
Published
Property AppendContent : Boolean Read fAppendContent Write fAppendContent;
Property Identification : String Read FIdentification Write SetIdentification;
Property LogType : TLogType Read Flogtype Write SetlogType;
Property Active : Boolean Read FActive write SetActive;
Property RaiseExceptionOnError : Boolean Read FRaiseExceptionOnError Write FRaiseExceptionOnError;
Property DefaultEventType : TEventType Read FDEfaultEventType Write FDefaultEventType;
Property FileName : String Read FFileName Write SetFileName;
Property TimeStampFormat : String Read FTimeStampFormat Write FTimeStampFormat;
Property CustomLogType : Word Read FCustomLogType Write FCustomLogType;
Property EventIDOffset : DWord Read FEventIDOffset Write FEventIDOffset;
Property OnGetCustomCategory : TLogCategoryEvent Read FOnGetCustomCategory Write FOnGetCustomCategory;
Property OnGetCustomEventID : TLogCodeEvent Read FOnGetCustomEventID Write FOnGetCustomEventID;
Property OnGetCustomEvent : TLogCodeEvent Read FOnGetCustomEvent Write FOnGetCustomEvent;
End;
ELogError = Class(Exception);
Resourcestring
SLogInfo = 'Info';
SLogWarning = 'Warning';
SLogError = 'Error';
SLogDebug = 'Debug';
SLogCustom = 'Custom (%d)';
SErrLogFailedMsg = 'Failed to log entry (Error: %s)';
implementation
{$i eventlog.inc}
(* File based dummy implementation is used for all platforms not providing
specific implementation of eventlog.inc for the particular platform. *)
{ TEventLog }
Resourcestring
SErrOperationNotAllowed = 'Operation not allowed when eventlog is active.';
procedure TEventLog.CheckInactive;
begin
If Active then
Raise ELogError.Create(SErrOperationNotAllowed);
end;
procedure TEventLog.Debug(const Fmt: String; Args: array of const);
begin
Debug(Format(Fmt,Args));
end;
procedure TEventLog.Debug(const Msg: String);
begin
Log(etDebug,Msg);
end;
procedure TEventLog.EnsureActive;
begin
If Not Active then
Active:=True;
end;
procedure TEventLog.Error(const Fmt: String; Args: array of const);
begin
Error(Format(Fmt,Args));
end;
procedure TEventLog.Error(const Msg: String);
begin
Log(etError,Msg);
end;
procedure TEventLog.Info(const Fmt: String; Args: array of const);
begin
Info(Format(Fmt,Args));
end;
procedure TEventLog.Info(const Msg: String);
begin
Log(etInfo,Msg);
end;
procedure TEventLog.Log(const Msg: String);
begin
Log(DefaultEventType,msg);
end;
procedure TEventLog.Log(EventType: TEventType; const Fmt: String;
Args: array of const);
begin
Log(EventType,Format(Fmt,Args));
end;
procedure TEventLog.Log(EventType: TEventType; const Msg: String);
begin
EnsureActive;
Case FlogType of
ltFile : WriteFileLog(EventType,Msg);
ltSystem : WriteSystemLog(EventType,Msg);
end;
end;
procedure TEventLog.WriteFileLog(EventType : TEventType; const Msg : String);
Var
S,TS,T : String;
begin
If FTimeStampFormat='' then
FTimeStampFormat:='yyyy-mm-dd hh:nn:ss.zzz';
TS:=FormatDateTime(FTimeStampFormat,Now);
T:=EventTypeToString(EventType);
S:=Format('%s [%s %s] %s%s',[Identification,TS,T,Msg,LineEnding]);
try
FStream.WriteBuffer(S[1],Length(S));
S:='';
except
On E : Exception do
S:=E.Message;
end;
If (S<>'') and RaiseExceptionOnError then
Raise ELogError.CreateFmt(SErrLogFailedMsg,[S]);
end;
procedure TEventLog.Log(const Fmt: String; Args: array of const);
begin
Log(Format(Fmt,Args));
end;
procedure TEventLog.SetActive(const Value: Boolean);
begin
If Value<>FActive then
begin
If Value then
ActivateLog
else
DeActivateLog;
FActive:=Value;
end;
end;
Procedure TEventLog.ActivateLog;
begin
Case FLogType of
ltFile : ActivateFileLog;
ltSystem : ActivateSystemLog;
end;
end;
Procedure TEventLog.DeActivateLog;
begin
Case FLogType of
ltFile : DeActivateFileLog;
ltSystem : DeActivateSystemLog;
end;
end;
Procedure TEventLog.ActivateFileLog;
var
fFileFlags : Word;
begin
If (FFileName='') then
FFileName:=DefaultFileName;
// This will raise an exception if the file cannot be opened for writing !
if fAppendContent and FileExists(FFileName) then
fFileFlags := fmOpenWrite
else
fFileFlags := fmCreate;
fFileFlags := fFileFlags or fmShareDenyWrite;
FStream:=TFileStream.Create(FFileName,fFileFlags);
end;
Procedure TEventLog.DeActivateFileLog;
begin
FStream.Free;
FStream:=Nil;
end;
procedure TEventLog.SetIdentification(const Value: String);
begin
FIdentification := Value;
end;
procedure TEventLog.SetlogType(const Value: TLogType);
begin
CheckInactive;
Flogtype := Value;
end;
procedure TEventLog.Warning(const Fmt: String; Args: array of const);
begin
Warning(Format(Fmt,Args));
end;
procedure TEventLog.Warning(const Msg: String);
begin
Log(etWarning,Msg);
end;
procedure TEventLog.SetFileName(const Value: String);
begin
CheckInactive;
FFileName := Value;
end;
Procedure TEventLog.CheckIdentification;
begin
If (Identification='') then
Identification:=ChangeFileExt(ExtractFileName(Paramstr(0)),'');
end;
Function TEventLog.EventTypeToString(E : TEventType) : String;
begin
Case E of
etInfo : Result:=SLogInfo;
etWarning : Result:=SLogWarning;
etError : Result:=SLogError;
etDebug : Result:=SLogDebug;
etCustom : Result:=Format(SLogCustom,[CustomLogType]);
end;
end;
Procedure TEventLog.DoGetCustomEventID(Var Code : DWord);
begin
If Assigned(FOnGetCustomEventID) then
FOnGetCustomEventID(Self,Code);
end;
Procedure TEventLog.DoGetCustomEventCategory(Var Code : Word);
begin
If Assigned(FOnGetCustomCategory) then
FOnGetCustomCategory(Self,Code);
end;
Procedure TEventLog.DoGetCustomEvent(Var Code : DWord);
begin
If Assigned(FOnGetCustomEvent) then
FOnGetCustomEvent(Self,Code);
end;
destructor TEventLog.Destroy;
begin
Active:=False;
inherited;
end;
end.
|