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

--- Merging r31146 into '.':

Browse Source 
U    packages/fcl-db/tests/testspecifictbufdataset.pas
U    packages/fcl-db/src/sqldb/sqldb.pp
U    packages/fcl-db/src/base/bufdataset.pas
--- Recording mergeinfo for merge of r31146 into '.':
 U   .
--- Merging r31153 into '.':
U    packages/odbc/src/odbcsql.inc
--- Recording mergeinfo for merge of r31153 into '.':
 G   .
--- Merging r31154 into '.':
A    packages/fcl-db/examples/createsql.pas
A    packages/fcl-db/examples/createsql.lpi
--- Recording mergeinfo for merge of r31154 into '.':
 G   .
--- Merging r31155 into '.':
U    packages/fcl-db/src/base/dsparams.inc
U    packages/fcl-db/tests/testbasics.pas
--- Recording mergeinfo for merge of r31155 into '.':
 G   .
--- Merging r31156 into '.':
U    packages/fcl-db/src/base/dbconst.pas
--- Recording mergeinfo for merge of r31156 into '.':
 G   .
--- Merging r31157 into '.':
G    packages/fcl-db/src/sqldb/sqldb.pp
--- Recording mergeinfo for merge of r31157 into '.':
 G   .
--- Merging r31158 into '.':
U    packages/fcl-db/src/sqldb/mssql/mssqlconn.pp
U    packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp
U    packages/fcl-db/src/sqldb/mysql/mysqlconn.inc
U    packages/fcl-db/src/sqldb/oracle/oracleconnection.pp
U    packages/fcl-db/src/sqldb/postgres/pqconnection.pp
U    packages/fcl-db/src/sqldb/interbase/ibconnection.pp
--- Recording mergeinfo for merge of r31158 into '.':
 G   .
--- Merging r31159 into '.':
G    packages/fcl-db/src/sqldb/mssql/mssqlconn.pp
G    packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp
--- Recording mergeinfo for merge of r31159 into '.':
 G   .
--- Merging r31160 into '.':
A    packages/fcl-db/examples/logsqldemo.pas
A    packages/fcl-db/examples/logsqldemo.lpi
--- Recording mergeinfo for merge of r31160 into '.':
 G   .
--- Merging r31161 into '.':
U    packages/fcl-db/examples/logsqldemo.pas
--- Recording mergeinfo for merge of r31161 into '.':
 G   .

# revisions: 31146,31153,31154,31155,31156,31157,31158,31159,31160,31161

git-svn-id: branches/fixes_3_0@31274 -
This commit is contained in:
marco 2015-08-04 09:13:52 +00:00
parent 0f77f50a7c
commit 58b4a36869
18 changed files with 625 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -2037,12 +2037,16 @@ packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain
packages/fcl-db/Makefile svneol=native#text/plain
packages/fcl-db/Makefile.fpc svneol=native#text/plain
packages/fcl-db/Makefile.fpc.fpcmake svneol=native#text/plain
packages/fcl-db/examples/createsql.lpi svneol=native#text/plain
packages/fcl-db/examples/createsql.pas svneol=native#text/plain
packages/fcl-db/examples/dbftool.lpi svneol=native#text/plain
packages/fcl-db/examples/dbftool.lpr 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/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/pqeventstest.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

63
packages/fcl-db/examples/createsql.lpi Normal file
View File

@ -0,0 +1,63 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="Generate SQL Demo"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="createsql.pas"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

203
packages/fcl-db/examples/createsql.pas Normal file
View File

