eventlog.pas

boomerang library 5.11 internet ed

(* EventLog - NT event log library
 * Copyright (C) 2005  Tomas Mandys-MandySoft
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA  02111-1307  USA
 *)

{ URL: http://www.2p.cz }

unit {$IFDEF CLR}MandySoft.Vcl.{$ENDIF}EventLog;

{ EventLog.htx }

interface
uses
  Classes, SysUtils, Windows, Connect, SyncObjs;

type
  TOnEventLogExceptionEvent = procedure(Sender: TComponent; E: Exception; const aType, aCategory: Word; aId: Longword; const aText: array of string; aRawLength: LongWord; aRawData: Pointer) of object;

  TEventLog = class(TConnection)
  private
    FCriticalSection: TCriticalSection;
    fAutoOpen: Boolean;
    fOnException: TOnEventLogExceptionEvent;
    fId: LongWord;
    fHandle: THandle;
    fServerName: string;
    fSourceName: string;
    procedure SetAutoOpen(aValue: Boolean);
    procedure SetServerName(const aValue: string);
    procedure SetSourceName(const aValue: string);
  protected
    procedure DoOnException(E: Exception; const aType, aCategory: Word; aId: Longword; const aText: array of string; aRawLength: LongWord; aRawData: Pointer); virtual;
    procedure OpenConn; override;
    procedure CloseConn; override;
  public
    property CriticalSection: TCriticalSection read fCriticalSection;
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure Log(const aType, aCategory: Word; const aText: array of string; aRawLength: Longword; aRawData: Pointer); overload;
    procedure Log(const aType, aCategory: Word; const aText: array of string); overload;
    procedure Log(const aType, aCategory: Word; const aText: array of string; const aRawData: array of Char); overload;
    procedure Log(const aType, aCategory: Word; const aText: array of string; const aRawData: TStream); overload;
  published
    property AutoOpen: Boolean read fAutoOpen write SetAutoOpen;
    property OnException: TOnEventLogExceptionEvent read fOnException write fOnException;

    property ServerName: string read fServerName write SetServerName;
    property SourceName: string read fSourceName write SetSourceName;
    property Id: LongWord read fId write fId;
    property Handle: THandle read fHandle;
  end;

procedure Register;

implementation

constructor TEventLog.Create(aOwner: TComponent);
begin
  inherited;
  FCriticalSection:= TCriticalSection.Create;
end;

destructor TEventLog.Destroy;
begin
  FCriticalSection.Free;
  inherited;
end;

procedure TEventLog.SetAutoOpen(aValue: Boolean);
begin
  CheckInactive;
  fAutoOpen:= aValue;
end;

procedure TEventLog.DoOnException;
begin
  if Assigned(fOnException) then
    fOnException(Self, E, aType, aId, aCategory, aText, aRawLength, aRawData);
end;

procedure TEventLog.Log(const aType, aCategory: Word; const aText: array of string; aRawLength: Longword; aRawData: Pointer);
var
  SaveActive: Boolean;
  Arr: array of PChar;
  P1: Pointer;
  I: Integer;
begin
  if (Self <> nil) and (Active or FAutoOpen) then
  begin
    FCriticalSection.Enter;
    try
      SaveActive:= Active;
      try
        Open;
        try
          fId:= fId+1;
          SetLength(Arr, Length(aText));
          for I:= Low(aText) to High(aText) do
            Arr[I-Low(aText)]:= PChar(aText[I]);  // ASCIIZ automatically, I hope
          if Length(Arr) > 0 then
            P1:= @(Arr[0])
          else
            P1:= nil;

          if aRawData = nil then
            aRawLength:= 0;
          if aRawLength = 0 then
            aRawData:= nil;

          if not ReportEvent(fHandle, aType, aCategory, fId, nil, Length(Arr), aRawLength, P1, aRawData) then
            RaiseLastWin32Error();

        finally
          Active:= SaveActive;
        end;
      except
        on E: Exception do
          DoOnException(E, aType, aCategory, fId, aText, aRawLength, aRawData);
      end;
    finally
      FCriticalSection.Leave;
    end;
  end;
end;

procedure TEventLog.Log(const aType, aCategory: Word; const aText: array of string);
begin
  Log(aType, aCategory, aText, 0, nil);
end;

procedure TEventLog.Log(const aType, aCategory: Word; const aText: array of string; const aRawData: array of Char);
var
  P: Pointer;
begin
  if Length(aRawData) = 0 then
    P:= nil
  else
    P:= @(aRawData[0]);
  Log(aType, aCategory, aText, Length(aRawData), P);
end;

procedure TEventLog.Log(const aType, aCategory: Word; const aText: array of string; const aRawData: TStream);
var
  St: TMemoryStream;
begin
  if aRawData = nil then
    begin
      Log(aType, aCategory, aText);
    end
  else
    begin
      if aRawData is TMemoryStream then
        St:= aRawData as TMemoryStream
      else
        begin
          St:= TMemoryStream.Create;
          St.CopyFrom(aRawData, aRawData.Size-aRawData.Position);
          St.Position:= 0;
        end;
      Log(aType, aCategory, aText, St.Size-St.Position, Pointer(LongInt(St.Memory)+St.Position));

      if aRawData <> St then
        St.Free;
    end;
end;

procedure TEventLog.OpenConn;
var
  P: PChar;
begin
  if fServerName = '' then
    P:= nil
  else
    P:= PChar(fServerName);
  fHandle:= RegisterEventSource(P, PChar(fSourceName));
  if fHandle = 0 then
    RaiseLastWin32Error();
end;

procedure TEventLog.CloseConn;
begin
  DeregisterEventSource(fHandle);
end;

procedure TEventLog.SetServerName;
begin
  CheckInactive;
  fServerName:= aValue;
end;

procedure TEventLog.SetSourceName;
begin
  CheckInactive;
  fSourceName:= aValue;
end;

procedure Register;
begin
  RegisterComponents('Communication', [TEventLog]);
end;

end.