paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 21:19:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r32831 into '.':

Browse Source 
U    packages/fcl-db/fpmake.pp
U    packages/fcl-db/src/datadict/fpddregstd.pp
A    packages/fcl-db/src/datadict/fpddmssql.pp
U    packages/fcl-db/src/datadict/buildd.lpi
--- Recording mergeinfo for merge of r32831 into '.':
 U   .
--- Merging r32843 into '.':
G    packages/fcl-db/fpmake.pp
--- Recording mergeinfo for merge of r32843 into '.':
 G   .
--- Merging r32851 into '.':
U    packages/fcl-db/src/datadict/fpddsqldb.pp
U    packages/fcl-db/src/datadict/fpddmssql.pp
--- Recording mergeinfo for merge of r32851 into '.':
 G   .
--- Merging r32853 into '.':
U    packages/fcl-db/src/base/bufdataset.pas
--- Recording mergeinfo for merge of r32853 into '.':
 G   .
--- Merging r32854 into '.':
U    packages/fcl-db/tests/testdbbasics.pas
--- Recording mergeinfo for merge of r32854 into '.':
 G   .

# revisions: 32831,32843,32851,32853,32854,3293

git-svn-id: branches/fixes_3_0@33370 -
This commit is contained in:
marco 2016-03-28 15:00:58 +00:00
parent 7e72560c33
commit c76c86e598
8 changed files with 381 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -2091,6 +2091,7 @@ packages/fcl-db/src/datadict/fpdatadict.pp svneol=native#text/plain
packages/fcl-db/src/datadict/fpdddbf.pp svneol=native#text/plain
packages/fcl-db/src/datadict/fpdddiff.pp svneol=native#text/plain
packages/fcl-db/src/datadict/fpddfb.pp svneol=native#text/plain
packages/fcl-db/src/datadict/fpddmssql.pp svneol=native#text/plain
packages/fcl-db/src/datadict/fpddmysql40.pp svneol=native#text/plain
packages/fcl-db/src/datadict/fpddmysql41.pp svneol=native#text/plain
packages/fcl-db/src/datadict/fpddmysql50.pp svneol=native#text/plain

11
packages/fcl-db/fpmake.pp
View File

@ -464,7 +464,15 @@ begin
AddUnit('fpddsqldb');
AddUnit('pqconnection');
end;
T:=P.Targets.AddUnit('fpddregstd.pp', DatadictOSes-SqldbWithoutOracleOSes);
T:=P.Targets.AddUnit('fpddmssql.pp', DatadictOSes*MSSQLOSes);
with T.Dependencies do
begin
AddUnit('sqldb');
AddUnit('fpdatadict');
AddUnit('fpddsqldb');
AddUnit('mssqlconn');
end;
T:=P.Targets.AddUnit('fpddregstd.pp', (DatadictOSes*MSSQLOses)-SqldbWithoutOracleOSes);
with T.Dependencies do
begin
AddUnit('fpdatadict');
@ -476,6 +484,7 @@ begin
AddUnit('fpddmysql40');
AddUnit('fpddmysql41');
AddUnit('fpddmysql50');
AddUnit('fpddmssql');
AddUnit('fpddodbc');
end;
T:=P.Targets.AddUnit('customsqliteds.pas', SqliteOSes);

18
packages/fcl-db/src/base/bufdataset.pas
View File

@ -1249,17 +1249,15 @@ begin
if Fields.Count = 0 then
DatabaseError(SErrNoDataset);
// search for autoinc field
// If there is a field with FieldNo=0 then the fields are not found to the
// FieldDefs which is a sign that there is no dataset created. (Calculated and
// lookup fields have FieldNo=-1)
FAutoIncField:=nil;
if FAutoIncValue>-1 then
begin
for i := 0 to Fields.Count-1 do
if Fields[i] is TAutoIncField then
begin
FAutoIncField := TAutoIncField(Fields[i]);
Break;
end;
end;
for i := 0 to Fields.Count-1 do
if Fields[i].FieldNo=0 then
DatabaseError(SErrNoDataset)
else if (FAutoIncValue>-1) and (Fields[i] is TAutoIncField) and not assigned(FAutoIncField) then
FAutoIncField := TAutoIncField(Fields[i]);
InitDefaultIndexes;
CalcRecordSize;

41
packages/fcl-db/src/datadict/buildd.lpi
View File

