--- Merging r40063 into '.':

U    packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp
--- Recording mergeinfo for merge of r40063 into '.':
 U   .
--- Merging r40240 into '.':
U    packages/fcl-db/tests/testsqldb.pas
U    packages/fcl-db/src/sqldb/sqldb.pp
--- Recording mergeinfo for merge of r40240 into '.':
 G   .
--- Merging r40396 into '.':
U    packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp
--- Recording mergeinfo for merge of r40396 into '.':
 G   .
--- Merging r40607 into '.':
G    packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp
--- Recording mergeinfo for merge of r40607 into '.':
 G   .
--- Merging r40610 into '.':
A    packages/fcl-db/examples/myext.pp
A    packages/fcl-db/examples/sqlite3extdemo.pp
--- Recording mergeinfo for merge of r40610 into '.':
 G   .

# revisions: 40063,40240,40396,40607,40610

git-svn-id: branches/fixes_3_2@40713 -

.gitattributes

@@ -2023,8 +2023,10 @@ packages/fcl-db/examples/loadlibdemo.lpi svneol=native#text/plain
 packages/fcl-db/examples/loadlibdemo.pp svneol=native#text/plain
 packages/fcl-db/examples/logsqldemo.lpi svneol=native#text/plain
 packages/fcl-db/examples/logsqldemo.pas svneol=native#text/plain
+packages/fcl-db/examples/myext.pp svneol=native#text/plain
 packages/fcl-db/examples/pqeventstest.pp svneol=native#text/plain
 packages/fcl-db/examples/showcsv.pp svneol=native#text/plain
+packages/fcl-db/examples/sqlite3extdemo.pp svneol=native#text/plain
 packages/fcl-db/examples/sqlite3loadlib.lpr svneol=native#text/plain
 packages/fcl-db/examples/sqlparser.pp svneol=native#text/plain
 packages/fcl-db/examples/tsamytable.pp svneol=native#text/plain

packages/fcl-db/examples/myext.pp

@@ -0,0 +1,49 @@
+library myext;
+
+{$mode objfpc}{$h+}
+
+uses
+  sysutils,
+  ctypes,
+  sqlite3,
+  sqlite3ext;
+
+procedure mysum(ctx: psqlite3_context; n: cint; v: ppsqlite3_value); cdecl;
+var
+  a, b, r: cint;
+begin
+  a := sqlite3_value_int(v[0]);
+  b := sqlite3_value_int(v[1]);
+  r := a + b;
+  sqlite3_result_int(ctx, r);
+end;
+
+procedure myconcat(ctx: psqlite3_context; n: cint; v: ppsqlite3_value); cdecl;
+var
+  a, b, r: ansistring;
+begin
+  a := sqlite3_value_text(v[0]);
+  b := sqlite3_value_text(v[1]);
+  r := a + b;
+  sqlite3_result_text(ctx, @r[1], length(r), nil);
+end;
+
+function sqlite3_extension_init(db: Psqlite3; pzErrMsg: Ppcchar;
+  const pApi: Psqlite3_api_routines): cint; cdecl; export;
+var
+  rc: cint;
+begin
+  SQLITE_EXTENSION_INIT2(pApi);
+  rc := sqlite3_create_function(db, 'mysum', 2, SQLITE_UTF8, nil,
+    @mysum, nil, nil);
+  if rc = SQLITE_OK then
+    Result := sqlite3_create_function(db, 'myconcat', 2, SQLITE_UTF8, nil,
+      @myconcat, nil, nil);
+  Result := rc;
+end;
+
+exports
+  sqlite3_extension_init;
+
+begin
+end.

packages/fcl-db/examples/sqlite3extdemo.pp

@@ -0,0 +1,40 @@
+program test;
+
+{$mode objfpc}{$H+}
+
+uses
+  sysutils,
+  sqlite3conn,
+  sqlite3ext,
+  sqldb;
+
+const
+  SharedPrefix = {$ifdef mswindows}''{$else}'lib'{$endif};
+
+var
+  con: TSQLite3Connection;
+  trans: TSQLTransaction;
+  q: TSQLQuery;
+begin
+  con := TSQLite3Connection.Create(nil);
+  trans := TSQLTransaction.Create(con);
+  q := TSQLQuery.Create(con);
+  try
+    trans.DataBase := con;
+    q.DataBase := con;
+    q.Transaction := trans;
+    con.DatabaseName := 'test.sqlite3';
+    con.Open;
+    con.LoadExtension(ExtractFilePath(ParamStr(0)) +
+      SharedPrefix + 'myext.' + SharedSuffix);
+    q.SQL.Text := 'SELECT mysum(2, 3);';
+    q.Open;
+    WriteLn('MYSUM: ', q.Fields[0].AsInteger); // prints "MYSUM: 5"
+    q.Close;
+    q.SQL.Text := 'SELECT myconcat(''abc'', ''123'');';
+    q.Open;
+    WriteLn('MYCONCAT: ', q.Fields[0].AsString); // prints "MYCONCAT: abc123"
+  finally
+    con.Free;
+  end;
+end.

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

