From 4873692ce545109f2d616fb3bf5243d5a66b257a Mon Sep 17 00:00:00 2001 From: marco Date: Mon, 31 Dec 2018 11:16:38 +0000 Subject: [PATCH] --- 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 | 2 + packages/fcl-db/examples/myext.pp | 49 ++++++++++++++ packages/fcl-db/examples/sqlite3extdemo.pp | 40 +++++++++++ .../src/sqldb/postgres/pqeventmonitor.pp | 6 ++ packages/fcl-db/src/sqldb/sqldb.pp | 25 +++---- .../fcl-db/src/sqldb/sqlite/sqlite3conn.pp | 67 +++++++++++++++++-- packages/fcl-db/tests/testsqldb.pas | 34 ++++++++++ 7 files changed, 206 insertions(+), 17 deletions(-) create mode 100644 packages/fcl-db/examples/myext.pp create mode 100644 packages/fcl-db/examples/sqlite3extdemo.pp diff --git a/.gitattributes b/.gitattributes index b162e85fc4..e15835b3a5 100644 --- a/.gitattributes +++ b/.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 diff --git a/packages/fcl-db/examples/myext.pp b/packages/fcl-db/examples/myext.pp new file mode 100644 index 0000000000..7a5bc97e5e --- /dev/null +++ b/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. diff --git a/packages/fcl-db/examples/sqlite3extdemo.pp b/packages/fcl-db/examples/sqlite3extdemo.pp new file mode 100644 index 0000000000..93869fd14f --- /dev/null +++ b/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. diff --git a/packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp b/packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp index a1f85ce683..b911222caf 100644 --- a/packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp +++ b/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; diff --git a/packages/fcl-db/src/sqldb/sqldb.pp b/packages/fcl-db/src/sqldb/sqldb.pp index a8165c0856..d0b3f2bb51 100644 --- a/packages/fcl-db/src/sqldb/sqldb.pp +++ b/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; diff --git a/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp b/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp index 8831e8a1a2..83cb07d43c 100644 --- a/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp +++ b/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 diff --git a/packages/fcl-db/tests/testsqldb.pas b/packages/fcl-db/tests/testsqldb.pas index 1f13f4a83e..003fd53a8d 100644 --- a/packages/fcl-db/tests/testsqldb.pas +++ b/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;