fcl-db: sqldb:

- handle quoted table names when retrieving server index informations for quoted TableName
- reset updated flag of ServerIndexDefs when SQL.Text changes
- new tests unit for sqlDB
- tested for FB, MSSQL, MySQL, PostgreSQL, Sqlite, odbc_MSSQL, odbc_PostgreSQL, odbc_Firebird, odbc_MySQL

git-svn-id: trunk@24880 -

.gitattributes

@@ -2212,6 +2212,7 @@ packages/fcl-db/tests/testjsondataset.pp svneol=native#text/plain
 packages/fcl-db/tests/testleaks.sh svneol=native#text/plain
 packages/fcl-db/tests/testspecifictbufdataset.pas svneol=native#text/plain
 packages/fcl-db/tests/testspecifictdbf.pas svneol=native#text/plain
+packages/fcl-db/tests/testsqldb.pas svneol=native#text/pascal
 packages/fcl-db/tests/testsqlfiles.lpi svneol=native#text/plain
 packages/fcl-db/tests/testsqlfiles.lpr svneol=native#text/plain
 packages/fcl-db/tests/testsqlscanner.lpi svneol=native#text/plain

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

@@ -1385,6 +1385,11 @@ begin
   if not assigned(Transaction) then
     DatabaseError(SErrConnTransactionnSet);
 
+  if (length(TableName)>2) and (TableName[1]='"') and (TableName[length(TableName)]='"') then
+    TableName := AnsiDequotedStr(TableName, '"')
+  else
+    TableName := UpperCase(TableName);
+
   qry := tsqlquery.Create(nil);
   qry.transaction := Transaction;
   qry.database := Self;
@@ -1408,7 +1413,7 @@ begin
               'rel_con.rdb$index_name = ind.rdb$index_name '+
             'where '+
               '(ind_seg.rdb$index_name = ind.rdb$index_name) and '+
