ibevents.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2001 Borland Software Corporation             }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    IBEvents was strongly based upon David S. Becker's SuperIB Events   }
{    with permission (www.rcsis.com/users/dbecker/superib).  Thank you   }
{    David.                                                              }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You may obtain }
{    a copy of the License at http://www.borland.com/interbase/IPL.html  }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Borland Software Corporation are Copyright      }
{       (C) Borland Software Corporation. All Rights Reserved.           }
{    Contributor(s): David S. Becker, Jeff Overcash, Slavomir Skopalik   }
{                                                                        }
{************************************************************************}

unit IBEvents;

interface

uses
  SysUtils, Classes,
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF}
  {$IFDEF LINUX}
  Libc,
  {$ENDIF}
  DB, IBHeader, IBExternals, IB, IBDatabase;

type

  TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
                           var CancelAlerts: Boolean) of object;
  TErrorEvent=procedure( Sender: TObject; ErrorCode:integer)of object;

  TIBEvents = class(TComponent, IIBEventNotifier)
  private
    FEvents: TStrings;
    FOnEventAlert: TEventAlert;
    FThreads : TList;
    FNativeHandle : TISC_DB_HANDLE;
    ThreadException : Boolean;
    FDatabase: TIBDatabase;
    FOnError: TErrorEvent;
    FAutoRegister: Boolean;
    FRegistered : Boolean;

    procedure SetDatabase( value: TIBDatabase);
    procedure SetEvents(Value: TStrings);
    function GetRegistered: Boolean;
    procedure SetRegistered(const Value: Boolean);
  protected
    { Protected declarations }
    function GetNativeHandle: TISC_DB_HANDLE; virtual;
    procedure EventChange(Sender: TObject); virtual;
    procedure ThreadEnded(Sender: TObject); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure ValidateDatabase(DataBase: TIBDatabase); virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure RegisterEvents; virtual;
    procedure UnRegisterEvents; virtual;
    property NativeHandle: TISC_DB_HANDLE read GetNativeHandle;
    procedure SetAutoRegister(const Value: Boolean);
    function GetAutoRegister: Boolean;
  published
    { Published declarations }
    property AutoRegister: Boolean read GetAutoRegister write SetAutoRegister;
    property Database: TIBDatabase read FDatabase write SetDatabase;
    property Events: TStrings read FEvents write SetEvents;
    property Registered: Boolean read GetRegistered write SetRegistered;
    property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
    property OnError:TErrorEvent read FOnError write FOnError;
  end;

implementation

uses
  IBIntf, SyncObjs;

const
  IB_MAX_EVENT_BLOCK   = 15;   // maximum events handled per block by InterBase
  IB_MAX_EVENT_LENGTH  = 64;  // maximum event name length
{$IFDEF LINUX}
  INFINITE = $FFFFFFFF;
{$ENDIF}

type

  { TIBEventThread }
  TIBEventThread = class(TThread)
  private
    // IB API call parameters
    WhichEvent: Integer;
    EventID: ISC_LONG;
    EventBuffer: PChar;
    EventBufferLen: Short;
    ResultBuffer: PChar;
    // Local use variables
    Signal: TSimpleEvent;
    EventsReceived,
    FirstTime: Boolean;
    EventGroup,
    EventCount: Integer;
    Parent: TIBEvents;
    FExceptObject: TObject;
    FExceptAddr: Pointer;
    FCancelAlerts : Boolean;
  protected
    procedure Execute; override;
    procedure SignalEvent; virtual;
    procedure SignalTerminate; virtual;
    procedure RegisterEvents; virtual;
    procedure UnRegisterEvents; virtual;
    procedure QueueEvents; virtual;
    procedure SQueEvents;
    procedure ProcessEvents; virtual;
    procedure DoEvent;
    procedure DoHandleException;
    function HandleException: Boolean; virtual;
    procedure UpdateResultBuffer(Length: UShort; Updated: PChar);
  public
    constructor Create(Owner: TIBEvents; EventGrp: Integer; TermEvent: TNotifyEvent); virtual;
    destructor Destroy; override;
  end;

  Tsib_event_block = function (EventBuffer, ResultBuffer: PPChar; IDCount: UShort;
    Event1, Event2, Event3, Event4, Event5, Event6, Event7, Event8, Event9,
    Event10, Event11, Event12, Event13, Event14, Event15: PChar): ISC_LONG; cdecl;

