* Add PostGres Event notification component from Ludo Brands (22060)

git-svn-id: trunk@21324 -

.gitattributes

@@ -1880,6 +1880,7 @@ packages/fcl-db/Makefile.fpc svneol=native#text/plain
 packages/fcl-db/Makefile.fpc.fpcmake svneol=native#text/plain
 packages/fcl-db/examples/fbadmindemo.pp svneol=native#text/plain
 packages/fcl-db/examples/fbeventstest.pp svneol=native#text/plain
+packages/fcl-db/examples/pqeventstest.pp svneol=native#text/plain
 packages/fcl-db/fpmake.pp svneol=native#text/plain
 packages/fcl-db/src/Dataset.txt svneol=native#text/plain
 packages/fcl-db/src/README.txt svneol=native#text/plain
@@ -2059,6 +2060,7 @@ packages/fcl-db/src/sqldb/postgres/Makefile.fpc svneol=native#text/plain
 packages/fcl-db/src/sqldb/postgres/fpmake.inc svneol=native#text/plain
 packages/fcl-db/src/sqldb/postgres/fpmake.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/postgres/pqconnection.pp svneol=native#text/plain
+packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/sqldb.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/sqlite/Makefile svneol=native#text/plain
 packages/fcl-db/src/sqldb/sqlite/Makefile.fpc svneol=native#text/plain

packages/fcl-db/examples/pqeventstest.pp

@@ -0,0 +1,114 @@
+program PQEventsTest;
+
+{$mode delphi}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  Classes,sysutils,
+  PQEventMonitor,pqconnection,sqldb;
+
+const
+  MAXEVENTS=35;
+  NUMTESTS=100;
+
+type
+
+  { TMyEventAlert }
+
+  TMyEventAlert=class
+    class procedure OnPQEvent(Sender: TObject; EventName: string; EventCount: longint;
+      var CancelAlerts: boolean);
+  end;
+
+var
+  EvSent,EvReceived:Array [1..MAXEVENTS] of integer;
+  TotalRecieved:integer;
+
+function testNEvents(PQConnection:TPQConnection;n:integer):boolean;
+var
+  EventsM:TPQEventMonitor;
+  i,j,k:integer;
+begin
+  for i:=1 to MAXEVENTS do
+    begin
+    EvSent[i]:=0;
+    EvReceived[i]:=0;
+    end;
+  EventsM:=TPQEventMonitor.create(nil);
+  EventsM.Connection:=PQConnection;
+  for i:=1 to n do
+    EventsM.Events.Add('E'+IntToStr(i));
+  EventsM.OnEventAlert:=TMyEventAlert.OnPQEvent;
+  EventsM.RegisterEvents;
+  i:=NUMTESTS;
+  TotalRecieved:=0;
+  Randomize;
+  while i>0 do
+    begin
+    k:=1+random(n);
+    PQConnection.ExecuteDirect('NOTIFY E'+IntTostr(k));
+    PQConnection.Transaction.Commit;
+    EvSent[k]:=EvSent[k]+1;
+    EventsM.Poll;
+    i:=i-1;
+    end;
+  for i:=1 to 300 do  //3 secs max
+    begin
+    Sleep(10); //wait until everything received
+    EventsM.Poll;
+    if TotalRecieved=NUMTESTS then
+      break;
+    end;
+  result:=true;
+  for i:=1 to n do
+    begin
+    result:=result and (EvSent[i]=EvReceived[i]);
+    end;
+  EventsM.Free;
+end;
+
+{ TMyEventAlert }
+
+class procedure TMyEventAlert.OnPQEvent(Sender: TObject; EventName: string;
+  EventCount: longint; var CancelAlerts: boolean);
+var i:integer;
+begin
+  i:=StrToInt(copy(EventName,2,2));
+  EvReceived[i]:=EvReceived[i]+EventCount;
+  TotalRecieved:=TotalRecieved+EventCount;
+end;
+
+var
+  PQConnection1:TPQConnection;
+  SQLTransaction1: TSQLTransaction;
+  i:integer;
+
+begin
+  if paramcount<4 then
+    begin
+    WriteLn('Usage:');
+    WriteLn('  '+Paramstr(0) +' database hostname username password');
+    exit;
+    end;
+  PQConnection1:=TPQConnection.Create(nil);
+  SQLTransaction1:= TSQLTransaction.Create(nil);
+  PQConnection1.Transaction:=SQLTransaction1;
+  SQLTransaction1.DataBase:=PQConnection1;
+  PQConnection1.Password:=paramstr(4);
+  PQConnection1.UserName:=paramstr(3);
+  PQConnection1.HostName:=paramstr(2);
+  PQConnection1.DatabaseName:=paramstr(1);
+  for i:=1 to 16 do
+    begin
+    if testNEvents(PQConnection1,i) then
+      WriteLn(inttostr(i)+' succeeded')
+    else
+      WriteLn(inttostr(i)+' failed. Missed '+ IntToStr(NUMTESTS-TotalRecieved)+' Events');
+    end;
+  SQLTransaction1.Free;
+  PQConnection1.Free;
+  WriteLn('Tests finished.');
+end.
+