@ -1,17 +1,20 @@
<?xml version="1.0"?>
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="6"/>
<Version Value="9"/>
<General>
<Flags>
<LRSInOutputDirectory Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
@ -28,17 +31,14 @@
<Unit0>
<Filename Value="buildd.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="buildd"/>
</Unit0>
<Unit1>
<Filename Value="fpddsqldb.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddsqldb"/>
</Unit1>
<Unit2>
<Filename Value="fpdatadict.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpdatadict"/>
</Unit2>
<Unit3>
<Filename Value="fpdddbf.pp"/>
@ -48,65 +48,54 @@
<Unit4>
<Filename Value="fpddfb.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddfb"/>
</Unit4>
<Unit5>
<Filename Value="fpddmysql40.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddmysql40"/>
</Unit5>
<Unit6>
<Filename Value="fpddmysql41.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddmysql41"/>
</Unit6>
<Unit7>
<Filename Value="fpddmysql50.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddmysql50"/>
</Unit7>
<Unit8>
<Filename Value="fpddpq.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddpq"/>
</Unit8>
<Unit9>
<Filename Value="fpddodbc.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddodbc"/>
</Unit9>
<Unit10>
<Filename Value="fpddoracle.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddoracle"/>
</Unit10>
<Unit11>
<Filename Value="fpddsqlite3.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddsqlite3"/>
</Unit11>
<Unit12>
<Filename Value="fpddregstd.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddregstd"/>
</Unit12>
<Unit13>
<Filename Value="fpdddiff.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpdddiff"/>
</Unit13>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<Version Value="11"/>
<SearchPaths>
<UnitOutputDirectory Value="../../units/$(TARGETCPU)-$(TARGETOS)"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
</CompilerOptions>
</CONFIG>

304
packages/fcl-db/src/datadict/fpddmssql.pp Normal file
View File