-              '(ind.rdb$relation_name=''' +  UpperCase(TableName) +''') '+
+              '(ind.rdb$relation_name=' + QuotedStr(TableName) + ') '+
             'order by '+
               'ind.rdb$index_name;');
     open;

packages/fcl-db/src/sqldb/odbc/odbcconn.pas

@@ -1284,6 +1284,7 @@ end;
 
 procedure TODBCConnection.UpdateIndexDefs(IndexDefs: TIndexDefs; TableName: string);
 var
+  Len: integer;
   StmtHandle:SQLHSTMT;
   Res:SQLRETURN;
   IndexDef: TIndexDef;
@@ -1299,6 +1300,13 @@ var
 const
   DEFAULT_NAME_LEN = 255;
 begin
+  Len := length(TableName);
+  if Len > 2 then
+    if (TableName[1] in ['"','`']) and (TableName[Len]  in ['"','`']) then
+      TableName := AnsiDequotedStr(TableName, TableName[1])
+    else if (TableName[1] in ['[']) and (TableName[Len] in [']']) then
+      TableName := copy(TableName, 2, Len-2);
+
   // allocate statement handle
   StmtHandle := SQL_NULL_HANDLE;
   ODBCCheckResult(

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

@@ -1041,11 +1041,17 @@ end;
 procedure TPQConnection.UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string);
 
 var qry : TSQLQuery;
+    relname : string;
 
 begin
   if not assigned(Transaction) then
     DatabaseError(SErrConnTransactionnSet);
 
+  if (length(TableName)>2) and (TableName[1]='"') and (TableName[length(TableName)]='"') then
+    relname := QuotedStr(AnsiDequotedStr(TableName, '"'))
+  else
+    relname := 'lower(' + QuotedStr(TableName) + ')';  // unquoted names are stored lower case in PostgreSQL which is incompatible with the SQL standard
+
   qry := tsqlquery.Create(nil);
   qry.transaction := Transaction;
   qry.database := Self;
@@ -1072,7 +1078,7 @@ begin
               '(ia.attrelid = i.indexrelid) and '+
               '(ic.oid = i.indexrelid) and '+
               '(ta.attnum = i.indkey[ia.attnum-1]) and '+
-              '(upper(tc.relname)=''' +  UpperCase(TableName) +''') '+
+              '(tc.relname = ' + relname + ') '+
             'order by '+
               'ic.relname;');
     open;

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

@@ -1579,8 +1579,7 @@ begin
       FreeFldBuffers;
     // Some SQLConnections does not support statement [un]preparation,
     //  so let them do cleanup f.e. cancel pending queries and/or free resultset
-    if not FStatement.Prepared then
+    if not Prepared then FStatement.DoUnprepare;
-      FStatement.DoUnprepare;
     end
   else
     begin
@@ -1893,7 +1892,8 @@ begin
   finally
     // Cursor has to be assigned, or else the prepare went wrong before PrepareStatment was
     //   called, so UnPrepareStatement shoudn't be called either
-    if (not IsPrepared) and (assigned(database)) and (assigned(Cursor)) then TSQLConnection(database).UnPrepareStatement(Cursor);
+    // Don't deallocate cursor; f.e. RowsAffected is requested later
+    if not Prepared and (assigned(Database)) and (assigned(Cursor)) then TSQLConnection(Database).UnPrepareStatement(Cursor);
   end;
 end;
 
@@ -1983,6 +1983,7 @@ begin
   inherited OnChangeSQL(Sender);
   If CheckParams and Assigned(FMasterLink) then
     FMasterLink.RefreshParamNames;
+  FQuery.ServerIndexDefs.Updated:=false;
 end;
 
 destructor TQuerySQLStatement.Destroy;

packages/fcl-db/tests/sqldbtoolsunit.pas

@@ -23,10 +23,60 @@ type
   TSQLConnType = (mysql40,mysql41,mysql50,mysql51,mysql55,postgresql,interbase,odbc,oracle,sqlite3,mssql,sybase);
   TSQLServerType = (ssFirebird, ssInterbase, ssMSSQL, ssMySQL, ssOracle, ssPostgreSQL, ssSQLite, ssSybase, ssUnknown);
 
-const MySQLConnTypes = [mysql40,mysql41,mysql50,mysql51,mysql55];
+const
+  MySQLConnTypes = [mysql40,mysql41,mysql50,mysql51,mysql55];
   SQLConnTypesNames : Array [TSQLConnType] of String[19] =
         ('MYSQL40','MYSQL41','MYSQL50','MYSQL51','MYSQL55','POSTGRESQL','INTERBASE','ODBC','ORACLE','SQLITE3','MSSQL','SYBASE');
              
+  STestNotApplicable = 'This test does not apply to this sqldb-connection type';
+
+
+type
+{ TSQLDBConnector }
+  TSQLDBConnector = class(TDBConnector)
+  private
+    FConnection    : TSQLConnection;
+    FTransaction   : TSQLTransaction;
+    FQuery         : TSQLQuery;
+    FUniDirectional: boolean;
+    procedure CreateFConnection;
+    procedure CreateFTransaction;
+    Function CreateQuery : TSQLQuery;
+  protected
+    procedure SetTestUniDirectional(const AValue: boolean); override;
+    function GetTestUniDirectional: boolean; override;
+    procedure CreateNDatasets; override;
+    procedure CreateFieldDataset; override;
+    procedure DropNDatasets; override;
+    procedure DropFieldDataset; override;
+    Function InternalGetNDataset(n : integer) : TDataset; override;
+    Function InternalGetFieldDataset : TDataSet; override;
+    procedure TryDropIfExist(ATableName : String);
+  public
+    destructor Destroy; override;
+    constructor Create; override;
+    procedure ExecuteDirect(const SQL: string);
+    procedure CommitDDL;
+    property Connection : TSQLConnection read FConnection;
+    property Transaction : TSQLTransaction read FTransaction;
+    property Query : TSQLQuery read FQuery;
+  end;
+
+var SQLConnType : TSQLConnType;
+    SQLServerType : TSQLServerType;
+    FieldtypeDefinitions : Array [TFieldType] of String[20];
+    
+implementation
+
+uses StrUtils;
+
+type
+  TSQLServerTypesMapItem = record
+    s: string;
+    t: TSQLServerType;
+  end;
+
+const
   FieldtypeDefinitionsConst : Array [TFieldType] of String[20] =
     (
       '',
@@ -71,52 +121,6 @@ const MySQLConnTypes = [mysql40,mysql41,mysql50,mysql51,mysql55];
       ''              // ftWideMemo
     );
 
-
-type
-{ TSQLDBConnector }
-  TSQLDBConnector = class(TDBConnector)
-  private
-    FConnection    : TSQLConnection;
-    FTransaction   : TSQLTransaction;
-    FQuery         : TSQLQuery;
-    FUniDirectional: boolean;
-    procedure CreateFConnection;
-    procedure CreateFTransaction;
-    Function CreateQuery : TSQLQuery;
-  protected
-    procedure SetTestUniDirectional(const AValue: boolean); override;
-    function GetTestUniDirectional: boolean; override;
-    procedure CreateNDatasets; override;
-    procedure CreateFieldDataset; override;
-    procedure DropNDatasets; override;
-    procedure DropFieldDataset; override;
-    Function InternalGetNDataset(n : integer) : TDataset; override;
-    Function InternalGetFieldDataset : TDataSet; override;
-    procedure TryDropIfExist(ATableName : String);
-  public
-    destructor Destroy; override;
-    constructor Create; override;
-    procedure CommitDDL;
-    property Connection : TSQLConnection read FConnection;
-    property Transaction : TSQLTransaction read FTransaction;
-    property Query : TSQLQuery read FQuery;
-  end;
-
-var SQLConnType : TSQLConnType;
-    SQLServerType : TSQLServerType;
-    FieldtypeDefinitions : Array [TFieldType] of String[20];
-    
-implementation
-
-uses StrUtils;
-
-type
-  TSQLServerTypesMapItem = record
-    s: string;
-    t: TSQLServerType;
-  end;
-
-const
   // names as returned by ODBC SQLGetInfo(..., SQL_DBMS_NAME, ...) and GetConnectionInfo(citServerType)
   SQLServerTypesMap : array [0..7] of TSQLServerTypesMapItem = (
     (s: 'Firebird'; t: ssFirebird),
@@ -239,7 +243,7 @@ begin
       end;
     ssPostgreSQL:
       begin
-      FieldtypeDefinitions[ftCurrency] := 'MONEY';
+      FieldtypeDefinitions[ftCurrency] := 'MONEY'; // ODBC?!
       FieldtypeDefinitions[ftBlob] := 'BYTEA';
       FieldtypeDefinitions[ftMemo] := 'TEXT';
       FieldtypeDefinitions[ftGraphic] := '';
@@ -320,7 +324,7 @@ begin
     database := Fconnection;
 end;
 
-Function TSQLDBConnector.CreateQuery : TSQLQuery;
+function TSQLDBConnector.CreateQuery: TSQLQuery;
 
 begin
   Result := TSQLQuery.create(nil);
@@ -512,6 +516,11 @@ begin
   end;
 end;
 
+procedure TSQLDBConnector.ExecuteDirect(const SQL: string);
+begin
+  Connection.ExecuteDirect(SQL);
+end;
+
 procedure TSQLDBConnector.CommitDDL;
 begin
   // Commits schema definition and manipulation statements;

packages/fcl-db/tests/testfieldtypes.pas

@@ -164,8 +164,6 @@ const
     '', #0, #0#1#2#3#4#5#6#7#8#9
   );
 
-  STestNotApplicable = 'This test does not apply to this sqldb-connection type';
-
 
 procedure TTestFieldTypes.TestpfInUpdateFlag;
 var ds   : TCustomBufDataset;

packages/fcl-db/tests/testsqldb.pas

@@ -0,0 +1,158 @@
+unit TestSQLDB;
+
+{
+  Unit tests which are specific to the sqlDB components like TSQLQuery, TSQLConnection.
+}
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit, testregistry,
+  db;
+
+type
+
+  { TTestTSQLQuery }
+
+  TTestTSQLQuery = class(TTestCase)
+  private
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  published
+    procedure TestUpdateServerIndexDefs;
+  end;
+
+  { TTestTSQLConnection }
+
+  TTestTSQLConnection = class(TTestCase)
+  private
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  published
+    procedure ReplaceMe;
+  end;
+
+
+implementation
+
+uses sqldbtoolsunit, toolsunit, sqldb;
+
+{ TTestTSQLQuery }
+
+procedure TTestTSQLQuery.TestUpdateServerIndexDefs;
+var Q: TSQLQuery;
+    name1, name2, name3: string;
+begin
+  // Test retrieval of information about indexes on unquoted and quoted table names
+  //  (tests also case-sensitivity for DB's that support case-sensitivity of quoted identifiers)
+  // For ODBC Firebird/Interbase we must define primary key as named constraint and
+  //  in ODBC driver must be set: "quoted identifiers" and "sensitive identifier"
+  // See also: TTestFieldTypes.TestUpdateIndexDefs
+  with TSQLDBConnector(DBConnector) do
+  begin
+    // SQLite ignores case-sensitivity of quoted table names
+    // MS SQL Server case-sensitivity of identifiers depends on the case-sensitivity of default collation of the database
+    // MySQL case-sensitivity depends on case-sensitivity of server's file system
+    if SQLServerType in [ssMSSQL,ssSQLite{$IFDEF WINDOWS},ssMySQL{$ENDIF}] then
+      name1 := Connection.FieldNameQuoteChars[0]+'fpdev 2'+Connection.FieldNameQuoteChars[1]
+    else
+      name1 := 'FPDEV2';
+    ExecuteDirect('create table '+name1+' (id integer not null, constraint PK_FPDEV21 primary key(id))');
+    // same but quoted table name
+    name2 := Connection.FieldNameQuoteChars[0]+'FPdev2'+Connection.FieldNameQuoteChars[1];
+    ExecuteDirect('create table '+name2+' (ID2 integer not null, constraint PK_FPDEV22 primary key(ID2))');
+    // embedded quote in table name
+    if SQLServerType in [ssMySQL] then
+      name3 := '`FPdev``2`'
+    else
+      name3 := Connection.FieldNameQuoteChars[0]+'FPdev""2'+Connection.FieldNameQuoteChars[1];
+    ExecuteDirect('create table '+name3+' (Id3 integer not null, constraint PK_FPDEV23 primary key(Id3))');
+    CommitDDL;
+  end;
+
+  try
+    Q := TSQLDBConnector(DBConnector).Query;
+    Q.SQL.Text:='select * from '+name1;
+    Q.Prepare;
+    Q.ServerIndexDefs.Update;
+    CheckEquals(1, Q.ServerIndexDefs.Count);
+
+    Q.SQL.Text:='select * from '+name2;
+    Q.Prepare;
+    Q.ServerIndexDefs.Update;
+    CheckEquals(1, Q.ServerIndexDefs.Count, '2.1');
+    CheckTrue(CompareText('ID2', Q.ServerIndexDefs[0].Fields)=0, '2.2'+Q.ServerIndexDefs[0].Fields);
+    CheckTrue(Q.ServerIndexDefs[0].Options=[ixPrimary,ixUnique], '2.3');
+
+    Q.SQL.Text:='select * from '+name3;
+    Q.Prepare;
+    Q.ServerIndexDefs.Update;
+    CheckEquals(1, Q.ServerIndexDefs.Count, '3.1');
+    CheckTrue(CompareText('ID3', Q.ServerIndexDefs[0].Fields)=0, '3.2');
+    CheckTrue(Q.ServerIndexDefs[0].Options=[ixPrimary,ixUnique], '3.3');
+  finally
+    Q.UnPrepare;
+    with TSQLDBConnector(DBConnector) do
+    begin
+      ExecuteDirect('DROP TABLE '+name1);
+      ExecuteDirect('DROP TABLE '+name2);
+      ExecuteDirect('DROP TABLE '+name3);
+      CommitDDL;
+    end;
+  end;
+end;
+
+{ TTestTSQLConnection }
+
+procedure TTestTSQLConnection.ReplaceMe;
+begin
+  // replace this procedure with any test for TSQLConnection
+end;
+
+
+procedure TTestTSQLQuery.SetUp;
+begin
+  inherited;
+  InitialiseDBConnector;
+  DBConnector.StartTest;
+end;
+
+procedure TTestTSQLConnection.SetUp;
+begin
+  inherited;
+  InitialiseDBConnector;
+  DBConnector.StartTest;
+end;
+
+procedure TTestTSQLQuery.TearDown;
+begin
+  DBConnector.StopTest;
+  if assigned(DBConnector) then
+    with TSQLDBConnector(DBConnector) do
+      Transaction.Rollback;
+  FreeDBConnector;
+  inherited;
+end;
+
+procedure TTestTSQLConnection.TearDown;
+begin
+  DBConnector.StopTest;
+  if assigned(DBConnector) then
+    with TSQLDBConnector(DBConnector) do
+      Transaction.Rollback;
+  FreeDBConnector;
+  inherited;
+end;
+
+
+initialization
+  if uppercase(dbconnectorname)='SQL' then
+  begin
+    RegisterTest(TTestTSQLQuery);
+    RegisterTest(TTestTSQLConnection);
+  end;
+end.