@ -0,0 +1,203 @@
program createsql;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
typinfo, Classes, SysUtils, CustApp, db, sqldb, fpdatadict,
fpddfb,fpddpq,fpddOracle,fpddsqlite3,fpddmysql40,fpddmysql41,fpddmysql50, fpddodbc,
strutils;
type
{ TGenSQLApplication }
TGenSQLApplication = class(TCustomApplication)
private
function CreateSQLEngine(AType: String): TFPDDSQLEngine;
procedure ConnectToDatabase(const AType, ADatabaseName,AUserName,APassword: String);
procedure DoConvertQuery(const S, T, KF: String; ST: TSTatementType);
protected
FConn : TSQLConnector;
FDD : TFPDataDictionary;
FENG : TFPDDSQLEngine;
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure WriteHelp(Const AMsg : string); virtual;
end;
{ TGenSQLApplication }
procedure TGenSQLApplication.ConnectToDatabase(Const AType,ADatabaseName,AUSerName,APassword : String);
begin
FConn:=TSQLConnector.Create(Self);
FConn.ConnectorType:=AType;
FConn.DatabaseName:=ADatabaseName;
FConn.UserName:=AUserName;
FConn.Password:=APassword;
FConn.Transaction:=TSQLTransaction.Create(Self);
FConn.Connected:=True;
FDD:=TFPDataDictionary.Create;
FENG:=CreateSQLEngine(AType);
end;
Function TGenSQLApplication.CreateSQLEngine(AType : String): TFPDDSQLEngine;
begin
Case lowercase(AType) of
'firebird' : Result:=TFPDDFBSQLEngine.Create;
else
Result:=TFPDDSQLEngine.Create;
end;
end;
procedure TGenSQLApplication.DoConvertQuery(Const S,T,KF : String; ST : TSTatementType);
Var
Q : TSQLQuery;
TD : TDDTableDef;
Fields,KeyFields : TFPDDFieldList;
I : Integer;
F : TDDFieldDef;
FN,SQL : String;
begin
TD:=FDD.Tables.AddTable(T);
Q:=TSQLQuery.Create(Self);
try
Q.Database:=FConn;
Q.Transaction:=FConn.Transaction;
Q.SQL.Text:=S;
Q.Open;
TD.ImportFromDataset(Q);
finally
Q.Free;
end;
if (KF<>'') then
begin
KeyFields:=TFPDDFieldList.Create(False);
For I:=1 to WordCount(KF,[',']) do
begin
FN:=ExtractWord(I,KF,[',']);
F:=TD.Fields.FieldByName(FN);
if (F=nil) then
Writeln('Warning: Field ',FN,' does not exist.')
else
KeyFields.Add(F);
end;
end;
Fields:=TFPDDFieldList.CreateFromTableDef(TD);
try
FEng.TableDef:=TD;
Case ST of
stDDL : SQL:=FEng.CreateCreateSQL(KeyFields);
stSelect : SQL:=FEng.CreateSelectSQL(Fields,KeyFields);
stInsert : SQL:=FEng.CreateInsertSQL(Fields);
stUpdate : SQL:=FEng.CreateUpdateSQL(Fields,KeyFields);
stDelete : SQL:=FEng.CreateDeleteSQL(KeyFields);
end;
Writeln(SQL);
finally
KeyFields.Free;
end;
end;
procedure TGenSQLApplication.DoRun;
var
ErrorMsg: String;
S,T,KF : String;
I : Integer;
ST : TStatementType;
begin
// quick check parameters
ErrorMsg:=CheckOptions('hc:d:s:t:y:k:u:p:', 'help connection-type: database: sql: table: type: keyfields: user: password:');
if ErrorMsg<>'' then
WriteHelp(ErrorMsg);
if HasOption('h', 'help') then
WriteHelp('');
S:=GetOptionValue('c','connection-type');
T:=GetOptionValue('d','database');
if (S='') or (t='') then
Writehelp('Need database and connectiontype');
ConnectToDatabase(S,T,GetOptionValue('u','user'),GetOptionValue('p','password'));
S:=GetOptionValue('s','sql');
T:=GetOptionValue('t','table');
if (t='') then
Writehelp('Need table name');
i:=GetEnumValue(TypeInfo(TStatementType),'st'+GetOptionValue('y','type'));
if I=-1 then
Writehelp(Format('Unknown statement type : %s',[GetOptionValue('y','type')]));
ST:=TStatementType(i);
KF:=GetOptionValue('k','keyfields');
if (KF='') and (st in [stselect, stupdate, stdelete]) then
Writehelp('Need key fields for delete, select and update');
if (S='') then
S:='SELECT * FROM '+T+' WHERE 0=1';
DoConvertQuery(S,T,KF,ST);
// stop program loop
Terminate;
end;
constructor TGenSQLApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
end;
destructor TGenSQLApplication.Destroy;
begin
FreeAndNil(FConn);
FreeAndNil(FDD);
FreeAndNil(FENG);
inherited Destroy;
end;
procedure TGenSQLApplication.WriteHelp(Const AMsg : string);
Var
S : String;
L : TStrings;
begin
if AMsg<>'' then
Writeln('Error : ',AMsg);
Writeln('Usage: ', ExeName, ' [options]');
Writeln('Where options is one or more of:');
Writeln('-h --help this help message');
Writeln('-c --connection-type=ctype Set connection type (required)' );
Writeln('-d --database=db database connection name (required)');
Writeln('-s --sql=sql SQL to execute (optional)');
Writeln('-t --table=tablename tablename to use for statement (required)');
Writeln('-y --type=stype Statement type (required) one of ddl, select, insert, update, delete)');
Writeln('-k --keyfields=fields Comma-separated list of key fields (required for delete, update, optional for select,ddl)');
Writeln('-u --user=username User name to connect to database');
Writeln('-p --password=password Password of user to connect to database with');
Writeln('Where ctype is one of : ');
L:=TStringList.Create;
try
GetConnectionList(L);
for S in L do
Writeln(' ',lowercase(S));
finally
L.Free;
end;
Halt(Ord(AMsg<>''));
end;
var
Application: TGenSQLApplication;
begin
Application:=TGenSQLApplication.Create(nil);
Application.Title:='Generate SQL Demo';
Application.Run;
Application.Free;
end.