@ -0,0 +1,304 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2007 by Michael Van Canneyt, member of the
Free Pascal development team
MS-SQL Server Data Dictionary Engine Implementation.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
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.
**********************************************************************}
unit fpddmssql;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, sqldb, fpdatadict, fpddsqldb, db;
Type
{ TFPDDMSSQLEngine }
TFPDDMSSQLEngine = Class(TFPDDSQLEngine)
Public
Function CreateDomainSQL(Domain : TDDDomainDef) : String; override;
end;
{ TSQLDBMSSQLDDEngine }
TSQLDBMSSQLDDEngine = Class(TSQLDBDDEngine)
Protected
Function CreateConnection(AConnectString : String) : TSQLConnection; override;
Public
Function ImportIndexes(Table : TDDTableDef) : Integer; override;
Function ImportSequences(Sequences : TDDSequenceDefs; List : TStrings; UpdateExisting : boolean) : Integer; override;
Function ImportDomains(Domains : TDDDomainDefs; List : TStrings; UpdateExisting : boolean) : Integer; override;
Function CreateSQLEngine : TFPDDSQLEngine; override;
Class function EngineCapabilities : TFPDDEngineCapabilities; override;
Class function Description : string; override;
Class function DBType : String; override;
end;
Procedure RegisterMSSQLDDEngine;
Procedure UnRegisterMSSQLDDEngine;
implementation
uses mssqlconn;
Procedure RegisterMSSQLDDEngine;
begin
RegisterDictionaryEngine(TSQLDBMSSQLDDEngine);
end;
Procedure UnRegisterMSSQLDDEngine;
begin
UnRegisterDictionaryEngine(TSQLDBMSSQLDDEngine);
end;
{ TSQLDBMSSQLDDEngine }
function TSQLDBMSSQLDDEngine.CreateConnection(AConnectString: String
): TSQLConnection;
begin
Result:=TMSSQLConnection.Create(Self);
end;
class function TSQLDBMSSQLDDEngine.EngineCapabilities: TFPDDEngineCapabilities;
begin
Result:=[ecImport, ecCreateTable, ecViewTable, ecTableIndexes,
ecRunQuery, ecRowsAffected, ecSequences, ecDomains];
end;
class function TSQLDBMSSQLDDEngine.Description: string;
begin
Result:='Microsoft SQL Server connection using SQLDB';
end;
class function TSQLDBMSSQLDDEngine.DBType: String;
begin
Result:='Microsoft SQL Server';
end;
function TSQLDBMSSQLDDEngine.ImportIndexes(Table: TDDTableDef): Integer;
const
SQL_Indexes = 'SELECT '+
' t.name AS TableName, '+
' ind.name AS IndexName, '+
' ind.index_id AS IndexId, '+
' ic.index_column_id AS ColumnId, '+
' col.name AS ColumnName, '+
' ind.is_unique AS IsUniqueIndex, '+
' ind.is_unique_constraint AS IsConstraint '+
'FROM '+
' sys.indexes ind ' +
' INNER JOIN sys.index_columns ic ON ind.object_id = ic.object_id and ind.index_id = ic.index_id '+
' INNER JOIN sys.columns col ON ic.object_id = col.object_id and ic.column_id = col.column_id '+
' INNER JOIN sys.tables t ON ind.object_id = t.object_id '+
'WHERE '+
' t.name=:TableName '+
'ORDER BY '+
' t.name, ind.name, ind.index_id, ic.index_column_id ';
Var
Q : TSQLQuery;
FIndexName, FFieldName, FUnique, FConstraint : TField;
procedure BindIndexFields;
begin
FIndexName := Q.FieldByName ('IndexName');
FFieldName := Q.FieldbyName('ColumnName');
FUnique := Q.FieldByName('IsUniqueIndex');
FConstraint := Q.FieldByName('IsConstraint');
end;
function CreateIndex (AName, indexname: string) : TDDIndexDef;
var n, s : string;
begin
n := trim(AName);
if n = '' then
n := trim(indexname);
if trim (indexName) = '' then
indexname := AName;
result := Table.Indexes.AddIndex(n);
if FUnique.AsInteger<>0 then
result.Options:=[ixUnique];
end;
Var
FN,IndName : String;
IDD : TDDIndexDef;
begin
FN:='';
IndName:='';
IDD:=Nil;
Q:=CreateSQLQuery(Nil);
Q.SQL.text := SQL_Indexes;
Q.Params[0].AsString:=Table.TableName;
Q.Open;
try
BindIndexFields;
while not Q.Eof do
begin
if IndName<>FIndexName.AsString then
begin
if (IDD<>Nil) then
IDD.Fields:=FN;
IndName:=FIndexName.AsString;
IDD:=CreateIndex('',IndName);
FN:='';
end;
if FN<>'' then
FN:=FN+';';
FN:=FN+Trim(FFieldName.AsString);
Q.Next;
end;
if (IDD<>Nil) then
IDD.Fields:=FN;
finally
Q.Free;
end;
end;
function TSQLDBMSSQLDDEngine.ImportSequences(Sequences: TDDSequenceDefs;
List: TStrings; UpdateExisting: boolean): Integer;
const
SQL_Sequences = 'SELECT SEQUENCE_NAME, START_VALUE, INCREMENT FROM INFORMATION_SCHEMA.SEQUENCES';
Var
Q : TSQLQuery;
Seq : TDDSequenceDef;
n : string;
begin
result := 0;
Q:=CreateSQLQuery(Nil);
try
Q.Sql.Text := SQL_Sequences;
Q.Open;
try
while not Q.eof do
begin
n := trim(Q.Fields[0].AsString);
seq := Sequences.FindSequence(n);
if not assigned (Seq) then
Seq := Sequences.AddSequence(n)
else if not UpdateExisting then
Seq := nil;
if assigned (Seq) then
begin
Seq.StartValue := Round(Q.Fields[1].AsFloat);
Seq.Increment := Round(Q.Fields[2].AsFloat);
inc (result);
end;
Q.Next;
end;
finally
Q.CLose;
end;
finally
Q.Free;
end;
end;
function TSQLDBMSSQLDDEngine.ImportDomains(Domains: TDDDomainDefs;
List: TStrings; UpdateExisting: boolean): Integer;
const
SQL_Domains = 'SELECT * FROM INFORMATION_SCHEMA.DOMAINS';
Var
Q : TSQLQuery;
FName, FDomainName, FDomainDefault,
FCharLength, FPrecision, FScale, FDataType : TField;
procedure BindFields;
begin
FName := Q.fieldbyname('DOMAIN_NAME');
FDomainDefault := q.fieldbyname('DOMAIN_DEFAULT');
FCharLength := q.fieldbyname('CHARACTER_MAXIMUM_LENGTH');
FPrecision := q.fieldbyname('NUMERIC_PRECISION');
FScale := q.fieldbyname('NUMERIC_SCALE');
FDataType := q.fieldbyname('DATA_TYPE');
end;
function ImportDomain : boolean;
var Dom : TDDDomainDef;
n : string;
begin
n := trim(FName.AsString);
Dom := Domains.FindDomain(n);
if not assigned (Dom) then
Dom := Domains.AddDomain(n)
else if not UpdateExisting then
Dom := nil;
if assigned (Dom) then
begin
result := true;
Dom.FieldType := SQLDataTypeToFieldType(FDataType.AsString);
Dom.Precision := FPrecision.AsInteger;
if Dom.FieldType in [ftFloat, ftBcd, ftFmtBCD] then
Dom.Size := FScale.AsInteger
else if Dom.FieldType in [ftString, ftFixedChar] then
Dom.Size := FCharLength.AsInteger
else
Dom.Size := 0;
end
else
result := false;
end;
begin
result := 0;
Q:=CreateSQLQuery(Nil);
try
Q.Sql.Text := SQL_Domains;
Q.Open;
BindFields;
try
while not Q.eof do
begin
if ImportDomain then
inc (result);
Q.Next;
end;
finally
Q.CLose;
end;
finally
Q.Free;
end;
end;
function TSQLDBMSSQLDDEngine.CreateSQLEngine: TFPDDSQLEngine;
begin
Result:=TFPDDMSSQLEngine.Create;
end;
{ TFPDDMSSQLEngine }
function TFPDDMSSQLEngine.CreateDomainSQL(Domain: TDDDomainDef): String;
begin
Result:='CREATE TYPE '+Domain.DomainName+' FROM '+FieldTypeString(Domain.FieldType,Domain.Size,Domain.Precision);
if Domain.Required then
Result:=Result+' NOT NULL';
end;
end.

