zibsqlnotify.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{            Interbase Notification Component            }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2001 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZIbSqlNotify;

interface

uses
  SysUtils, Classes, DB, ZLibIbSql, ZDirIbSql, ZIbSqlCon, ZIbSqlTr;

type

  TZEventAlert = procedure(Sender: TObject; EventName: string; EventCount: LongInt;
    var CancelAlerts: Boolean) of object;
  TZErrorEvent = procedure(Sender: TObject; ErrorCode: Integer) of object;

  TZIbSqlNotify = class(TComponent)
  private
    FEvents: TStrings;
    FOnEventAlert: TZEventAlert;
    FThreads: TList;
    FNativeHandle: TISC_DB_HANDLE;
    ThreadException: Boolean;
    FDatabase: TZIbSqlDatabase;
    FOnError: TZErrorEvent;
    FAutoRegister: Boolean;
    FRegistered: Boolean;

    FStatusVector: ARRAY_ISC_STATUS;

    procedure SetDatabase(value: TZIbSqlDatabase);
    procedure SetEvents(Value: TStrings);
    function GetRegistered: Boolean;
    procedure SetRegistered(const Value: Boolean);
  protected
    //FTransact: TZIbSqlTransact;

    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: TZIbSqlDatabase); virtual;

    function GetErrorMsg: ShortString;
  public
    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
    property AutoRegister: Boolean read GetAutoRegister write SetAutoRegister;
    property Database: TZIbSqlDatabase read FDatabase write SetDatabase;
    property Events: TStrings read FEvents write SetEvents;
    property Registered: Boolean read GetRegistered write SetRegistered;
    property OnEventAlert: TZEventAlert read FOnEventAlert write FOnEventAlert;
    property OnError: TZErrorEvent read FOnError write FOnError;
  end;

implementation

uses SyncObjs;

const
  IB_MAX_EVENT_BLOCK = 15; // maximum events handled per block by InterBase
  IB_MAX_EVENT_LENGTH = 64; // maximum event name length

type
  { TZIbSqlNotifyTread }
  TZIbSqlNotifyTread = class(TThread)
  private
    { IB API call parameters }
    WhichEvent: Integer;
    EventID: ISC_LONG;
    EventBuffer: PChar;
    EventBufferLen: SmallInt;
    ResultBuffer: PChar;

    { Local use variables }
    Signal: TSimpleEvent;
    EventsReceived, FirstTime: Boolean;
    EventGroup, EventCount: Integer;
    Parent: TZIbSqlNotify;
    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: TZIbSqlNotify; 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 TZIbSqlNotify.GetNativeHandle: TISC_DB_HANDLE;
begin
  ValidateDatabase(FDatabase);
  Result := TDirIbSqlConnect(FDatabase.Handle).Handle;
end;

procedure TZIbSqlNotify.ValidateDatabase(Database: TZIbSqlDatabase);
begin
  if not Assigned(Database) then
    DataBaseError('Database Name Missing');
  if not Database.Connected then
    DataBaseError('Database Closed');
end;

{ TZIbSqlNotify }

constructor TZIbSqlNotify.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  CheckIbSqlLoaded;

  //FTransact:= TZIbSqlTransact.Create(nil) ;//added by faraj
  //FTransact.TransactSafe:=False;//faraj

  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 TZIbSqlNotify.Destroy;
begin
  try
    if Registered then
      UnRegisterEvents;
  except
   // silence any exceptions which might be raised
   // by UnRegisterEvents during destruction
  end;

 {
  If Assigned(FTransact) then //faraj
    FTransact.RemoveNotify(Self);
 }

  FThreads.Free;
  TStringList(FEvents).OnChange := nil;
  FEvents.Free;

  //FTransact.Free;//Faraj
  inherited Destroy;
end;

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

    //faraj
    //FTransact.Database := nil;
  end;
end;

function TZIbSqlNotify.GetErrorMsg: ShortString;
var
  PStatusVector: PISC_STATUS;
  Msg: array[0..1024] of Char;
begin
  if (FStatusVector[0] = 1) and (FStatusVector[1] > 0) then
  begin
    PStatusVector := @FStatusVector;
    isc_interprete(Msg, @PStatusVector);
    Result := StrPas(Msg);
  end
  else if not Registered then
    Result := 'Not Registered'
  else
    Result := '';
end;


procedure TZIbSqlNotify.RegisterEvents;
var
  i: Integer;
begin
  if csDesigning in ComponentState then Exit;
  if FThreads.Count = 0 then
  begin
    {
    if not FTransact.Connected then
      FTransact.Connect; //Faraj
    }

    if FEvents.Count > 0 then
    begin
      for I := 0 to ((FEvents.Count - 1) div IB_MAX_EVENT_BLOCK) do
        FThreads.Add(TZIbSqlNotifyTread.Create(Self, i, ThreadEnded));
    end;
  end else
    DataBaseError('Event Already Registered');
end;

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

procedure TZIbSqlNotify.SetDatabase(value: TZIbSqlDatabase);
var
  WasRegistered: Boolean;
begin
  if (Value <> FDatabase) then
  begin
    //FTransact.Database:=Value; //Faraj

    if (csDesigning in ComponentState) then
      FDatabase := Value
    else
    begin
      WasRegistered := Registered;
      if WasRegistered then
        UnRegisterEvents;
      try
      {
        if Assigned(FTransact) then  //faraj
          FTransact.RemoveNotify(Self);
      }
          FDatabase := Value;
      {
        if Assigned(FTransact) then  //faraj
          FTransact.AddNotify(Self);
      }
      finally
        if WasRegistered then
          RegisterEvents;
      end;
    end;
  end;
end;

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

procedure TZIbSqlNotify.UnregisterEvents;
var
  I: Integer;
  Temp: TZIbSqlNotifyTread;
begin
  if csDesigning in ComponentState then Exit;
  if (FThreads.Count > 0) then
  begin