@@ -47,6 +47,8 @@ uses
 type
   TEventAlert = procedure(Sender: TObject; EventName: string; EventCount: longint;
     var CancelAlerts: boolean) of object;
+  TEventAlertPayload = procedure(Sender: TObject; EventName, PayLoad: string; EventCount: longint;
+    var CancelAlerts: boolean) of object;
   TErrorEvent = procedure(Sender: TObject; ErrorCode: integer) of object;
 
 { TPQEventMonitor }
@@ -59,6 +61,7 @@ type
     FEvents: TStrings;
     FOnError: TErrorEvent;
     FOnEventAlert: TEventAlert;
+    FOnEventAlertPayLoad: TEventAlertPayload;
     FRegistered: Boolean;
     function GetNativeHandle: pointer;
     procedure SetConnection(AValue: TPQConnection);
@@ -77,6 +80,7 @@ type
     property Events: TStrings read FEvents write SetEvents;
     property Registered: Boolean read FRegistered write SetRegistered;
     property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
+    property OnEventAlertPayload: TEventAlertPayload read FOnEventAlertPayload write FOnEventAlertPayload;
     property OnError: TErrorEvent read FOnError write FOnError;
   end;
 
@@ -165,6 +169,8 @@ begin
         begin
         if assigned(OnEventAlert) then
           OnEventAlert(Self,notify^.relname,1,CancelAlerts);
+        if assigned(OnEventAlertPayLoad) then
+          OnEventAlertPayLoad(Self,notify^.relname,Notify^.Extra,1,CancelAlerts);
         PQfreemem(notify);
         end;
     until not assigned(notify) or CancelAlerts;

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

@@ -1518,9 +1518,10 @@ end;
 
 function TSQLConnection.GetStatementInfo(const ASQL: string): TSQLStatementInfo;
 
-type TParsePart = (ppStart,ppWith,ppSelect,ppTableName,ppFrom,ppWhere,ppGroup,ppOrder,ppBogus);
-     TPhraseSeparator = (sepNone, sepWhiteSpace, sepComma, sepComment, sepParentheses, sepDoubleQuote, sepEnd);
-     TKeyword = (kwWITH, kwSELECT, kwINSERT, kwUPDATE, kwDELETE, kwFROM, kwJOIN, kwWHERE, kwGROUP, kwORDER, kwUNION, kwROWS, kwLIMIT, kwUnknown);
+type
+  TParsePart = (ppStart,ppWith,ppSelect,ppTableName,ppFrom,ppWhere,ppGroup,ppOrder,ppBogus);
+  TPhraseSeparator = (sepNone, sepWhiteSpace, sepComma, sepComment, sepParentheses, sepDoubleQuote, sepEnd);
+  TKeyword = (kwWITH, kwSELECT, kwINSERT, kwUPDATE, kwDELETE, kwFROM, kwJOIN, kwWHERE, kwGROUP, kwORDER, kwUNION, kwROWS, kwLIMIT, kwUnknown);
 
 const
   KeywordNames: array[TKeyword] of string =
@@ -1536,7 +1537,7 @@ var
   Keyword, K              : TKeyword;
 
 begin
-  PSQL:=Pchar(ASQL);
+  PSQL:=PChar(ASQL);
   ParsePart := ppStart;
 
   CurrentP := PSQL-1;
@@ -1548,7 +1549,6 @@ begin
   Result.WhereStopPos := 0;
 
   repeat
-    begin
     inc(CurrentP);
     SavedP := CurrentP;
 
@@ -1582,12 +1582,12 @@ begin
           Separator := sepNone;
     end;
 
-    if (CurrentP > SavedP) and (SavedP > PhraseP) then
-      CurrentP := SavedP;  // there is something before comment or left parenthesis
-
     if Separator <> sepNone then
       begin