11
packages/fcl-db/src/datadict/fpddregstd.pp
View File

@ -36,12 +36,12 @@ uses
Type
TDataDictEngine = (teDBF,teFirebird,teOracle,teMySQL40,teMySQL41,teMySQL50,
tePostgreSQL,teSQLite3,teODBC);
tePostgreSQL,teSQLite3,teODBC, teMSSQL);
TDataDictEngines = set of TDataDictEngine;
Const
AllStdDDEngines = [teDBF,teFirebird,teOracle,teMySQL40,teMySQL41,teMySQL50,
tePostgreSQL,teSQLite3,teODBC];
tePostgreSQL,teSQLite3,teODBC,teMSSQL];
Type
@ -78,6 +78,7 @@ uses
fpddmysql40,
fpddmysql41,
fpddmysql50,
fpddmssql,
fpddodbc;
Const
@ -86,19 +87,19 @@ Const
= (TDBFDDEngine, TSQLDBFBDDEngine, TSQLDBOracleDDEngine,
TSQLDBMySql40DDEngine, TSQLDBMySql41DDEngine ,
TSQLDBMySql5DDEngine, TSQLDBPostGreSQLDDEngine,
TSQLDBSQLite3DDEngine,TSQLDBODBCDDEngine);
TSQLDBSQLite3DDEngine,TSQLDBODBCDDEngine, TSQLDBMSSQLDDEngine);
StdEngineRegs : Array [TDataDictEngine] of procedure
= (@InitDBFImporter, @RegisterFBDDEngine, @RegisterOracleDDEngine,
@RegisterMySQL40DDEngine, @RegisterMySQL41DDEngine,
@RegisterMySQL50DDEngine, @RegisterPostgreSQLDDengine,
@RegisterSQLite3DDEngine, @RegisterODBCDDengine);
@RegisterSQLite3DDEngine, @RegisterODBCDDengine,@RegisterMSSQLDDEngine);
StdEngineUnRegs : Array [TDataDictEngine] of procedure
= (@DoneDBFImporter, @UnRegisterFBDDEngine, @UnRegisterOracleDDEngine,
@UnRegisterMySQL40DDEngine, @UnRegisterMySQL41DDEngine,
@UnRegisterMySQL50DDEngine, @UnRegisterPostgreSQLDDengine,
@UnRegisterSQLite3DDEngine, @UnRegisterODBCDDengine);
@UnRegisterSQLite3DDEngine, @UnRegisterODBCDDengine,@UnRegisterMSSQLDDEngine);
function RegisterStdDDEngines(Engines: TDataDictEngines): TDataDictEngines;

28
packages/fcl-db/src/datadict/fpddsqldb.pp
View File