64
packages/fcl-db/examples/logsqldemo.lpi Normal file
View File

@ -0,0 +1,64 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="Generate SQL Demo"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<CommandLineParams Value="-c firebird -d localhost:/home/firebird/timetrack.fb -u WISASOFT -p SysteemD -s 'SELECT * FROM PROJECT WHERE PJ_ID=:ID' -P ID=s:632F3D2F-055A-4DD9-852B-4050BF6A2ED9"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="logsqldemo.pas"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

200
packages/fcl-db/examples/logsqldemo.pas Normal file
View File

@ -0,0 +1,200 @@
program logsqldemo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
typinfo, Classes, SysUtils, CustApp, db, sqldb,
ibconnection, sqlite3conn, oracleconnection, mysql40conn,mysql41conn, mssqlconn,
mysql50conn, mysql55conn, mysql56conn, odbcconn, pqconnection, strutils;
type
{ TGenSQLApplication }
TGenSQLApplication = class(TCustomApplication)
procedure DoSQLLog(Sender: TSQLConnection; EventType: TDBEventType;
const Msg: String);
private
procedure ConnectToDatabase(const AType, ADatabaseName,AUserName,APassword: String);
procedure RunQuery(SQL: String; ParamValues: TStrings);
protected
FConn : TSQLConnector;
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure WriteHelp(Const AMsg : string); virtual;
end;
{ TGenSQLApplication }
procedure TGenSQLApplication.DoSQLLog(Sender: TSQLConnection;
EventType: TDBEventType; const Msg: String);
begin
Writeln(stderr,'[',EventType,'] : ',Msg);
end;
procedure TGenSQLApplication.ConnectToDatabase(const AType, ADatabaseName,
AUserName, APassword: String);
begin
FConn:=TSQLConnector.Create(Self);
FConn.ConnectorType:=AType;
FConn.DatabaseName:=ADatabaseName;
FConn.UserName:=AUserName;
FConn.Password:=APassword;
FConn.Transaction:=TSQLTransaction.Create(Self);
FConn.OnLog:=@DoSQLLog;
FConn.LogEvents:=LogAllEventsExtra;
FConn.Connected:=True;
end;
procedure TGenSQLApplication.RunQuery(SQL : String; ParamValues : TStrings);
Var
S,PT,V : String;
I : Integer;
P : TParam;
Q : TSQLQuery;
F : TField;
begin
Q:=TSQLQuery.Create(Self);
try
Q.Database:=FConn;
Q.Transaction:=FConn.Transaction;
Q.SQL.Text:=SQL;
For P in Q.Params do
begin
S:=ParamValues.Values[P.Name];
PT:=ExtractWord(1,S,[':']);
V:=ExtractWord(2,S,[':']);
Case lowercase(PT) of
's' : P.AsString:=V;
'i' : P.AsInteger:=StrToInt(V);
'i64' : P.AsLargeInt:=StrToInt64(V);
'dt' : P.AsDateTime:=StrToDateTime(V);
'd' : P.AsDateTime:=StrToDate(V);
't' : P.AsDateTime:=StrToTime(V);
'f' : P.AsFloat:=StrToFloat(V);
'c' : P.AsCurrency:=StrToCurr(V);
else
Raise Exception.CreateFmt('unknown parameter type for %s : %s (value: %s)',[P.Name,PT,V]);
end
end;
Q.Open;
I:=0;
While not Q.EOF do
begin
Inc(I);
Writeln('Record ',I,':');
For F in Q.Fields do
if F.IsNull then
writeln(F.FieldName,'=<Null>')
else
writeln(F.FieldName,'=',F.AsString);
Q.Next;
end;
finally
Q.Free;
end;
end;
procedure TGenSQLApplication.DoRun;
var
ErrorMsg: String;
S,T,KF : String;
I : Integer;
ST : TStatementType;
P : TStrings;
begin
// quick check parameters
ErrorMsg:=CheckOptions('hc:d:s:u:p:P:', 'help connection-type: database: sql: user: password: param:');
if ErrorMsg<>'' then
WriteHelp(ErrorMsg);
if HasOption('h', 'help') then
WriteHelp('');
S:=GetOptionValue('c','connection-type');
T:=GetOptionValue('d','database');
if (S='') or (t='') then
Writehelp('Need database and connectiontype');
ConnectToDatabase(S,T,GetOptionValue('u','user'),GetOptionValue('p','password'));
S:=GetOptionValue('s','sql');
P:=TStringList.Create;
try
P.AddStrings(GetOptionValues('P','param'));
RunQuery(S,P);
finally
P.Free;
end;
// stop program loop
Terminate;
end;
constructor TGenSQLApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
end;
destructor TGenSQLApplication.Destroy;
begin
FreeAndNil(FConn);
inherited Destroy;
end;
procedure TGenSQLApplication.WriteHelp(const AMsg: string);
Var
S : String;
L : TStrings;
begin
if AMsg<>'' then
Writeln('Error : ',AMsg);
Writeln('Usage: ', ExeName, ' [options]');
Writeln('Where options is one or more of:');
Writeln('-h --help this help message');
Writeln('-c --connection-type=ctype Set connection type (required)' );
Writeln('Where ctype is one of : ');
L:=TStringList.Create;
try
GetConnectionList(L);
for S in L do
Writeln(' ',lowercase(S));
finally
L.Free;
end;
Writeln('-d --database=db database connection name (required)');
Writeln('-s --sql=sql SQL to execute (required), can contain parameters');
Writeln('-u --user=username User name to connect to database');
Writeln('-p --password=password Password of user to connect to database with');
Writeln('-P --param=name=value Parameter values encoded as ptype:value');
Writeln('Where ptype is one of : ');
Writeln(' s : string');
Writeln(' dt : datetime');
Writeln(' d : date');
Writeln(' t : time');
Writeln(' i : integer');
Writeln(' i64 : int64');
Writeln(' f : float');
Writeln(' c : currency');
Halt(Ord(AMsg<>''));
end;
var
Application: TGenSQLApplication;
begin
Application:=TGenSQLApplication.Create(nil);
Application.Title:='Generate SQL Demo';
Application.Run;
Application.Free;
end.

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