-      if ((Separator in [sepWhitespace,sepComment]) and (PhraseP = SavedP)) then
+      if (CurrentP > SavedP) and (SavedP > PhraseP) then
+        CurrentP := SavedP;  // there is something before comment or left parenthesis or double quote
+
+      if (Separator in [sepWhitespace,sepComment]) and (SavedP = PhraseP) then
         PhraseP := CurrentP;  // skip comments (but not parentheses) and white spaces
 
       if (CurrentP-PhraseP > 0) or (Separator = sepEnd) then
@@ -1633,10 +1633,12 @@ begin
                      //  and/or derived tables are also not updateable
                      if Separator in [sepWhitespace, sepComment, sepDoubleQuote, sepEnd] then
                        begin
-                       Result.TableName := s;
+                       Result.TableName := Result.TableName + s;
                        Result.Updateable := True;
                        end;
-                     ParsePart := ppFrom;
+                     // compound delimited classifier like: "schema name"."table name"
+                     if not (CurrentP^ in ['.','"']) then
+                       ParsePart := ppFrom;
                      end;
           ppFrom   : begin
                      if (Keyword in [kwWHERE, kwGROUP, kwORDER, kwLIMIT, kwROWS]) or
@@ -1683,7 +1685,6 @@ begin
         dec(CurrentP);
       PhraseP := CurrentP+1;
       end
-    end;
   until CurrentP^=#0;
 end;
 

packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp

@@ -43,12 +43,34 @@ type
  
   TArrayStringArray = Array of TStringArray;
   PArrayStringArray = ^TArrayStringArray;
- 
-  { TSQLite3Connection }
 
+  // VFS not supported at this time.
+  // Do not change the order. See NativeFlags constant in GetSQLiteOpenFlags.
+
+  TSQLiteOpenFlag = (
+    sofReadOnly,
+    sofReadWrite,
+    sofCreate,
+    sofNoMutex,
+    sofFullMutex,
+    sofSharedCache,
+    sofPrivateCache,
+    sofURI,
+    sofMemory
+  );
+  TSQLiteOpenFlags = set of TSQLiteOpenFlag;
+
+Const
+  DefaultOpenFlags = [sofReadWrite,sofCreate];
+
+  { TSQLite3Connection }
+Type
   TSQLite3Connection = class(TSQLConnection)
   private
     fhandle: psqlite3;
+    FOpenFlags: TSQLiteOpenFlags;
+    function GetSQLiteOpenFlags: Integer;
+    procedure SetOpenFlags(AValue: TSQLiteOpenFlags);
   protected
     procedure DoInternalConnect; override;
     procedure DoInternalDisconnect; override;
@@ -97,7 +119,9 @@ type
     // Warning: UTF8CompareCallback needs a wide string manager on Linux such as cwstring
     // Warning: CollationName has to be a UTF-8 string
     procedure CreateCollation(const CollationName: string; eTextRep: integer; Arg: Pointer=nil; Compare: xCompare=nil);
-    procedure LoadExtension(LibraryFile: string);
+    procedure LoadExtension(const LibraryFile: string);
+  Published
+    Property OpenFlags : TSQLiteOpenFlags Read FOpenFlags Write SetOpenFlags default DefaultOpenFlags;
   end;
 
   { TSQLite3ConnectionDef }
@@ -274,6 +298,7 @@ begin
   inherited Create(AOwner);
   FConnOptions := [sqEscapeRepeat, sqEscapeSlash, sqImplicitTransaction, sqLastInsertID];
   FieldNameQuoteChars:=DoubleQuotes;
+  FOpenFlags:=DefaultOpenFlags;
 end;
 
 procedure TSQLite3Connection.LoadBlobIntoBuffer(FieldDef: TFieldDef; ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction);
@@ -766,6 +791,38 @@ begin
   execsql('BEGIN');
 end;
 
+function TSQLite3Connection.GetSQLiteOpenFlags: Integer;
+
+Const
+  NativeFlags : Array[TSQLiteOpenFlag] of Integer = (
+    SQLITE_OPEN_READONLY,
+    SQLITE_OPEN_READWRITE,
+    SQLITE_OPEN_CREATE,
+    SQLITE_OPEN_NOMUTEX,
+    SQLITE_OPEN_FULLMUTEX,
+    SQLITE_OPEN_SHAREDCACHE,
+    SQLITE_OPEN_PRIVATECACHE,
+    SQLITE_OPEN_URI,
+    SQLITE_OPEN_MEMORY
+  );
+Var
+  F : TSQLiteOpenFlag;
+
+begin
+  Result:=0;
+  For F in TSQLiteOpenFlags do
+    if F in FOpenFlags then
+      Result:=Result or NativeFlags[F];
+end;
+
+
+procedure TSQLite3Connection.SetOpenFlags(AValue: TSQLiteOpenFlags);
+begin
+  if FOpenFlags=AValue then Exit;
+  CheckDisConnected;
+  FOpenFlags:=AValue;
+end;
+
 procedure TSQLite3Connection.DoInternalConnect;
 var
   filename: ansistring;