@ -30,6 +30,7 @@ Type
Private
FConn: TSQLConnection;
Protected
Function SQLDataTypeToFieldType(const SQLDataType: string) : TFieldType; virtual;
Function CreateConnection(AConnectString : String) : TSQLConnection; virtual; abstract;
Function CreateSQLQuery(ADatasetOwner: TComponent) : TSQLQuery;
Property Connection : TSQLConnection Read FConn;
@ -74,6 +75,25 @@ begin
Result:=True;
end;
function TSQLDBDDEngine.SQLDataTypeToFieldType(const SQLDataType: string
): TFieldType;
begin
// ANSI standard types
case SQLDataType of
'char' : Result := ftFixedChar;
'varchar' : Result := ftString;
'smallint': Result := ftSmallint;
'int',
'integer' : Result := ftInteger;
'bigint' : Result := ftLargeInt;
'float' : Result := ftFloat;
'date' : Result := ftDate;
'time' : Result := ftTime;
'datetime': Result := ftDateTime;
else Result := ftUnknown;
end;
end;
function TSQLDBDDEngine.CreateSQLQuery(ADatasetOwner: TComponent): TSQLQuery;
begin
Result:=TSQLQuery.Create(ADatasetOwner);
@ -124,7 +144,7 @@ end;
function TSQLDBDDEngine.ImportFields(Table: TDDTableDef): Integer;
Const
SQL = 'SELECT * from %s where (1=0)';
SQL = 'SELECT * FROM %s WHERE (1=0)';
Var
Q : TSQLQuery;
@ -145,7 +165,7 @@ begin
end;
Function TSQLDBDDEngine.ImportIndexes(Table : TDDTableDef) : Integer;
function TSQLDBDDEngine.ImportIndexes(Table: TDDTableDef): Integer;
begin
end;
@ -209,7 +229,7 @@ begin
Try
Q.Database:=FConn;
Q.Transaction:=FConn.Transaction;
Q.SQL.text:=Format('SELECT * FROM %s WHERE (1=2)',[ATAbleName]);
Q.SQL.text:=Format('SELECT * FROM %s WHERE (1=2)',[ATableName]);
Q.ReadOnly:=False;
Q.Prepare;
Q.IndexDefs.Update;
@ -222,7 +242,7 @@ end;
class function TSQLDBDDEngine.EngineCapabilities: TFPDDEngineCapabilities;
begin
Result:=[ecimport,ecViewTable, ecRunQuery, ecTableIndexes];
Result:=[ecImport, ecViewTable, ecRunQuery, ecTableIndexes];
end;
end.

27
packages/fcl-db/tests/testdbbasics.pas
View File

@ -58,7 +58,6 @@ type
procedure TestAssignFieldftFixedChar;
procedure TestSelectQueryBasics;
procedure TestPostOnlyInEditState;
procedure TestCancel;
procedure TestMove; // bug 5048
procedure TestActiveBufferWhenClosed;
procedure TestEOFBOFClosedDataset;
@ -118,7 +117,6 @@ type
procedure TestIndexEditRecord;
procedure TestIndexAppendRecord;
end;
{$endif fpc}
TTestUniDirectionalDBBasics = class(TTestDBBasics)
@ -132,6 +130,7 @@ type
procedure FTestDelete1(TestCancelUpdate : boolean);
procedure FTestDelete2(TestCancelUpdate : boolean);
published
procedure TestCancel;
procedure TestCancelUpdDelete1;
procedure TestCancelUpdDelete2;
@ -276,18 +275,6 @@ begin
end;
end;
procedure TTestDBBasics.TestCancel;
begin
with DBConnector.GetNDataset(1) do
begin
Open;
Edit;
FieldByName('name').AsString := 'EditName1';
Cancel;
CheckEquals('TestName1', FieldByName('name').AsString, 'Cancel did not restored previous value');
end;
end;
procedure TTestDBBasics.TestMove;
var i,count : integer;
aDatasource : TDataSource;
@ -1305,6 +1292,18 @@ begin
{$endif fpc}
end;
procedure TTestCursorDBBasics.TestCancel;
begin
with DBConnector.GetNDataset(1) do
begin
Open;
Edit;
FieldByName('name').AsString := 'EditName1';
Cancel;
CheckEquals('TestName1', FieldByName('name').AsString, 'Cancel did not restored previous value');
end;
end;
procedure TTestCursorDBBasics.TestOnFilterProc(DataSet: TDataSet; var Accept: Boolean);
begin
Accept := odd(Dataset.FieldByName('ID').AsInteger);