@ -558,7 +558,6 @@ type
procedure SetReadOnly(AValue: Boolean); virtual;
function IsReadFromPacket : Boolean;
function getnextpacket : integer;
procedure ActiveBufferToRecord;
function GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader; virtual;
// abstracts, must be overidden by descendents
function Fetch : boolean; virtual;
@ -2553,7 +2552,8 @@ begin
FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := nil;
end;
end;
ActiveBufferToRecord;
Move(ActiveBuffer^, FCurrentIndex.CurrentBuffer^, FRecordSize);
// new data are now in current record so reorder current record if needed
for i := 1 to FIndexesCount-1 do
@ -2561,12 +2561,6 @@ begin
FIndexes[i].OrderCurrentRecord;
end;
procedure TCustomBufDataset.ActiveBufferToRecord;
begin
move(ActiveBuffer^,FCurrentIndex.CurrentBuffer^,FRecordSize);
end;
procedure TCustomBufDataset.CalcRecordSize;
var x : longint;
@ -2844,23 +2838,19 @@ function TCustomBufDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode
var bufblob : TBufBlobField;
begin
result := nil;
if Mode = bmRead then
begin
if not Field.GetData(@bufblob) then
exit;
result := TBufBlobStream.Create(Field as TBlobField, bmRead);
end
else if Mode = bmWrite then
begin
if not (State in [dsEdit, dsInsert, dsFilter, dsCalcFields]) then
DatabaseErrorFmt(SNotEditing, [Name], Self);
if Field.ReadOnly and not (State in [dsSetKey, dsFilter]) then
DatabaseErrorFmt(SReadOnlyField, [Field.DisplayName]);
result := TBufBlobStream.Create(Field as TBlobField, bmWrite);
end;
Result := nil;
case Mode of
bmRead:
if not Field.GetData(@bufblob) then Exit;
bmWrite:
begin
if not (State in [dsEdit, dsInsert, dsFilter, dsCalcFields]) then
DatabaseErrorFmt(SNotEditing, [Name], Self);
if Field.ReadOnly and not (State in [dsSetKey, dsFilter]) then
DatabaseErrorFmt(SReadOnlyField, [Field.DisplayName]);
end;
end;
Result := TBufBlobStream.Create(Field as TBlobField, Mode);
end;
procedure TCustomBufDataset.SetDatasetPacket(AReader: TDataPacketReader);

