00001 {*********************************************************}
00002 { }
00003 { Zeos Database Objects }
00004 { Interbase Database Connectivity Classes }
00005 { }
00006 { Copyright (c) 1999-2003 Zeos Development Group }
00007 { Written by Sergey Merkuriev }
00008 { }
00009 {*********************************************************}
00010
00011 {*********************************************************}
00012 { License Agreement: }
00013 { }
00014 { This library is free software; you can redistribute }
00015 { it and/or modify it under the terms of the GNU Lesser }
00016 { General Public License as published by the Free }
00017 { Software Foundation; either version 2.1 of the License, }
00018 { or (at your option) any later version. }
00019 { }
00020 { This library is distributed in the hope that it will be }
00021 { useful, but WITHOUT ANY WARRANTY; without even the }
00022 { implied warranty of MERCHANTABILITY or FITNESS FOR }
00023 { A PARTICULAR PURPOSE. See the GNU Lesser General }
00024 { Public License for more details. }
00025 { }
00026 { You should have received a copy of the GNU Lesser }
00027 { General Public License along with this library; if not, }
00028 { write to the Free Software Foundation, Inc., }
00029 { 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA }
00030 { }
00031 { The project web site is located on: }
00032 { http:
00033 { http:
00034 { }
00035 { Zeos Development Group. }
00036 {*********************************************************}
00037
00038 unit ZIBEventAlerter;
00039
00040 {$I ..\dbc\ZDbc.inc}
00041
00042 interface
00043
00044 uses
00045 SysUtils, Classes, Math,
00046 {$IFNDEF UNIX}
00047 Windows,
00048 {$ELSE}
00049 {$IFNDEF FPC}
00050 libc,
00051 {$ENDIF}
00052 {$ENDIF}
00053 ZDbcInterbase6, ZPlainInterbaseDriver, ZConnection, ZDbcIntfs,
00054 ZPlainInterbase5, ZPlainInterbase6, ZPlainFirebird10, ZPlainFirebird15, ZPlainFirebird20, ZPlainFirebirdInterbaseConstants;
00055
00056 type
00057
00058 TEventAlert = procedure(Sender: TObject; EventName: string; EventCount: longint;
00059 var CancelAlerts: boolean) of object;
00060 TErrorEvent = procedure(Sender: TObject; ErrorCode: integer) of object;
00061
00062 TZIBEventAlerter = class(TComponent)
00063 private
00064 FEvents: TStrings;
00065 FOnEventAlert: TEventAlert;
00066 FThreads: TList;
00067 FNativeHandle: PISC_DB_HANDLE;
00068 ThreadException: boolean;
00069 FConnection: TZConnection;
00070 FOnError: TErrorEvent;
00071 FAutoRegister: boolean;
00072 FRegistered: boolean;
00073
00074 procedure SetConnection(Value: TZConnection);
00075 procedure SetEvents(Value: TStrings);
00076 function GetRegistered: boolean;
00077 procedure SetRegistered(const Value: boolean);
00078 function GetPlainDriver: IZInterbasePlainDriver;
00079 protected
00080 { Protected declarations }
00081 function GetNativeHandle: PISC_DB_HANDLE; virtual;
00082 procedure EventChange(Sender: TObject); virtual;
00083 procedure ThreadEnded(Sender: TObject); virtual;
00084 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
00085 public
00086 { Public declarations }
00087 constructor Create(AOwner: TComponent); override;
00088 destructor Destroy; override;
00089 procedure RegisterEvents; virtual;
00090 procedure UnRegisterEvents; virtual;
00091 property NativeHandle: PISC_DB_HANDLE read GetNativeHandle;
00092 property PlainDriver: IZInterbasePlainDriver read GetPlainDriver;
00093 procedure SetAutoRegister(const Value: boolean);
00094 function GetAutoRegister: boolean;
00095 published
00096 { Published declarations }
00097 property AutoRegister: boolean read GetAutoRegister write SetAutoRegister;
00098 property Connection: TZConnection read FConnection write SetConnection;
00099 property Events: TStrings read FEvents write SetEvents;
00100 property Registered: boolean read GetRegistered write SetRegistered;
00101 property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
00102 property OnError: TErrorEvent read FOnError write FOnError;
00103 end;
00104
00105 implementation
00106
00107 uses
00108 SyncObjs;
00109
00110 const
00111 IB_MAX_EVENT_BLOCK = 15;
00112 IB_MAX_EVENT_LENGTH = 64;
00113 {$IFDEF LINUX}
00114 INFINITE = $FFFFFFFF;
00115 {$ELSE}
00116 {$IFDEF VER140BELOW}
00117 INFINITE = $FFFFFFFF;
00118 {$ENDIF}
00119 {$ENDIF}
00120 threadvar
00121 FStatusVector: TARRAY_ISC_STATUS;
00122
00123 type
00124
00125 { TIBEventThread }
00126 TIBEventThread = class(TThread)
00127 private
00128
00129 WhichEvent: integer;
00130 EventID: ISC_LONG;
00131 EventBuffer: PChar;
00132 EventBufferLen: Short;
00133 ResultBuffer: PChar;
00134
00135 Signal: TSimpleEvent;
00136 EventsReceived,
00137 FirstTime: boolean;
00138 EventGroup,
00139 EventCount: integer;
00140 Parent: TZIBEventAlerter;
00141 FExceptObject: TObject;
00142 FExceptAddr: Pointer;
00143 FCancelAlerts: boolean;
00144 protected
00145 procedure Execute; override;
00146 procedure SignalEvent; virtual;
00147 procedure SignalTerminate; virtual;
00148 procedure RegisterEvents; virtual;
00149 procedure UnRegisterEvents; virtual;
00150 procedure QueueEvents; virtual;
00151 procedure SQueEvents;
00152 procedure ProcessEvents; virtual;
00153 procedure DoEvent;
00154 procedure DoHandleException;
00155 function HandleException: boolean; virtual;
00156 procedure UpdateResultBuffer(Length: UShort; Updated: PChar);
00157 public
00158 constructor Create(Owner: TZIBEventAlerter; EventGrp: integer;
00159 TermEvent: TNotifyEvent); virtual;
00160 destructor Destroy; override;
00161 end;
00162
00163 Tsib_event_block = function(EventBuffer, ResultBuffer: PPChar; IDCount: UShort;
00164 Event1, Event2, Event3, Event4, Event5, Event6, Event7, Event8, Event9,
00165 Event10, Event11, Event12, Event13, Event14, Event15: PChar): ISC_LONG;
00166 cdecl;
00167
00168 function TZIBEventAlerter.GetNativeHandle: PISC_DB_HANDLE;
00169 begin
00170 Result := (FConnection.DbcConnection as IZInterbase6Connection).GetDBHandle;
00171 end;
00172
00173 function StatusVector: PISC_STATUS;
00174 begin
00175 Result := @FStatusVector;
00176 end;
00177
00178 function StatusVectorArray: TARRAY_ISC_STATUS;
00179 begin
00180 Result := FStatusVector;
00181 end;
00182
00183 { TZIBEventAlerter }
00184
00185 constructor TZIBEventAlerter.Create(AOwner: TComponent);
00186 begin
00187 inherited Create(AOwner);
00188
00189 ThreadException := False;
00190 FOnEventAlert := nil;
00191 FNativeHandle := nil;
00192 FConnection := nil;
00193 FAutoRegister := False;
00194 FEvents := TStringList.Create;
00195 with TStringList(FEvents) do
00196 begin
00197 Sorted := True;
00198 OnChange := EventChange;
00199 Duplicates := dupIgnore;
00200 end;
00201 FThreads := TList.Create;
00202 end;
00203
00204 destructor TZIBEventAlerter.Destroy;
00205 begin
00206 try
00207 if Registered then
00208 UnRegisterEvents;
00209 except
00210
00211
00212 end;
00213
00214 { If Assigned(FConnection) then
00215 FConnection.RemoveEventNotifier(Self);
00216 }
00217
00218 FThreads.Free;
00219 FEvents.Free;
00220
00221 inherited Destroy;
00222 end;
00223
00224 procedure TZIBEventAlerter.Notification(AComponent: TComponent;
00225 Operation: TOperation);
00226 begin
00227 inherited Notification(AComponent, Operation);
00228 if (Operation = opRemove) and (AComponent = FConnection) then
00229 begin
00230 if Registered then
00231 UnRegisterEvents;
00232 FConnection := nil;
00233 end;
00234 end;
00235
00236
00237
00238
00239
00240
00241
00242
00243
00244
00245
00246 Procedure TZIBEventAlerter.RegisterEvents;
00247 Var i: Integer;
00248 Begin
00249 If (not (csDesigning in ComponentState)) and (Assigned(FConnection)) Then Begin
00250 Try
00251 If (FThreads.Count = 0) Then Begin
00252 If (FEvents.Count > 0) Then Begin
00253 For i := 0 To ((FEvents.Count - 1) div IB_MAX_EVENT_BLOCK) Do
00254 FThreads.Add(TIBEventThread.Create(Self, i, ThreadEnded));
00255 End;
00256 End;
00257 Finally
00258 FRegistered := FThreads.Count <> 0;
00259 If FRegistered Then Begin
00260 If not FConnection.Connected Then
00261 FConnection.Connect;
00262 FNativeHandle := GetNativeHandle;
00263 End;
00264 End;
00265 End;
00266 End;
00267
00268
00269
00270
00271
00272
00273 Procedure TZIBEventAlerter.SetConnection(Value: TZConnection);
00274 Var
00275 WasRegistered: boolean;
00276 Begin
00277 If (Value <> FConnection) Then Begin
00278 If (csDesigning in ComponentState) Then
00279 FConnection := Value
00280 Else Begin
00281 WasRegistered := Registered;
00282 If WasRegistered Then
00283 UnRegisterEvents;
00284 FConnection := Value;
00285 If WasRegistered Then
00286 RegisterEvents;
00287 End;
00288 End;
00289 End;
00290
00291
00292 procedure TZIBEventAlerter.SetEvents(Value: TStrings);
00293 begin
00294 FEvents.Assign(Value);
00295 end;
00296
00297 procedure TZIBEventAlerter.SetRegistered(const Value: boolean);
00298 begin
00299 FRegistered := Value;
00300 if csDesigning in ComponentState then
00301 exit;
00302 if Value then
00303 RegisterEvents
00304 else
00305 UnRegisterEvents;
00306 end;
00307
00308 procedure TZIBEventAlerter.UnregisterEvents;
00309 var
00310 i: integer;
00311 Temp: TIBEventThread;
00312 begin
00313 if csDesigning in ComponentState then
00314 exit;
00315 if (FThreads.Count > 0) then
00316 begin
00317 for i := (FThreads.Count - 1) downto 0 do
00318 begin
00319 Temp := TIBEventThread(FThreads[i]);
00320 FThreads.Delete(i);
00321
00322 Temp.SignalTerminate;
00323 Temp.WaitFor;
00324 Temp.Free;
00325 end;
00326 end;
00327 FRegistered := FThreads.Count <> 0;
00328 end;
00329
00330 function TZIBEventAlerter.GetPlainDriver: IZInterbasePlainDriver;
00331 begin
00332 Result := (FConnection.DbcConnection as IZInterbase6Connection).GetPlainDriver;
00333 end;
00334
00335 { TIBEventThread }
00336
00337 procedure EventCallback(P: Pointer; Length: Short; Updated: PChar); cdecl;
00338 begin
00339 if (Assigned(P) and Assigned(Updated)) then
00340 begin
00341 TIBEventThread(P).UpdateResultBuffer(Length, Updated);
00342 TIBEventThread(P).SignalEvent;
00343 end;
00344 end;
00345
00346 procedure TIBEventThread.DoEvent;
00347 begin
00348 Parent.FOnEventAlert(Parent, Parent.FEvents[((EventGroup * IB_MAX_EVENT_BLOCK) + WhichEvent)],
00349 StatusVectorArray[WhichEvent], FCancelAlerts)
00350 end;
00351
00352 procedure TIBEventThread.UpdateResultBuffer(Length: UShort; Updated: PChar);
00353 begin
00354 Move(Updated[0], ResultBuffer[0], Length);
00355 end;
00356
00357 procedure TIBEventThread.QueueEvents;
00358 begin
00359 EventsReceived := False;
00360 Signal.ResetEvent;
00361 Synchronize(SQueEvents);
00362 end;
00363
00364 procedure TIBEventThread.ProcessEvents;
00365 var
00366 i: integer;
00367 begin
00368 Parent.PlainDriver.isc_event_counts(StatusVector, EventBufferLen,
00369 EventBuffer, ResultBuffer);
00370 if (Assigned(Parent.FOnEventAlert) and (not FirstTime)) then
00371 begin
00372 FCancelAlerts := False;
00373 for i := 0 to (EventCount - 1) do
00374 begin
00375 if (StatusVectorArray[i] <> 0) then
00376 begin
00377 WhichEvent := i;
00378 Synchronize(DoEvent)
00379 end;
00380 end;
00381 end;
00382 FirstTime := False;
00383 end;
00384
00385 procedure TIBEventThread.UnRegisterEvents;
00386 begin
00387 Parent.PlainDriver.isc_cancel_events(StatusVector, Parent.FNativeHandle, @EventID);
00388 Parent.PlainDriver.isc_free(EventBuffer);
00389 EventBuffer := nil;
00390 Parent.PlainDriver.isc_free(ResultBuffer);
00391 ResultBuffer := nil;
00392 end;
00393
00394 procedure TIBEventThread.RegisterEvents;
00395 var sib_event_block: Tsib_event_block;
00396
00397 function EBP(Index: integer): PChar;
00398 begin
00399 Inc(Index, (EventGroup * IB_MAX_EVENT_BLOCK));
00400 if (Index > Parent.FEvents.Count) then
00401 Result := nil
00402 else
00403 Result := PChar(Parent.FEvents[Index -1]);
00404 end;
00405 begin
00406 EventBuffer := nil;
00407 ResultBuffer := nil;
00408 EventBufferLen := 0;
00409 FirstTime := True;
00410 EventCount := (Parent.FEvents.Count - (EventGroup * IB_MAX_EVENT_BLOCK));
00411 if (EventCount > IB_MAX_EVENT_BLOCK) then
00412 EventCount := IB_MAX_EVENT_BLOCK;
00413
00414 if Parent.Connection.Protocol='interbase-5' then
00415 sib_event_block := Tsib_event_block(ZPlainInterbase5.isc_event_block)
00416 else if Parent.Connection.Protocol='interbase-6' then
00417 sib_event_block := Tsib_event_block(ZPlainInterbase6.isc_event_block)
00418 else if Parent.Connection.Protocol='firebird-1.0' then
00419 sib_event_block := Tsib_event_block(ZPlainFirebird10.isc_event_block)
00420 else if Parent.Connection.Protocol='firebird-1.5' then
00421 sib_event_block := Tsib_event_block(ZPlainFirebird15.isc_event_block)
00422 else if Parent.Connection.Protocol='firebirdd-1.5' then
00423 sib_event_block := Tsib_event_block(ZPlainFirebird15.isc_event_block)
00424 else if Parent.Connection.Protocol='firebird-2.0' then
00425 sib_event_block := Tsib_event_block(ZPlainFirebird20.isc_event_block)
00426 else if Parent.Connection.Protocol='firebirdd-2.0' then
00427 sib_event_block := Tsib_event_block(ZPlainFirebird20.isc_event_block)
00428 else
00429 sib_event_block := Tsib_event_block(ZPlainInterbase6.isc_event_block);
00430
00431 EventBufferLen := sib_event_block(@EventBuffer,
00432 @ResultBuffer, EventCount,
00433 EBP(1), EBP(2), EBP(3), EBP(4), EBP(5), EBP(6), EBP(7), EBP(8),
00434 EBP(9), EBP(10), EBP(11), EBP(12), EBP(13), EBP(14), EBP(15));
00435
00436 end;
00437
00438 procedure TIBEventThread.SignalEvent;
00439 begin
00440 EventsReceived := True;
00441 Signal.SetEvent;
00442 end;
00443
00444 procedure TIBEventThread.SignalTerminate;
00445 begin
00446 if not Terminated then
00447 begin
00448 Terminate;
00449 Signal.SetEvent;
00450 end;
00451 end;
00452
00453 procedure TIBEventThread.DoHandleException;
00454 begin
00455 SysUtils.ShowException(FExceptObject, FExceptAddr);
00456 end;
00457
00458 function TIBEventThread.HandleException: boolean;
00459 begin
00460 if not Parent.ThreadException then
00461 begin
00462 Result := True;
00463 Parent.ThreadException := True;
00464 FExceptObject := ExceptObject;
00465 FExceptAddr := ExceptAddr;
00466 try
00467 if not (FExceptObject is EAbort) then
00468 Synchronize(DoHandleException);
00469 finally
00470 FExceptObject := nil;
00471 FExceptAddr := nil;
00472 end;
00473 end
00474 else
00475 Result := False;
00476 end;
00477
00478 procedure TIBEventThread.Execute;
00479 begin
00480 RegisterEvents;
00481 QueueEvents;
00482 try
00483 repeat
00484 Signal.WaitFor(INFINITE);
00485 if EventsReceived then
00486 begin
00487 ProcessEvents;
00488 QueueEvents;
00489 end;
00490 until Terminated;
00491 ReturnValue := 0;
00492 except
00493 if HandleException then
00494 ReturnValue := 1
00495 else
00496 ReturnValue := 0;
00497 end;
00498 end;
00499
00500 constructor TIBEventThread.Create(Owner: TZIBEventAlerter;
00501 EventGrp: integer; TermEvent: TNotifyEvent);
00502 begin
00503 inherited Create(True);
00504 FCancelAlerts := False;
00505 Signal := TSimpleEvent.Create;
00506 Parent := Owner;
00507 EventGroup := EventGrp;
00508 OnTerminate := TermEvent;
00509 Resume;
00510 end;
00511
00512 destructor TIBEventThread.Destroy;
00513 begin
00514 try
00515 UnRegisterEvents;
00516 except
00517 if HandleException then
00518 ReturnValue := 1
00519 else
00520 ReturnValue := 0;
00521 end;
00522 Signal.Free;
00523 inherited Destroy;
00524 end;
00525
00526 procedure TZIBEventAlerter.EventChange(Sender: TObject);
00527 var
00528 i: integer;
00529 WasRegistered: boolean;
00530 ErrorStr: string;
00531 begin
00532 ErrorStr := EmptyStr;
00533 WasRegistered := Registered;
00534 try
00535 if WasRegistered then
00536 UnRegisterEvents;
00537 TStringList(FEvents).OnChange := nil;
00538 try
00539 for i := (FEvents.Count - 1) downto 0 do
00540 begin
00541 if (FEvents[i] = EmptyStr) then
00542 begin
00543 FEvents.Delete(i);
00544 end
00545 else if (Length(FEvents[i]) > (IB_MAX_EVENT_LENGTH - 1)) then
00546 begin
00547 FEvents[i] := Copy(FEvents[i], 1, (IB_MAX_EVENT_LENGTH - 1));
00548 end;
00549 end;
00550 finally
00551 TStringList(FEvents).OnChange := EventChange;
00552 end;
00553 finally
00554 if WasRegistered then
00555 RegisterEvents;
00556 end;
00557 end;
00558
00559 function TZIBEventAlerter.GetRegistered: boolean;
00560 begin
00561 Result := FRegistered;
00562 end;
00563
00564 procedure TZIBEventAlerter.ThreadEnded(Sender: TObject);
00565 var
00566 ThreadIdx: integer;
00567 begin
00568 if (Sender is TIBEventThread) then
00569 begin
00570 ThreadIdx := FThreads.IndexOf(Sender);
00571 if (ThreadIdx > -1) then
00572 FThreads.Delete(ThreadIdx);
00573 if (TIBEventThread(Sender).ReturnValue = 1) then
00574 begin
00575 if Registered then
00576 UnRegisterEvents;
00577 ThreadException := False;
00578 end
00579 end;
00580 end;
00581
00582 procedure TZIBEventAlerter.SetAutoRegister(const Value: boolean);
00583 begin
00584 if FAutoRegister <> Value then
00585 begin
00586 FAutoRegister := Value;
00587 if FAutoRegister and (not Registered) and
00588 Assigned(FConnection) and FConnection.Connected then
00589 RegisterEvents;
00590 end;
00591 end;
00592
00593 function TZIBEventAlerter.GetAutoRegister: boolean;
00594 begin
00595 Result := FAutoRegister;
00596 end;
00597
00598 procedure TIBEventThread.SQueEvents;
00599 var Status: ISC_STATUS;
00600 begin
00601 try
00602 Status:=Parent.PlainDriver.isc_que_events(StatusVector, Parent.FNativeHandle,
00603 @EventID, EventBufferLen, EventBuffer, TISC_CALLBACK(@EventCallback),
00604 PVoid(Self));
00605 except
00606 on E: Exception do
00607 if Assigned(Parent.OnError) then
00608 if E is EZSQLException then
00609 Parent.OnError(Parent, EZSQLException(E).ErrorCode)
00610 else
00611 Parent.OnError(Parent, 0);
00612 end;
00613 end;
00614
00615 end.
00616