packages/fcl-db/fpmake.pp

@@ -662,6 +662,16 @@ begin
           AddUnit('dbconst');
           AddUnit('bufdataset');
         end;
+    T:=P.Targets.AddUnit('pqeventmonitor.pp', SqldbConnectionOSes-SqldbWithoutPostgresOSes);
+    T.ResourceStrings:=true;
+      with T.Dependencies do
+        begin
+          AddUnit('sqldb');
+          AddUnit('db');
+          AddUnit('dbconst');
+          AddUnit('bufdataset');
+          AddUnit('pqconnection');
+        end;
     T:=P.Targets.AddUnit('mssqlconn.pp', MSSQLOSes);
     with T.Dependencies do
       begin

packages/fcl-db/src/sqldb/postgres/Makefile.fpc

@@ -7,7 +7,7 @@ main=fcl-db
 
 [target]
 rsts=pqconnection
-units=pqconnection
+units=pqconnection pqeventmonitor
 
 [require]
 packages=fcl-xml postgres

packages/fcl-db/src/sqldb/postgres/fpmake.inc

@@ -9,3 +9,5 @@ Targets.DefaultDir:='db/sqldb/postgres';
 Targets.DefaultOS:=[win32,openbsd,netbsd,freebsd,darwin,linux,haiku];
 T:=Targets.AddUnit('pqconnection');
 T.ResourceStrings:=True;
+T:=Targets.AddUnit('pqeventmonitor');
+T.Dependencies.Add('pqconnection');

packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp

@@ -0,0 +1,251 @@
+unit PQEventMonitor;
+
+{ PostGresql notification monitor
+
+  Copyright (C) 2012 Ludo Brands
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version with the following modification:
+
+  As a special exception, the copyright holders of this library give you
+  permission to link this library with independent modules to produce an
+  executable, regardless of the license terms of these independent modules,and
+  to copy and distribute the resulting executable under terms of your choice,
+  provided that you also meet, for each linked independent module, the terms
+  and conditions of the license of that module. An independent module is a
+  module which is not derived from or based on this library. If you modify
+  this library, you may extend this exception to your version of the library,
+  but you are not obligated to do so. If you do not wish to do so, delete this
+  exception statement from your version.
+
+  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. See the GNU Library General Public License
+  for more details.
+
+  You should have received a copy of the GNU Library 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.
+}
+
+{$mode objfpc}{$H+}
+{$Define LinkDynamically}
+
+interface
+
+uses
+  Classes, SysUtils,pqconnection,db,dbconst,
+{$IfDef LinkDynamically}
+  postgres3dyn;
+{$Else}
+  postgres3;
+{$EndIf}
+
+
+type
+  TEventAlert = procedure(Sender: TObject; EventName: string; EventCount: longint;
+    var CancelAlerts: boolean) of object;
+  TErrorEvent = procedure(Sender: TObject; ErrorCode: integer) of object;
+
+{ TPQEventMonitor }
+
+  TPQEventMonitor=class (TComponent)
+  private
+    FConnection: TPQConnection;
+    FDBHandle: PPGconn;
+    FErrorMsg: string;
+    FEvents: TStrings;
+    FOnError: TErrorEvent;
+    FOnEventAlert: TEventAlert;
+    FRegistered: Boolean;
+    function GetNativeHandle: pointer;
+    procedure SetConnection(AValue: TPQConnection);
+    procedure SetEvents(AValue: TStrings);
+    procedure SetRegistered(AValue: Boolean);
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Poll;
+    procedure RegisterEvents; virtual;
+    procedure UnRegisterEvents; virtual;
+    property ErrorMsg:string read FErrorMsg;
+    property NativeHandle: pointer read GetNativeHandle;
+  published
+    property Connection: TPQConnection read FConnection write SetConnection;
+    property Events: TStrings read FEvents write SetEvents;
+    property Registered: Boolean read FRegistered write SetRegistered;
+    property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
+    property OnError: TErrorEvent read FOnError write FOnError;
+  end;
+
+
+implementation
+
+ResourceString
+  SErrConnectionFailed = 'Connection to database failed';
+  SErrExecuteFailed = 'Execution of query failed';
+
+{ TPQEventMonitor }
+
+function TPQEventMonitor.GetNativeHandle: pointer;
+begin
+  result:=FDBHandle;
+end;
+
+
+procedure TPQEventMonitor.SetConnection(AValue: TPQConnection);
+begin
+  if FConnection=AValue then Exit;
+  If not (csDesigning in ComponentState) and FRegistered then
+    begin
+    if assigned(FConnection) then
+      FConnection.RemoveFreeNotification(self); // remove us from the old connection
+    UnRegisterEvents;
+    FConnection:=AValue;
+    if assigned(FConnection) then
+      begin
+      RegisterEvents;
+      end;
+    end
+  else
+    FConnection:=AValue;
+  if assigned(FConnection) then
+    FConnection.FreeNotification(Self); //in case Connection is destroyed before we are
+end;
+
+procedure TPQEventMonitor.SetEvents(AValue: TStrings);
+begin
+  FEvents.Assign(AValue);
+end;
+
+procedure TPQEventMonitor.SetRegistered(AValue: Boolean);
+begin
+  FRegistered := AValue;
+  if not (csDesigning in ComponentState) then
+    if AValue then
+      RegisterEvents
+    else
+      UnRegisterEvents;
+end;
+
+constructor TPQEventMonitor.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FEvents:=TStringList.Create;
+  {$IfDef LinkDynamically}
+  InitialisePostgres3;             // stick to library in case connection closes before us
+  {$EndIf}
+end;
+
+destructor TPQEventMonitor.Destroy;
+begin
+  if FRegistered then
+    UnRegisterEvents;
+  if assigned(FConnection) then
+    FConnection.RemoveFreeNotification(self);
+  FEvents.Free;
+  {$IfDef LinkDynamically}
+  ReleasePostgres3;
+  {$EndIf}
+  inherited Destroy;
+end;
+
+procedure TPQEventMonitor.Poll;
+var
+  notify:PpgNotify;
+  CancelAlerts:boolean;
+begin
+  if FConnection.Connected and FRegistered and (PQconsumeInput(FDBHandle)=1) then
+    begin
+    CancelAlerts:=false;
+    repeat
+      notify:=PQnotifies(FDBHandle);
+      if assigned(notify) then
+        begin
+        if assigned(OnEventAlert) then
+          OnEventAlert(Self,notify^.relname,1,CancelAlerts);
+        PQfreemem(notify);
+        end;
+    until not assigned(notify) or CancelAlerts;
+    if CancelAlerts then
+      UnRegisterEvents;
+    end;
+end;
+
+procedure TPQEventMonitor.RegisterEvents;
+var
+  i:Integer;
+  sConn: String;
+  res: PPGresult;
+  msg:string;
+  notify:PpgNotify;
+  CancelAlerts:boolean;
+begin
+  If not assigned(FConnection) then
+    DatabaseError(SErrNoDatabaseAvailable,Self);
+  if not(csDesigning in ComponentState) and not FRegistered and (Events.Count>0) then
+    begin
+    sConn := '';
+    if (FConnection.UserName <> '') then sConn := sConn + ' user=''' + FConnection.UserName + '''';
+    if (FConnection.Password <> '') then sConn := sConn + ' password=''' + FConnection.Password + '''';
+    if (FConnection.HostName <> '') then sConn := sConn + ' host=''' + FConnection.HostName + '''';
+    if (FConnection.DatabaseName <> '') then sConn := sConn + ' dbname=''' + FConnection.DatabaseName + '''';
+    if (FConnection.Params.Text <> '') then sConn := sConn + ' '+FConnection.Params.Text;
+
+    FDBHandle := PQconnectdb(pchar(sConn));
+    if (PQstatus(FDBHandle) <> CONNECTION_OK) then
+      begin
+      msg := PQerrorMessage(FDBHandle);
+      PQFinish(FDBHandle);
+      DatabaseError(sErrConnectionFailed + ' (TPQEventMonitor: ' + Msg + ')',self);
+      end;
+    for i:=0 to Events.Count-1 do
+      begin
+      res := PQexec(FDBHandle,pchar('LISTEN '+ Events[i]));
+      if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
+        begin
+        msg := PQerrorMessage(FDBHandle);
+        PQclear(res);
+        PQFinish(FDBHandle);
+        FDBHandle:=nil;
+        DatabaseError(SErrExecuteFailed + ' (TPQEventMonitor: ' + Msg + ')',self);
+        end
+      else
+        PQclear(res);
+      end;
+    FRegistered :=true;
+    end;
+end;
+
+procedure TPQEventMonitor.UnRegisterEvents;
+var
+  i: Integer;
+  res: PPGresult;
+  msg:string;
+begin
+  if not (csDesigning in ComponentState) and FRegistered then
+    begin
+    for i:=0 to Events.Count-1 do
+      begin
+      res := PQexec(FDBHandle,pchar('unlisten '+ Events[i]));
+      if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
+        begin
+        msg := PQerrorMessage(FDBHandle);
+        PQclear(res);
+        PQFinish(FDBHandle);
+        FDBHandle:=nil;
+        DatabaseError(SErrExecuteFailed + ' (TPQEventMonitor: ' + Msg + ')',self);
+        end
+      else
+        PQclear(res);
+      end;
+    PQFinish(FDBHandle);
+    FDBHandle:=nil;
+    FRegistered :=false;
+    end;
+end;
+
+end.
+