mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-23 00:33:03 +02:00
+ Added event log
This commit is contained in:
michael
parent
a49c4466a8
commit
88a68e0a04
55
fcl/Makefile
55
fcl/Makefile
@ -1,8 +1,8 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2002/05/22]
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2002/10/05]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx
|
||||
override PATH:=$(subst \,/,$(PATH))
|
||||
ifeq ($(findstring ;,$(PATH)),)
|
||||
inUnix=1
|
||||
@ -42,6 +42,9 @@ endif
|
||||
ifeq ($(OS_TARGET),netbsd)
|
||||
BSDhier=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
BSDhier=1
|
||||
endif
|
||||
ifdef inUnix
|
||||
BATCHEXT=.sh
|
||||
else
|
||||
@ -55,6 +58,9 @@ ifdef inUnix
|
||||
PATHSEP=/
|
||||
else
|
||||
PATHSEP:=$(subst /,\,/)
|
||||
ifneq ($(findstring sh.exe,$(SHELL)),)
|
||||
PATHSEP=/
|
||||
endif
|
||||
endif
|
||||
ifdef PWD
|
||||
BASEDIR:=$(subst \,/,$(shell $(PWD)))
|
||||
@ -137,6 +143,16 @@ ifndef OS_TARGET
|
||||
OS_TARGET:=$(shell $(FPC) -iTO)
|
||||
endif
|
||||
endif
|
||||
ifndef CPU_TARGET
|
||||
ifdef CPU_TARGET_DEFAULT
|
||||
CPU_TARGET=$(CPU_TARGET_DEFAULT)
|
||||
endif
|
||||
endif
|
||||
ifndef OS_TARGET
|
||||
ifdef OS_TARGET_DEFAULT
|
||||
OS_TARGET=$(OS_TARGET_DEFAULT)
|
||||
endif
|
||||
endif
|
||||
FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
|
||||
FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
|
||||
ifneq ($(FULL_TARGET),$(FULL_SOURCE))
|
||||
@ -199,7 +215,7 @@ PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/ext
|
||||
override PACKAGE_NAME=fcl
|
||||
override PACKAGE_VERSION=1.0.6
|
||||
override TARGET_DIRS+=xml db shedit
|
||||
override TARGET_UNITS+=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry
|
||||
override TARGET_UNITS+=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog
|
||||
ifeq ($(OS_TARGET),linux)
|
||||
override TARGET_UNITS+=process asyncio ssockets http resolve
|
||||
endif
|
||||
@ -212,6 +228,9 @@ endif
|
||||
ifeq ($(OS_TARGET),netbsd)
|
||||
override TARGET_UNITS+=process asyncio ssockets http
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
override TARGET_UNITS+=process asyncio ssockets http
|
||||
endif
|
||||
override TARGET_RSTS+=classes ssockets cachecls resolve
|
||||
override TARGET_EXAMPLEDIRS+=tests
|
||||
override CLEAN_UNITS+=adler gzcrc gzio infblock infcodes inffast inftrees infutil minigzip paszlib trees zbase zcompres zdeflate zinflate zuncompr zutil
|
||||
@ -233,6 +252,9 @@ endif
|
||||
ifeq ($(OS_TARGET),qnx)
|
||||
override COMPILER_INCLUDEDIR+=posix
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
override COMPILER_INCLUDEDIR+=unix
|
||||
endif
|
||||
override COMPILER_SOURCEDIR+=$(OS_TARGET) inc
|
||||
override COMPILER_TARGETDIR+=$(OS_TARGET)
|
||||
ifdef REQUIRE_UNITSDIR
|
||||
@ -251,6 +273,9 @@ endif
|
||||
ifeq ($(OS_TARGET),netbsd)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),sunos)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
@ -267,6 +292,9 @@ endif
|
||||
ifeq ($(OS_SOURCE),netbsd)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
ifeq ($(OS_SOURCE),openbsd)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),sunos)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
@ -482,6 +510,12 @@ HASSHAREDLIB=1
|
||||
FPCMADE=fpcmade.netbsd
|
||||
ZIPSUFFIX=netbsd
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
EXEEXT=
|
||||
HASSHAREDLIB=1
|
||||
FPCMADE=fpcmade.openbsd
|
||||
ZIPSUFFIX=openbsd
|
||||
endif
|
||||
ifeq ($(OS_TARGET),win32)
|
||||
PPUEXT=.ppw
|
||||
OEXT=.ow
|
||||
@ -847,6 +881,17 @@ ifeq ($(OS_TARGET),netware)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_PASZLIB=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_PASZLIB=1
|
||||
REQUIRE_PACKAGES_INET=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),wdosx)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_PASZLIB=1
|
||||
endif
|
||||
ifdef REQUIRE_PACKAGES_RTL
|
||||
PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
|
||||
ifneq ($(PACKAGEDIR_RTL),)
|
||||
@ -983,6 +1028,9 @@ endif
|
||||
ifneq ($(OS_TARGET),$(OS_SOURCE))
|
||||
override FPCOPT+=-T$(OS_TARGET)
|
||||
endif
|
||||
ifeq ($(OS_SOURCE),openbsd)
|
||||
override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
|
||||
endif
|
||||
ifdef UNITDIR
|
||||
override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
|
||||
endif
|
||||
@ -1383,6 +1431,7 @@ fpc_baseinfo:
|
||||
@$(ECHO) Rm........ $(RMPROG)
|
||||
@$(ECHO) GInstall.. $(GINSTALL)
|
||||
@$(ECHO) Echo...... $(ECHO)
|
||||
@$(ECHO) Shell..... $(SHELL)
|
||||
@$(ECHO) Date...... $(DATE)
|
||||
@$(ECHO) FPCMake... $(FPCMAKE)
|
||||
@$(ECHO) PPUMove... $(PPUMOVE)
|
||||
|
||||
@ -19,7 +19,7 @@ units=adler gzcrc gzio infblock infcodes inffast inftrees infutil minigzip paszl
|
||||
|
||||
[target]
|
||||
dirs=xml db shedit
|
||||
units=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry
|
||||
units=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog
|
||||
units_freebsd=process asyncio ssockets http
|
||||
units_netbsd=process asyncio ssockets http
|
||||
units_openbsd=process asyncio ssockets http
|
||||
|
||||
29
fcl/go32v2/eventlog.inc
Normal file
29
fcl/go32v2/eventlog.inc
Normal file
@ -0,0 +1,29 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
DOS 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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Include event log that maps to file event log.
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
{$i felog.inc}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2003-02-19 20:25:16 michael
|
||||
+ Added event log
|
||||
|
||||
}
|
||||
|
||||
293
fcl/inc/eventlog.pp
Normal file
293
fcl/inc/eventlog.pp
Normal file
@ -0,0 +1,293 @@
|
||||
{
|
||||
$Id$
|
||||
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
|
||||
TEventType = (etCustom,etInfo,etWarning,etError,etDebug);
|
||||
TLogType = (ltSystem,ltFile);
|
||||
|
||||
TEventLog = Class(TComponent)
|
||||
Private
|
||||
FEventIDOffset : DWord;
|
||||
FLogHandle : Pointer;
|
||||
FStream : TFileStream;
|
||||
FActive: Boolean;
|
||||
FIdentification: String;
|
||||
FDefaultEventType: TEventType;
|
||||
FLogtype: TLogType;
|
||||
FFileName: String;
|
||||
FTimeStampFormat: String;
|
||||
FCustomLogType: Word;
|
||||
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; Msg: String);
|
||||
procedure WriteSystemLog(EventType: TEventType; Msg: String);
|
||||
procedure DeActivateFileLog;
|
||||
procedure DeActivateSystemLog;
|
||||
procedure CheckIdentification;
|
||||
function MapTypeToEvent(EventType: TEventType): DWord;
|
||||
Protected
|
||||
Procedure CheckInactive;
|
||||
Procedure EnsureActive;
|
||||
Public
|
||||
Destructor Destroy; override;
|
||||
Function EventTypeToString(E : TEventType) : String;
|
||||
Function RegisterMessageFile(AFileName : String) : Boolean; virtual;
|
||||
Function MapTypeToCategory(EventType : TEventType) : Word;
|
||||
Function MapTypeToEventID(EventType : TEventType) : DWord;
|
||||
Procedure Log (EventType : TEventType; Msg : String); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Log (EventType : TEventType; Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Log (Msg : String); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Log (Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Warning (Msg : String); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Warning (Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Error (Msg : String); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Error (Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Debug (Msg : String); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Debug (Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Info (Msg : String); {$ifndef fpc }Overload;{$endif}
|
||||
Procedure Info (Fmt : String; Args : Array of const); {$ifndef fpc }Overload;{$endif}
|
||||
Property Identification : String Read FIdentification Write SetIdentification;
|
||||
Property LogType : TLogType Read Flogtype Write SetlogType;
|
||||
Property Active : Boolean Read FActive write SetActive;
|
||||
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;
|
||||
End;
|
||||
|
||||
ELogError = Class(Exception);
|
||||
|
||||
Resourcestring
|
||||
|
||||
SLogInfo = 'Info';
|
||||
SLogWarning = 'Warning';
|
||||
SLogError = 'Error';
|
||||
SLogDebug = 'Debug';
|
||||
SLogCustom = 'Custom (%d)';
|
||||
|
||||
implementation
|
||||
|
||||
{$i eventlog.inc}
|
||||
|
||||
{ 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(Fmt: String; Args: array of const);
|
||||
begin
|
||||
Debug(Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
procedure TEventLog.Debug(Msg: String);
|
||||
begin
|
||||
Log(etDebug,Msg);
|
||||
end;
|
||||
|
||||
procedure TEventLog.EnsureActive;
|
||||
begin
|
||||
If Not Active then
|
||||
Active:=True;
|
||||
end;
|
||||
|
||||
procedure TEventLog.Error(Fmt: String; Args: array of const);
|
||||
begin
|
||||
Error(Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
procedure TEventLog.Error(Msg: String);
|
||||
begin
|
||||
Log(etError,Msg);
|
||||
end;
|
||||
|
||||
procedure TEventLog.Info(Fmt: String; Args: array of const);
|
||||
begin
|
||||
Info(Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
procedure TEventLog.Info(Msg: String);
|
||||
begin
|
||||
Log(etInfo,Msg);
|
||||
end;
|
||||
|
||||
procedure TEventLog.Log(Msg: String);
|
||||
begin
|
||||
Log(DefaultEventType,msg);
|
||||
end;
|
||||
|
||||
procedure TEventLog.Log(EventType: TEventType; Fmt: String;
|
||||
Args: array of const);
|
||||
begin
|
||||
Log(EventType,Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
procedure TEventLog.Log(EventType: TEventType; Msg: String);
|
||||
begin
|
||||
EnsureActive;
|
||||
Case FlogType of
|
||||
ltFile : WriteFileLog(EventType,Msg);
|
||||
ltSystem : WriteSystemLog(EventType,Msg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TEventLog.WriteFileLog(EventType : TEventType; 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]);
|
||||
FStream.Write(S[1],Length(S));
|
||||
end;
|
||||
|
||||
procedure TEventLog.Log(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;
|
||||
|
||||
begin
|
||||
If (FFileName='') then
|
||||
FFileName:=DefaultFileName;
|
||||
// This will raise an exception if the file cannot be opened for writing !
|
||||
FStream:=TFileStream.Create(FFileName,fmCreate or fmShareDenyWrite);
|
||||
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(Fmt: String; Args: array of const);
|
||||
begin
|
||||
Warning(Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
procedure TEventLog.Warning(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;
|
||||
|
||||
destructor TEventLog.Destroy;
|
||||
begin
|
||||
Active:=False;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2003-02-19 20:25:16 michael
|
||||
+ Added event log
|
||||
|
||||
}
|
||||
70
fcl/inc/felog.inc
Normal file
70
fcl/inc/felog.inc
Normal file
@ -0,0 +1,70 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Generic implementation of 'system log' event mechanism which maps to file log.
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
Function TEventLog.DefaultFileName : String;
|
||||
|
||||
begin
|
||||
Result:=ChangeFileExt(ExtractFileName(Paramstr(0)),'.log');
|
||||
end;
|
||||
|
||||
Procedure TEventLog.ActivateSystemLog;
|
||||
|
||||
begin
|
||||
CheckIdentification;
|
||||
ActivateFileLog;
|
||||
end;
|
||||
|
||||
Procedure TEventLog.DeActivateSystemLog;
|
||||
|
||||
begin
|
||||
DeActivateFileLog;
|
||||
end;
|
||||
|
||||
procedure TEventLog.WriteSystemLog(EventType : TEventType; Msg : String);
|
||||
|
||||
begin
|
||||
WriteFileLog(EventType,Msg);
|
||||
end;
|
||||
|
||||
Function TEventLog.RegisterMessageFile(AFileName : String) : Boolean;
|
||||
|
||||
begin
|
||||
Result:=True;
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToCategory(EventType: TEventType): Word;
|
||||
begin
|
||||
Result:=0;
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToEventID(EventType: TEventType): DWord;
|
||||
|
||||
begin
|
||||
Result:=0;
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToEvent(EventType: TEventType): DWord;
|
||||
|
||||
begin
|
||||
Result:=0;
|
||||
end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2003-02-19 20:25:16 michael
|
||||
+ Added event log
|
||||
|
||||
}
|
||||
29
fcl/os2/eventlog.inc
Normal file
29
fcl/os2/eventlog.inc
Normal file
@ -0,0 +1,29 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
DOS 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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Include event log that maps to file event log.
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
{$i felog.inc}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2003-02-19 20:25:16 michael
|
||||
+ Added event log
|
||||
|
||||
}
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2002/05/22]
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2002/10/05]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx
|
||||
override PATH:=$(subst \,/,$(PATH))
|
||||
ifeq ($(findstring ;,$(PATH)),)
|
||||
inUnix=1
|
||||
@ -42,6 +42,9 @@ endif
|
||||
ifeq ($(OS_TARGET),netbsd)
|
||||
BSDhier=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
BSDhier=1
|
||||
endif
|
||||
ifdef inUnix
|
||||
BATCHEXT=.sh
|
||||
else
|
||||
@ -55,6 +58,9 @@ ifdef inUnix
|
||||
PATHSEP=/
|
||||
else
|
||||
PATHSEP:=$(subst /,\,/)
|
||||
ifneq ($(findstring sh.exe,$(SHELL)),)
|
||||
PATHSEP=/
|
||||
endif
|
||||
endif
|
||||
ifdef PWD
|
||||
BASEDIR:=$(subst \,/,$(shell $(PWD)))
|
||||
@ -137,6 +143,16 @@ ifndef OS_TARGET
|
||||
OS_TARGET:=$(shell $(FPC) -iTO)
|
||||
endif
|
||||
endif
|
||||
ifndef CPU_TARGET
|
||||
ifdef CPU_TARGET_DEFAULT
|
||||
CPU_TARGET=$(CPU_TARGET_DEFAULT)
|
||||
endif
|
||||
endif
|
||||
ifndef OS_TARGET
|
||||
ifdef OS_TARGET_DEFAULT
|
||||
OS_TARGET=$(OS_TARGET_DEFAULT)
|
||||
endif
|
||||
endif
|
||||
FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
|
||||
FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
|
||||
ifneq ($(FULL_TARGET),$(FULL_SOURCE))
|
||||
@ -196,7 +212,7 @@ else
|
||||
UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
|
||||
endif
|
||||
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
|
||||
override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testcgi tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg
|
||||
override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testcgi tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd
|
||||
ifeq ($(OS_TARGET),linux)
|
||||
override TARGET_PROGRAMS+=sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre
|
||||
endif
|
||||
@ -221,6 +237,9 @@ endif
|
||||
ifeq ($(OS_TARGET),netbsd)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),sunos)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
@ -237,6 +256,9 @@ endif
|
||||
ifeq ($(OS_SOURCE),netbsd)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
ifeq ($(OS_SOURCE),openbsd)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),sunos)
|
||||
UNIXINSTALLDIR=1
|
||||
endif
|
||||
@ -452,6 +474,12 @@ HASSHAREDLIB=1
|
||||
FPCMADE=fpcmade.netbsd
|
||||
ZIPSUFFIX=netbsd
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
EXEEXT=
|
||||
HASSHAREDLIB=1
|
||||
FPCMADE=fpcmade.openbsd
|
||||
ZIPSUFFIX=openbsd
|
||||
endif
|
||||
ifeq ($(OS_TARGET),win32)
|
||||
PPUEXT=.ppw
|
||||
OEXT=.ow
|
||||
@ -829,6 +857,19 @@ REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_PASZLIB=1
|
||||
REQUIRE_PACKAGES_FCL=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),openbsd)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_PASZLIB=1
|
||||
REQUIRE_PACKAGES_INET=1
|
||||
REQUIRE_PACKAGES_FCL=1
|
||||
REQUIRE_PACKAGES_MYSQL=1
|
||||
REQUIRE_PACKAGES_IBASE=1
|
||||
endif
|
||||
ifeq ($(OS_TARGET),wdosx)
|
||||
REQUIRE_PACKAGES_RTL=1
|
||||
REQUIRE_PACKAGES_PASZLIB=1
|
||||
REQUIRE_PACKAGES_FCL=1
|
||||
endif
|
||||
ifdef REQUIRE_PACKAGES_RTL
|
||||
PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
|
||||
ifneq ($(PACKAGEDIR_RTL),)
|
||||
@ -991,6 +1032,9 @@ endif
|
||||
ifneq ($(OS_TARGET),$(OS_SOURCE))
|
||||
override FPCOPT+=-T$(OS_TARGET)
|
||||
endif
|
||||
ifeq ($(OS_SOURCE),openbsd)
|
||||
override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
|
||||
endif
|
||||
ifdef UNITDIR
|
||||
override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
|
||||
endif
|
||||
@ -1300,6 +1344,7 @@ fpc_baseinfo:
|
||||
@$(ECHO) Rm........ $(RMPROG)
|
||||
@$(ECHO) GInstall.. $(GINSTALL)
|
||||
@$(ECHO) Echo...... $(ECHO)
|
||||
@$(ECHO) Shell..... $(SHELL)
|
||||
@$(ECHO) Date...... $(DATE)
|
||||
@$(ECHO) FPCMake... $(FPCMAKE)
|
||||
@$(ECHO) PPUMove... $(PPUMOVE)
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
programs=stringl dparser fstream mstream list threads testrtf \
|
||||
cfgtest xmldump htdump testcgi tidea \
|
||||
b64test b64test2 b64enc b64dec restest testz testz2 \
|
||||
istream doecho testol testcont txmlreg testreg
|
||||
istream doecho testol testcont txmlreg testreg tstelcmd
|
||||
programs_win32=showver testproc testhres testnres testsres testrhre \
|
||||
testrnre testrsre
|
||||
programs_linux=sockcli isockcli dsockcli socksvr isocksvr dsocksvr \
|
||||
|
||||
@ -46,11 +46,13 @@ dsockcli.pp Dual socket server application. Tests ssockets.
|
||||
sstream.pp Tests TStringStream object.
|
||||
testol.pp Tests TObjectList in contnrs. (MVC)
|
||||
testcont.pp Tests TStack/TQueue in contnrs. (MVC)
|
||||
testhres.pp Test hostresolver in resolve
|
||||
testnres.pp Test netresolver in resolve
|
||||
testsres.pp Test serviceresolver in resolve
|
||||
testrhre.pp Test reverse hostresolver in resolve
|
||||
testrnre.pp Test reverse netresolver in resolve
|
||||
testrsre.pp Test reverse serviceresolver in resolve
|
||||
txmlreg.pp Test of xmlreg unit (xml-like registry)
|
||||
testreg.pp Test of registry unit.
|
||||
testhres.pp Test hostresolver in resolve (MVC)
|
||||
testnres.pp Test netresolver in resolve (MVC)
|
||||
testsres.pp Test serviceresolver in resolve (MVC)
|
||||
testrhre.pp Test reverse hostresolver in resolve (MVC)
|
||||
testrnre.pp Test reverse netresolver in resolve (MVC)
|
||||
testrsre.pp Test reverse serviceresolver in resolve (MVC)
|
||||
txmlreg.pp Test of xmlreg unit (xml-like registry) (MVC)
|
||||
testreg.pp Test of registry unit. (MVC)
|
||||
tstelcmd.pp Test of eventlog unit, command-line version.
|
||||
tstelgtk.pp Test of eventlog unit, FPGTK version. Not built by default. (MVC)
|
||||
|
||||
25
fcl/tests/tstelcmd.pp
Normal file
25
fcl/tests/tstelcmd.pp
Normal file
@ -0,0 +1,25 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{$ifdef win32}
|
||||
{$r fclel.res}
|
||||
{$endif}
|
||||
|
||||
program testelcmd;
|
||||
|
||||
uses eventlog;
|
||||
|
||||
Var
|
||||
E : TEventType;
|
||||
|
||||
begin
|
||||
With TEventLog.Create(Nil) do
|
||||
Try
|
||||
Identification:='Test eventlog class';
|
||||
RegisterMessageFile('');
|
||||
Active:=True;
|
||||
For E:=etInfo to etDebug do
|
||||
Log(E,'An event log message of type '+EventTypeToString(E));
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
end.
|
||||
158
fcl/tests/tstelgtk.pp
Normal file
158
fcl/tests/tstelgtk.pp
Normal file
@ -0,0 +1,158 @@
|
||||
{$mode objfpc}
|
||||
{$H+}
|
||||
{$apptype gui}
|
||||
|
||||
{$ifdef win32}
|
||||
{$R fclel.res}
|
||||
{$endif}
|
||||
|
||||
program tstelgtk;
|
||||
|
||||
uses gdk,gtk,fpgtk,fpgtkext,classes,sysutils,eventlog;
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Main form class
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
|
||||
Type
|
||||
TMainForm = Class(TFPGtkWindow)
|
||||
FEventLog : TEventLog;
|
||||
RGFrame : TFPgtkFrame;
|
||||
FHBox : TFPgtkHBox;
|
||||
RGBox,
|
||||
FVBox : TFPgtkVBox;
|
||||
BSend : TFPgtkButton;
|
||||
RGMsgType : TFPgtkRadioButtonGroup;
|
||||
FLMsg : TFPGtkLabel;
|
||||
FMsg : TFPGtkEntry;
|
||||
Procedure BSendClicked(Sender : TFPgtkObject; Data : Pointer);
|
||||
Public
|
||||
Constructor Create;
|
||||
Destructor Destroy; override;
|
||||
Procedure CreateWindow;
|
||||
Procedure SendEvent;
|
||||
end;
|
||||
|
||||
ResourceString
|
||||
SCaption = 'Free Pascal Event Log Demo';
|
||||
SEventlogDemo = 'TestEventlogClass';
|
||||
SMessage = 'Message text:';
|
||||
SMsgType = 'Message type:';
|
||||
SSend = 'Send message';
|
||||
SInformation = 'Information';
|
||||
SWarning = 'Warning';
|
||||
SError = 'Error';
|
||||
SDebug = 'Debug';
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Form Creation
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
Constructor TMainForm.Create;
|
||||
|
||||
begin
|
||||
Inherited create (gtk_window_dialog);
|
||||
Createwindow;
|
||||
end;
|
||||
|
||||
Procedure TMainForm.CreateWindow;
|
||||
|
||||
Procedure AddRG(C : String);
|
||||
|
||||
Var
|
||||
RB : TFPgtkRadioButton;
|
||||
|
||||
begin
|
||||
RB:= TFPgtkRadioButton.CreateWithLabel(RGmsgType,C);
|
||||
RGBox.Packstart(RB,False,False,2);
|
||||
rb.TheLabel.Justify:=GTK_JUSTIFY_LEFT;
|
||||
end;
|
||||
|
||||
Var
|
||||
S : TStrings;
|
||||
|
||||
begin
|
||||
BSend:=TFPGtkButton.CreateWithlabel(SSend);
|
||||
BSend.ConnectCLicked(@BSendClicked,Nil);
|
||||
RGFrame:=TFpgtkFrame.Create;
|
||||
RGFrame.Text:=SMsgType;
|
||||
RGBox:=TFPgtkVBox.Create;
|
||||
RGFRame.Add(RGBox);
|
||||
S:=TstringList.Create;
|
||||
try
|
||||
With S do
|
||||
begin
|
||||
Add(SInformation);
|
||||
Add(SWarning);
|
||||
Add(SError);
|
||||
Add(SDebug);
|
||||
end;
|
||||
RGMsgType:=RadioButtonGroupCreateFromStrings(S,Nil);
|
||||
RGMsgType.PackInBox(RGBox,True,False,False,2);
|
||||
Finally
|
||||
S.Free;
|
||||
end;
|
||||
FLMsg:=TfpGtkLabel.Create(SMessage);
|
||||
FMsg:=TfpGtkEntry.Create;
|
||||
FHBox:=TFPgtkHbox.Create;
|
||||
FHBox.PackStart(FLMsg,False,False,2);
|
||||
FHBox.PackStart(FMsg,True,True,2);
|
||||
Title:=SCaption;
|
||||
FVBox:=TFPgtkVBox.Create;
|
||||
FVBox.Homogeneous:=False;
|
||||
FVBox.PackStart(FHBox,False,False,2);
|
||||
FVBox.PackStart(RGFrame,False,False,2);
|
||||
FVBox.PackStart(BSend,true,false,2);
|
||||
Add(FVBox);
|
||||
FMsg.GrabFocus;
|
||||
FEventLog:=TEventlog.Create(Nil);
|
||||
FEventLog.Identification:=SEventLogDemo;
|
||||
FEventLog.RegisterMessagefile('');
|
||||
FEventLog.Active:=True;
|
||||
end;
|
||||
|
||||
Destructor TMainForm.Destroy;
|
||||
|
||||
begin
|
||||
FEventLog.Active:=False;
|
||||
FEventLog.Free;
|
||||
Inherited;
|
||||
end;
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Callback events
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
Procedure TMainForm.BSendClicked(Sender : TFPgtkObject; Data : Pointer);
|
||||
|
||||
begin
|
||||
SendEvent;
|
||||
end;
|
||||
|
||||
|
||||
Procedure TMainForm.SendEvent;
|
||||
|
||||
Var
|
||||
E : TEventType;
|
||||
|
||||
begin
|
||||
Case RGMsgType.ActiveButtonIndex of
|
||||
0 : E:=etinfo;
|
||||
1 : E:=etWarning;
|
||||
2 : E:=etError;
|
||||
3 : E:=etDebug;
|
||||
end;
|
||||
FEventLog.log(E,FMsg.Text);
|
||||
end;
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Program.
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
begin
|
||||
application := TFPgtkApplication.Create;
|
||||
application.MainWindow := TMainForm.Create;
|
||||
application.Run;
|
||||
application.Free;
|
||||
end.
|
||||
125
fcl/unix/eventlog.inc
Normal file
125
fcl/unix/eventlog.inc
Normal file
@ -0,0 +1,125 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Unix implementation of event mechanism
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{$linklib c}
|
||||
|
||||
const
|
||||
// OpenLog options
|
||||
LOG_PID = $01;
|
||||
LOG_CONS = $02;
|
||||
LOG_ODELAY = $04;
|
||||
LOG_NDELAY = $08;
|
||||
LOG_NOWAIT = $10;
|
||||
LOG_PERROR = $20;
|
||||
|
||||
// Priority levels
|
||||
LOG_EMERG = 0;
|
||||
LOG_ALERT = 1;
|
||||
LOG_CRIT = 2;
|
||||
LOG_ERR = 3;
|
||||
LOG_WARNING = 4;
|
||||
LOG_NOTICE = 5;
|
||||
LOG_INFO = 6;
|
||||
LOG_DEBUG = 7;
|
||||
LOG_PRIMASK = $07;
|
||||
|
||||
// facility
|
||||
LOG_KERN = 0 shl 3;
|
||||
LOG_USER = 1 shl 3;
|
||||
LOG_MAIL = 2 shl 3;
|
||||
LOG_DAEMON = 3 shl 3;
|
||||
LOG_AUTH = 4 shl 3;
|
||||
LOG_SYSLOG = 5 shl 3;
|
||||
LOG_LPR = 6 shl 3;
|
||||
LOG_NEWS = 7 shl 3;
|
||||
LOG_UUCP = 8 shl 3;
|
||||
LOG_CRON = 9 shl 3;
|
||||
LOG_AUTHPRIV = 10 shl 3;
|
||||
|
||||
procedure closelog;cdecl;external;
|
||||
procedure openlog(__ident:pchar; __option:longint; __facilit:longint);cdecl;external;
|
||||
function setlogmask(__mask:longint):longint;cdecl;external;
|
||||
procedure syslog(__pri:longint; __fmt:pchar; args:array of const);cdecl;external;
|
||||
|
||||
Function TEventLog.DefaultFileName : String;
|
||||
|
||||
begin
|
||||
Result:='/tmp/'+ChangeFileExt(ExtractFileName(Paramstr(0)),'.log');
|
||||
end;
|
||||
|
||||
Resourcestring
|
||||
SErrNoSysLog = 'Could not open system log (error %d)';
|
||||
SErrLogFailed = 'Failed to log entry (error %d)';
|
||||
|
||||
Procedure TEventLog.ActivateSystemLog;
|
||||
|
||||
begin
|
||||
CheckIdentification;
|
||||
OpenLog(Pchar(Identification),LOG_NOWAIT,LOG_USER);
|
||||
end;
|
||||
|
||||
Procedure TEventLog.DeActivateSystemLog;
|
||||
|
||||
begin
|
||||
CloseLog;
|
||||
end;
|
||||
|
||||
procedure TEventLog.WriteSystemLog(EventType : TEventType; Msg : String);
|
||||
|
||||
Var
|
||||
P,PT : PChar;
|
||||
T : String;
|
||||
|
||||
begin
|
||||
P:=PChar(Msg);
|
||||
T:=EventTypeToString(EventType);
|
||||
PT:=PChar(T);
|
||||
syslog(MapTypeToEvent(EventType),'[%s] %s',[PT,P]);
|
||||
end;
|
||||
|
||||
Function TEventLog.RegisterMessageFile(AFileName : String) : Boolean;
|
||||
|
||||
begin
|
||||
Result:=True;
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToCategory(EventType: TEventType): Word;
|
||||
begin
|
||||
Result:=0;
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToEventID(EventType: TEventType): DWord;
|
||||
|
||||
begin
|
||||
Result:=0;
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToEvent(EventType: TEventType): DWord;
|
||||
|
||||
Const
|
||||
WinET : Array[TEventType] of word = (LOG_NOTICE,
|
||||
LOG_INFO,LOG_WARNING,LOG_ERR,LOG_DEBUG);
|
||||
|
||||
begin
|
||||
If EventType=etCustom Then
|
||||
begin
|
||||
If CustomLogType=0 then
|
||||
CustomLogType:=LOG_NOTICE;
|
||||
Result:=CustomLogType
|
||||
end
|
||||
else
|
||||
Result:=WinET[EventType];
|
||||
end;
|
||||
142
fcl/win32/eventlog.inc
Normal file
142
fcl/win32/eventlog.inc
Normal file
@ -0,0 +1,142 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Win32 implementation part of 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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
uses windows,registry;
|
||||
|
||||
Function TEventLog.DefaultFileName : String;
|
||||
|
||||
begin
|
||||
Result:=ChangeFileExt(Paramstr(0),'.log');
|
||||
end;
|
||||
|
||||
Resourcestring
|
||||
SErrNoSysLog = 'Could not open system log (error %d)';
|
||||
SErrLogFailed = 'Failed to log entry (error %d)';
|
||||
|
||||
Procedure TEventLog.ActivateSystemLog;
|
||||
|
||||
begin
|
||||
CheckIdentification;
|
||||
FLogHandle := Pointer(OpenEventLog(Nil,Pchar(Identification)));
|
||||
If FLogHandle=Nil then
|
||||
Raise ELogError.CreateFmt(SErrNoSysLog,[GetLastError]);
|
||||
end;
|
||||
|
||||
Procedure TEventLog.DeActivateSystemLog;
|
||||
|
||||
begin
|
||||
CloseEventLog(Cardinal(FLogHandle));
|
||||
end;
|
||||
|
||||
{
|
||||
function ReportEvent(hEventLog: THandle; wType, wCategory: Word;
|
||||
dwEventID: DWORD; lpUserSid: Pointer; wNumStrings: Word;
|
||||
dwDataSize: DWORD; lpStrings, lpRawData: Pointer): BOOL; stdcall;
|
||||
}
|
||||
|
||||
procedure TEventLog.WriteSystemLog(EventType : TEventType; Msg : String);
|
||||
|
||||
Var
|
||||
P : PChar;
|
||||
I : Integer;
|
||||
FCategory : Word;
|
||||
FEventID : DWord;
|
||||
FEventType : Word;
|
||||
|
||||
begin
|
||||
FCategory:=MapTypeToCategory(EventType);
|
||||
FEventID:=MapTypeToEventID(EventType);
|
||||
FEventType:=MapTypeToEvent(EventType);
|
||||
P:=PChar(Msg);
|
||||
If Not ReportEvent(Cardinal(FLogHandle),FEventType,FCategory,FEventID,Nil,1,0,@P,Nil) then
|
||||
begin
|
||||
I:=GetLastError;
|
||||
Raise ELogError.CreateFmt(SErrLogFailed,[I]);
|
||||
end;
|
||||
end;
|
||||
|
||||
Function TEventLog.RegisterMessageFile(AFileName : String) : Boolean;
|
||||
|
||||
Const
|
||||
SKeyEventLog = '\SYSTEM\CurrentControlSet\Services\EventLog\Application\%s';
|
||||
SKeyCategoryCount = 'CategoryCount';
|
||||
SKeyEventMessageFile = 'EventMessageFile';
|
||||
SKeyCategoryMessageFile = 'CategoryMessageFile';
|
||||
SKeyTypesSupported = 'TypesSupported';
|
||||
|
||||
Var
|
||||
ELKey : String;
|
||||
R : TRegistry;
|
||||
|
||||
begin
|
||||
CheckIdentification;
|
||||
If AFileName='' then
|
||||
AFileName:=ParamStr(0);
|
||||
R:=TRegistry.Create;
|
||||
Try
|
||||
R.RootKey:=HKEY_LOCAL_MACHINE;
|
||||
ELKey:=Format(SKeyEventLog,[IDentification]);
|
||||
Result:=R.OpenKey(ELKey,True);
|
||||
If Result then
|
||||
try
|
||||
R.WriteInteger(SKeyCategoryCount,4);
|
||||
R.WriteString(SKeyCategoryMessageFile,AFileName);
|
||||
R.WriteString(SKeyEventMessageFile,AFileName);
|
||||
R.WriteInteger(SKeyTypesSupported,7);
|
||||
except
|
||||
Result:=False;
|
||||
end
|
||||
Finally
|
||||
R.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToCategory(EventType: TEventType): Word;
|
||||
begin
|
||||
Result:=Ord(EventType);
|
||||
If Result=0 then
|
||||
Result:=1;
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToEventID(EventType: TEventType): DWord;
|
||||
|
||||
begin
|
||||
If (FEventIDOffset=0) then
|
||||
FEventIDOffset:=1000;
|
||||
Result:=FEventIDOffset+Ord(EventType);
|
||||
end;
|
||||
|
||||
function TEventLog.MapTypeToEvent(EventType: TEventType): DWord;
|
||||
|
||||
|
||||
|
||||
Const
|
||||
EVENTLOG_SUCCESS=0;
|
||||
WinET : Array[TEventType] of word = (EVENTLOG_SUCCESS,
|
||||
EVENTLOG_INFORMATION_TYPE,
|
||||
EVENTLOG_WARNING_TYPE,EVENTLOG_ERROR_TYPE,
|
||||
EVENTLOG_AUDIT_SUCCESS);
|
||||
|
||||
begin
|
||||
If EventType=etCustom Then
|
||||
begin
|
||||
If CustomLogType=0 then
|
||||
CustomLogType:=EVENTLOG_SUCCESS;
|
||||
Result:=CustomLogType
|
||||
end
|
||||
else
|
||||
Result:=WinET[EventType];
|
||||
end;
|
||||
79
fcl/win32/fclel.mc
Normal file
79
fcl/win32/fclel.mc
Normal file
@ -0,0 +1,79 @@
|
||||
; $Id$
|
||||
; This file is part of the Free Pascal run time library.
|
||||
; Copyright (c) 2003 by the Free Pascal development team
|
||||
;
|
||||
; Messages for 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.
|
||||
;
|
||||
;
|
||||
;******************************************************
|
||||
; Default messages for FPC eventlog class
|
||||
;******************************************************
|
||||
; Categories are mapped from 1 to 4
|
||||
; 1 : etInfo
|
||||
; 2 : etWarning
|
||||
; 3 : etError
|
||||
; 4 : etDebug
|
||||
;
|
||||
; Categories (1-4)
|
||||
MessageId=1
|
||||
SymbolicName=ECInfo
|
||||
Language=English
|
||||
Information
|
||||
.
|
||||
|
||||
MessageId=2
|
||||
SymbolicName=ECWarning
|
||||
Language=English
|
||||
Warning
|
||||
.
|
||||
|
||||
MessageId=3
|
||||
SymbolicName=ECError
|
||||
Language=English
|
||||
Error
|
||||
.
|
||||
|
||||
MessageId=4
|
||||
SymbolicName=ECDebug
|
||||
Language=English
|
||||
Debug
|
||||
.
|
||||
|
||||
;
|
||||
; Message Definitions (1000-1004)
|
||||
;
|
||||
MessageId=1000
|
||||
Language=English
|
||||
%1.
|
||||
.
|
||||
|
||||
; Information
|
||||
MessageId=1001
|
||||
Language=English
|
||||
Information: %1
|
||||
.
|
||||
|
||||
; Warnings
|
||||
MessageId=1002
|
||||
Language=English
|
||||
Warning: %1
|
||||
.
|
||||
|
||||
; Error
|
||||
MessageId=1003
|
||||
Language=English
|
||||
Error: %1
|
||||
.
|
||||
|
||||
; Debug
|
||||
MessageId=1004
|
||||
Language=English
|
||||
Debug: %1
|
||||
.
|
||||
2
fcl/win32/fclel.rc
Normal file
2
fcl/win32/fclel.rc
Normal file
@ -0,0 +1,2 @@
|
||||
LANGUAGE 0x9,0x1
|
||||
1 11 "C:\\TEMP\\fclel.msg"
|
||||
BIN
fcl/win32/fclel.res
Normal file
BIN
fcl/win32/fclel.res
Normal file
Binary file not shown.
Loading…
Reference in New Issue
Block a user