3
packages/fcl-db/src/base/dbconst.pas
View File

@ -101,7 +101,7 @@ Resourcestring
SIndexFieldMissing = 'Cannot access index field ''%s''';
SNoFieldIndexes = 'No index currently active';
SNotIndexField = 'Field ''%s'' is not indexed and cannot be modified';
SErrUnknownConnectorType = 'Unknown connector type';
SErrUnknownConnectorType = 'Unknown connector type: "%s"';
SNoIndexFieldNameGiven = 'There are no fields selected to base the index on';
SStreamNotRecognised = 'The data-stream format is not recognized';
SNoReaderClassRegistered = 'There is no TDatapacketReaderClass registered for this kind of data-stream';
@ -123,6 +123,7 @@ Resourcestring
SErrRefreshEmptyResult = 'Refresh SQL resulted in empty result set.';
SErrNoKeyFieldForRefreshClause = 'No key field found to construct refresh SQL WHERE clause';
SErrFailedToFetchReturningResult = 'Failed to fetch returning result';
SLogParamValue = 'Parameter "%s" value : "%s"';
Implementation

6
packages/fcl-db/src/base/dsparams.inc
View File

@ -235,9 +235,9 @@ begin
case p^ of
'''', '"', '`':
begin
Result := True;
// single quote, double quote or backtick delimited string
SkipQuotesString(p, p^, EscapeSlash, EscapeRepeat);
Result := True;
end;
'-': // possible start of -- comment
begin
@ -315,7 +315,7 @@ begin
p:=PChar(SQL);
BufStart:=p; // used to calculate ParamPart.Start values
repeat
SkipComments(p,EscapeSlash,EscapeRepeat);
while SkipComments(p,EscapeSlash,EscapeRepeat) do ;
case p^ of
':','?': // parameter
begin
@ -403,7 +403,7 @@ begin
Dec(NewQueryLength,p-ParamNameStart);
end;
end;
#0:Break;
#0:Break; // end of SQL
else
Inc(p);
end;

7
packages/fcl-db/src/sqldb/interbase/ibconnection.pp
View File

@ -692,8 +692,11 @@ begin
tr := aTransaction.Handle;
if assigned(AParams) and (AParams.count > 0) then
begin
buf := AParams.ParseSQL(buf,false,sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions,psInterbase,paramBinding);
if LogEvent(detActualSQL) then
Log(detActualSQL,Buf);
end;
if isc_dsql_prepare(@Status[0], @tr, @Statement, 0, @Buf[1], Dialect, nil) <> 0 then
CheckError('PrepareStatement', Status);
if assigned(AParams) and (AParams.count > 0) then
@ -836,6 +839,8 @@ var tr : pointer;
begin
tr := aTransaction.Handle;
if Assigned(APArams) and (AParams.count > 0) then SetParameters(cursor, atransaction, AParams);
if LogEvent(detParamValue) then
LogParams(AParams);
with cursor as TIBCursor do
begin
if FStatementType = stExecProcedure then

4
packages/fcl-db/src/sqldb/mssql/mssqlconn.pp
View File

@ -611,7 +611,11 @@ var c: TDBLibCursor;
begin
c:=cursor as TDBLibCursor;
if LogEvent(detParamValue) then
LogParams(AParams);
cmd := c.ReplaceParams(AParams);
if LogEvent(detActualSQL) then
Log(detActualSQL,Cmd);
Execute(cmd);
res := SUCCEED;

7
packages/fcl-db/src/sqldb/mysql/mysqlconn.inc
View File

@ -599,7 +599,12 @@ begin
// paramreplacestring kan een probleem geven bij postgres als hij niet meer gewoon $ is?
C.FStatement := stringsreplace(C.FStatement,ParamNames,ParamValues,[rfReplaceAll]);
end;
Log(detExecute, C.FStatement);
if LogEvent(detParamValue) then
LogParams(AParams);
if LogEvent(detExecute) then
Log(detExecute, C.FStatement);
if LogEvent(detActualSQL) then
Log(detActualSQL,C.FStatement);
if mysql_query(FMySQL,Pchar(C.FStatement))<>0 then
begin
if not ForcedClose then

4
packages/fcl-db/src/sqldb/oracle/oracleconnection.pp
View File

@ -599,6 +599,8 @@ var i : integer;
begin
with cursor as TOracleCursor do
begin
if LogEvent(detActualSQL) then
Log(detActualSQL,Buf);
if OCIStmtPrepare2(TOracleTrans(ATransaction.Handle).FOciSvcCtx,FOciStmt,FOciError,@buf[1],length(buf),nil,0,OCI_NTV_SYNTAX,OCI_DEFAULT) = OCI_ERROR then
HandleError;
// Get statement type
@ -830,6 +832,8 @@ procedure TOracleConnection.Execute(cursor: TSQLCursor; ATransaction: TSQLTransa
end;
begin
if Assigned(AParams) and (AParams.Count > 0) then SetParameters(cursor, ATransaction, AParams);
if LogEvent(detParamValue) then
LogParams(AParams);
if cursor.FStatementType = stSelect then
begin
if OCIStmtExecute(TOracleTrans(ATransaction.Handle).FOciSvcCtx,(cursor as TOracleCursor).FOciStmt,FOciError,0,0,nil,nil,OCI_DEFAULT) = OCI_ERROR then

4
packages/fcl-db/src/sqldb/postgres/pqconnection.pp
View File

@ -931,6 +931,8 @@ begin
s := s + ' as ' + buf;
if LogEvent(detPrepare) then
Log(detPrepare,S);
if LogEvent(detActualSQL) then
Log(detActualSQL,S);
res := PQexec(tr.PGConn,pchar(s));
CheckResultError(res,nil,SErrPrepareFailed);
// if statement is INSERT, UPDATE, DELETE with RETURNING clause, then
@ -992,6 +994,8 @@ begin
PQclear(res);
if FStatementType in [stInsert,stUpdate,stDelete,stSelect] then
begin
if LogEvent(detParamValue) then
LogParams(AParams);
if Assigned(AParams) and (AParams.Count > 0) then
begin
l:=AParams.Count;

41
packages/fcl-db/src/sqldb/sqldb.pp
View File

@ -49,7 +49,7 @@ type
TSQLScript = class;
TDBEventType = (detCustom, detPrepare, detExecute, detFetch, detCommit, detRollBack);
TDBEventType = (detCustom, detPrepare, detExecute, detFetch, detCommit, detRollBack, detParamValue, detActualSQL);
TDBEventTypes = set of TDBEventType;
TDBLogNotifyEvent = Procedure (Sender : TSQLConnection; EventType : TDBEventType; Const Msg : String) of object;
@ -116,7 +116,8 @@ type
const
SingleQuotes : TQuoteChars = ('''','''');
DoubleQuotes : TQuoteChars = ('"','"');
LogAllEvents = [detCustom, detPrepare, detExecute, detFetch, detCommit, detRollBack];
LogAllEvents = [detCustom, detPrepare, detExecute, detFetch, detCommit, detRollBack];
LogAllEventsExtra = [detCustom, detPrepare, detExecute, detFetch, detCommit, detRollBack, detParamValue,detActualSQL];
StatementTokens : Array[TStatementType] of string = ('(unknown)', 'select',
'insert', 'update', 'delete',
'create', 'get', 'put', 'execute',
@ -159,7 +160,6 @@ type
FStatements : TFPList;
FLogEvents: TDBEventTypes;
FOnLog: TDBLogNotifyEvent;
FInternalTransaction : TSQLTransaction;
function GetPort: cardinal;
procedure SetOptions(AValue: TSQLConnectionOptions);
procedure SetPort(const AValue: cardinal);
@ -191,6 +191,7 @@ type
function GetAsSQLText(Param : TParam) : string; overload; virtual;
function GetHandle : pointer; virtual;
Function LogEvent(EventType : TDBEventType) : Boolean;
Procedure LogParams(Const AParams : TParams); virtual;
Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
Procedure RegisterStatement(S : TCustomSQLStatement);
Procedure UnRegisterStatement(S : TCustomSQLStatement);
@ -1580,6 +1581,27 @@ begin
Result:=(Assigned(FOnLog) or Assigned(GlobalDBLogHook)) and (EventType in LogEvents);
end;
procedure TSQLConnection.LogParams(const AParams: TParams);
Var
S : String;
P : TParam;
begin
if not LogEvent(detParamValue) then
Exit;
For P in AParams do
begin
if P.IsNull then
S:='<NULL>'
else if (P.DataType in ftBlobTypes) and not (P.DataType in [ftMemo, ftFmtMemo,ftWideMemo]) then
S:='<BLOB>'
else
S:=P.AsString;
Log(detParamValue,Format(SLogParamValue,[P.Name,S]));
end;
end;
procedure TSQLConnection.Log(EventType: TDBEventType; const Msg: String);
Var
@ -2842,7 +2864,7 @@ end;
procedure TCustomSQLQuery.ApplyRecUpdate(UpdateKind: TUpdateKind);
Var
DoRefresh, RecordRefreshed : Boolean;
DoRefresh : Boolean;
LastIDField : TField;
S : TDataSetState;
@ -2862,17 +2884,13 @@ begin
// TDataSet buffers are resynchronized at end of ApplyUpdates process
S:=SetTempState(dsRefreshFields);
try
RecordRefreshed:=False;
if assigned(LastIDField) then
RecordRefreshed:=RefreshLastInsertID(LastIDField);
RefreshLastInsertID(LastIDField);
if DoRefresh then
RecordRefreshed:=RefreshRecord(UpdateKind) or RecordRefreshed;
RefreshRecord(UpdateKind);
finally
RestoreState(S);
end;
if RecordRefreshed then
// Active buffer is updated, move to record.
//ActiveBufferToRecord;
end;
end;
@ -3278,6 +3296,9 @@ begin
FProxy.Role:=Self.Role;
FProxy.UserName:=Self.UserName;
FProxy.FTransaction:=Self.Transaction;
FProxy.LogEvents:=Self.LogEvents;
FProxy.OnLog:=Self.OnLog;
FProxy.Options:=Self.Options;
D:=GetConnectionDef(ConnectorType);
D.ApplyParams(Params,FProxy);
FProxy.Connected:=True;

6
packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp
View File

@ -233,6 +233,8 @@ Procedure TSQLite3Cursor.Prepare(Buf : String; AParams : TParams);
begin
if assigned(AParams) and (AParams.Count > 0) then
Buf := AParams.ParseSQL(Buf,false,false,false,psInterbase,fparambinding);
if (detActualSQL in fconnection.LogEvents) then
fconnection.Log(detActualSQL,Buf);
checkerror(sqlite3_prepare(fhandle,pchar(Buf),length(Buf),@fstatement,@ftail));
FPrepared:=True;
end;
@ -530,7 +532,9 @@ begin
checkerror(sqlite3_reset(sc.fstatement));
If (AParams<>Nil) and (AParams.count > 0) then
SC.BindParams(AParams);
SC.Execute;
If LogEvent(detParamValue) then
LogParams(AParams);
SC.Execute;
end;
Function NextWord(Var S : ShortString; Sep : Char) : String;

3
packages/fcl-db/tests/testbasics.pas
View File

@ -145,6 +145,9 @@ begin
// Bracketed comment
AssertEquals( 'select * from table where id=/*comment :c*/$1-$2',
Params.ParseSQL('select * from table where id=/*comment :c*/:a-:b', True, True, True, psPostgreSQL));
// Consecutive comments, with quote in second comment
AssertEquals( '--c1'#10'--c'''#10'select '':a'' from table where id=$1',
Params.ParseSQL('--c1'#10'--c'''#10'select '':a'' from table where id=:id', True, True, True, psPostgreSQL));
Params.Free;
end;

3
packages/fcl-db/tests/testspecifictbufdataset.pas
View File

@ -13,7 +13,7 @@ interface
uses
{$IFDEF FPC}
fpcunit, testutils, testregistry, testdecorator, BufDataset,
fpcunit, testregistry, BufDataset,
{$ELSE FPC}
TestFramework,
{$ENDIF FPC}
@ -49,7 +49,6 @@ uses
//
{$endif fpc}
variants,
strutils,
FmtBCD;
{ TTestSpecificTBufDataset }

10
packages/odbc/src/odbcsql.inc
View File

@ -130,7 +130,11 @@ const
SQL_TYPE_DATE = 91;
SQL_TYPE_TIME = 92;
SQL_TYPE_TIMESTAMP= 93;
// MS SQL Server types
// Microsoft has -150 thru -199 reserved for Microsoft SQL Server Native Client driver usage.
SQL_SS_VARIANT = -150;
SQL_SS_UDT = -151;
SQL_SS_XML = -152;
SQL_SS_TABLE = -153;
SQL_SS_TIME2 = -154;
SQL_SS_TIMESTAMPOFFSET = -155;
{$endif}
@ -1780,8 +1784,8 @@ begin
Result.sign:=0;
c := -c;
end;
n := int64(c);
for i:=0 to 15 do begin
n := NtoLE(int64(c));
for i:=0 to high(Result.val) do begin
Result.val[i] := n and $ff;
n := n shr 8;
end;