@@ -775,7 +832,7 @@ begin
     DatabaseError(SErrNoDatabaseName,self);
   InitializeSQLite;
   filename := DatabaseName;
-  checkerror(sqlite3_open(PAnsiChar(filename),@fhandle));
+  checkerror(sqlite3_open_v2(PAnsiChar(filename),@fhandle,GetSQLiteOpenFlags,Nil));
   if (Length(Password)>0) and assigned(sqlite3_key) then
     checkerror(sqlite3_key(fhandle,PChar(Password),StrLen(PChar(Password))));
   if Params.IndexOfName('foreign_keys') <> -1 then
@@ -1050,7 +1107,7 @@ begin
   CheckError(sqlite3_create_collation(fhandle, PChar(CollationName), eTextRep, Arg, Compare));
 end;
 
-procedure TSQLite3Connection.LoadExtension(LibraryFile: string);
+procedure TSQLite3Connection.LoadExtension(const LibraryFile: string);
 var
   LoadResult: integer;
 begin

packages/fcl-db/tests/testsqldb.pas

@@ -72,6 +72,7 @@ type
     procedure TestUseImplicitTransaction;
     procedure TestUseExplicitTransaction;
     procedure TestExplicitConnect;
+    procedure TestGetStatementInfo;
   end;
 
   { TTestTSQLScript }
@@ -838,6 +839,39 @@ begin
   AssertException('toExplicitStart raises exception on implicit start',EDatabaseError,@TryOpen)
 end;
 
+procedure TTestTSQLConnection.TestGetStatementInfo;
+var StmtInfo: TSQLStatementInfo;
+begin
+  // single table
+  StmtInfo := SQLDBConnector.Connection.GetStatementInfo('SELECT * FROM tab1');
+  AssertEquals('StatementType', ord(stSELECT), ord(StmtInfo.StatementType));
+  AssertEquals('TableName', 'tab1', StmtInfo.TableName);
+  AssertEquals('Updateable', True, StmtInfo.Updateable);
+  StmtInfo := SQLDBConnector.Connection.GetStatementInfo('SELECT * FROM tab2 WHERE col1=1');
+  AssertEquals('TableName', 'tab2', StmtInfo.TableName);
+  AssertEquals('Updateable', True, StmtInfo.Updateable);
+  // single table with schema
+  StmtInfo := SQLDBConnector.Connection.GetStatementInfo('SELECT * FROM dbo.tab2 WHERE col1=1');
+  AssertEquals('TableName', 'dbo.tab2', StmtInfo.TableName);
+  AssertEquals('Updateable', True, StmtInfo.Updateable);
+  // single table with quoted schema
+  StmtInfo := SQLDBConnector.Connection.GetStatementInfo('SELECT * FROM "dbo".tab2 WHERE col1=1');
+  AssertEquals('TableName', '"dbo".tab2', StmtInfo.TableName);
+  AssertEquals('Updateable', True, StmtInfo.Updateable);
+  StmtInfo := SQLDBConnector.Connection.GetStatementInfo('SELECT * FROM "dbo"."tab2" WHERE col1=1');
+  AssertEquals('TableName', '"dbo"."tab2"', StmtInfo.TableName);
+  AssertEquals('Updateable', True, StmtInfo.Updateable);
+  // multiple tables
+  StmtInfo := SQLDBConnector.Connection.GetStatementInfo('SELECT * FROM tab3,tab4 WHERE col1=1');
+  AssertEquals('TableName', '', StmtInfo.TableName);
+  AssertEquals('Updateable', False, StmtInfo.Updateable);
+  // function
+  StmtInfo := SQLDBConnector.Connection.GetStatementInfo('SELECT * FROM dbo.fn1(1)');
+  AssertEquals('TableName', '', StmtInfo.TableName);
+  AssertEquals('Updateable', False, StmtInfo.Updateable);
+end;
+
+
 { TTestTSQLScript }
 
 procedure TTestTSQLScript.TestExecuteScript;