function TIBEvents.GetNativeHandle: TISC_DB_HANDLE;
begin
  ValidateDatabase(FDatabase);
  Result := FDatabase.Handle;
end;

procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
begin
  if not assigned( Database) then
    IBError(ibxeDatabaseNameMissing, [nil]);
  if not Database.Connected then
    IBError(ibxeDatabaseClosed, [nil]);
end;

{ TIBEvents }

constructor TIBEvents.Create( AOwner: TComponent);
begin
  inherited Create( AOwner);
  CheckIBLoaded;
  ThreadException := False;
  FOnEventAlert := nil;
  FNativeHandle := nil;
  FDatabase := nil;
  FAutoRegister := False;
  FEvents := TStringList.Create;
  with TStringList(FEvents) do
  begin
    Sorted := true;  // dupIgnore only works when the TStringList is sorted
    OnChange := EventChange; // assign the routine which validates the event lenghts
    Duplicates := dupIgnore; // don't allow duplicate events
  end;
  FThreads := TList.Create;
end;

destructor TIBEvents.Destroy;
begin
  try
    if Registered then
      UnRegisterEvents;
  except
    // silence any exceptions which might be raised
    // by UnRegisterEvents during destruction
  end;
  If Assigned(FDatabase) then
    FDatabase.RemoveEventNotifier(Self);
  FThreads.Free;
  IF Assigned(FEvents) then
    TStringList(FEvents).OnChange := nil;
  FEvents.Free;
  inherited Destroy;
end;

procedure TIBEvents.Notification( AComponent: TComponent;
                                        Operation: TOperation);
begin
  inherited Notification( AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FDatabase) then
  begin
    if Registered then
      UnRegisterEvents;
    FDatabase := nil;
  end;
end;

procedure TIBEvents.RegisterEvents;
var
  i: Integer;
begin
  if csDesigning in ComponentState then
    exit;
  if not Assigned(FDatabase) then
    IBError(ibxeDatabaseNameMissing, []);
  if (FThreads.Count = 0) then
  begin
    if (FEvents.Count > 0) then
    begin
      for i := 0 to ((FEvents.Count - 1) div IB_MAX_EVENT_BLOCK) do
        FThreads.Add(TIBEventThread.Create(Self, i, ThreadEnded));
    end;
  end
  else
    IBError(ibxeEventAlreadyRegistered, []);
end;

procedure TIBEvents.SetEvents( value: TStrings);
begin
  FEvents.Assign(value);
end;

procedure TIBEvents.SetDatabase( value: TIBDatabase);
var
  WasRegistered: Boolean;
begin
  if (Value <> FDatabase) then
  begin
    if (csDesigning in ComponentState) then
      FDatabase := Value
    else
    begin
      WasRegistered := Registered;
      if WasRegistered then
        UnRegisterEvents;
      try
        if Assigned(FDatabase) then
          FDatabase.RemoveEventNotifier(Self);

        FDatabase := Value;

        if Assigned(FDatabase) then
          FDatabase.AddEventNotifier(Self);

      finally
        if WasRegistered then
          RegisterEvents;
      end;
    end;
  end;
end;

procedure TIBEvents.SetRegistered(const Value : Boolean);
begin
  FRegistered := Value;
  if csDesigning in ComponentState then
    exit;
  if Value then
    RegisterEvents
  else
    UnRegisterEvents;
end;

procedure TIBEvents.UnregisterEvents;
var
  i: Integer;
  Temp: TIBEventThread;
begin
  if csDesigning in ComponentState then
    exit;