paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-27 23:39:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged revisions 3896,3926,3928,3943,3950-3951 via svnmerge from

Browse Source 
http://peter@svn.freepascal.org/svn/fpc/trunk

........
r3896 | joost | 2006-06-19 21:13:57 +0200 (Mon, 19 Jun 2006) | 1 line

 + fix for bug #7007 by Martin Schreiber
........
r3926 | joost | 2006-06-23 22:52:04 +0200 (Fri, 23 Jun 2006) | 2 lines

 + when an error occurs, do not automatically rollback the transaction, only make it possible
 + use the new endian-functions
........
r3928 | joost | 2006-06-24 01:31:41 +0200 (Sat, 24 Jun 2006) | 1 line

 + implemented TDataset.Translate and TStringField.Transliterate
........
r3943 | joost | 2006-06-25 17:46:59 +0200 (Sun, 25 Jun 2006) | 1 line

 + implemented error-handling on ApplyUpdates
........
r3950 | joost | 2006-06-25 23:22:21 +0200 (Sun, 25 Jun 2006) | 1 line

 + Support for float-parameters
........
r3951 | joost | 2006-06-26 00:11:49 +0200 (Mon, 26 Jun 2006) | 1 line

 + added tests for ftbcd fields and string-typed parameters
........

git-svn-id: branches/fixes_2_0@3958 -
This commit is contained in:
peter 2006-06-26 06:37:29 +00:00
parent ec3c805097
commit 868de60ed2
10 changed files with 243 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
fcl/db/bufdataset.inc
View File

@ -417,10 +417,10 @@ begin
end;
function TBufDataset.ApplyRecUpdate(UpdateKind : TUpdateKind) : boolean;
procedure TBufDataset.ApplyRecUpdate(UpdateKind : TUpdateKind);
begin
Result := False;
raise EDatabaseError.Create(SApplyRecNotSupported);
end;
procedure TBufDataset.CancelUpdates;
@ -472,11 +472,25 @@ begin
end;
end;
procedure TBufDataset.ApplyUpdates;
procedure TBufDataset.SetOnUpdateError(const AValue: TResolverErrorEvent);
begin
FOnUpdateError := AValue;
end;
procedure TBufDataset.ApplyUpdates; // For backwards-compatibility
begin
ApplyUpdates(0);
end;
procedure TBufDataset.ApplyUpdates(MaxErrors: Integer);
var SaveBookmark : pchar;
r : Integer;
FailedCount : integer;
EUpdErr : EUpdateError;
Response : TResolverResponse;
begin
CheckBrowseMode;
@ -487,19 +501,34 @@ begin
r := 0;
FailedCount := 0;
while r < Length(FUpdateBuffer) do
Response := rrApply;
while (r < Length(FUpdateBuffer)) and (Response <> rrAbort) do
begin
if assigned(FUpdateBuffer[r].BookmarkData) then
begin
InternalGotoBookmark(@FUpdateBuffer[r].BookmarkData);
Resync([rmExact,rmCenter]);
if ApplyRecUpdate(FUpdateBuffer[r].UpdateKind) then
Response := rrApply;
try
ApplyRecUpdate(FUpdateBuffer[r].UpdateKind);
except
on E: EDatabaseError do
begin
Inc(FailedCount);
if failedcount > word(MaxErrors) then Response := rrAbort
else Response := rrSkip;
EUpdErr := EUpdateError.Create(SOnUpdateError,E.Message,0,0,E);
if assigned(FOnUpdateError) then FOnUpdateError(Self,Self,EUpdErr,FUpdateBuffer[r].UpdateKind,Response)
else if Response = rrAbort then Raise EUpdErr
end
else
raise;
end;
if response = rrApply then
begin
FreeRecordBuffer(FUpdateBuffer[r].OldValuesBuffer);
FUpdateBuffer[r].BookmarkData := nil;
end
else
Inc(FailedCount);
end;
inc(r);
end;

2
fcl/db/dataset.inc
View File

@ -1870,7 +1870,7 @@ end;
Function TDataset.Translate(Src, Dest: PChar; ToOem: Boolean): Integer;
begin
//!! To be implemented
strcopy(dest,src);
end;
Function Tdataset.TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;

1
fcl/db/datasource.inc
View File

@ -112,6 +112,7 @@ begin
RecordChanged(TField(Info));
deDataSetChange: begin
SetActive(DataSource.DataSet.Active);
CalcRange;
CalcFirstRecord(Info);
DatasetChanged;
end;

50
fcl/db/db.pp
View File

@ -57,6 +57,7 @@ type
TUpdateStatusSet = SET OF TUpdateStatus;
TUpdateMode = (upWhereAll, upWhereChanged, upWhereKeyOnly);
TResolverResponse = (rrSkip, rrAbort, rrMerge, rrApply, rrIgnore);
TProviderFlag = (pfInUpdate, pfInWhere, pfInKey, pfHidden);
TProviderFlags = set of TProviderFlag;
@ -68,6 +69,7 @@ type
TField = class;
TFields = Class;
TDataSet = class;
TBufDataSet = class;
TDataBase = Class;
TDatasource = Class;
TDatalink = Class;
@ -76,6 +78,22 @@ type
{ Exception classes }
EDatabaseError = class(Exception);
EUpdateError = class(EDatabaseError)
private
FContext : String;
FErrorCode : integer;
FOriginalException : Exception;
FPreviousError : Integer;
public
constructor Create(NativeError, Context : String;
ErrCode, PrevError : integer; E: Exception);
Destructor Destroy;
property Context : String read FContext;
property ErrorCode : integer read FErrorcode;
property OriginalExcaption : Exception read FOriginalException;
property PreviousError : Integer read FPreviousError;
end;
{ TFieldDef }
@ -387,7 +405,8 @@ type
TStringField = class(TField)
private
FFixedChar : boolean;
FFixedChar : boolean;
FTransliterate : Boolean;
protected
class procedure CheckTypeSize(AValue: Longint); override;
function GetAsBoolean: Boolean; override;
@ -409,6 +428,7 @@ type
public
constructor Create(AOwner: TComponent); override;
property FixedChar : Boolean read FFixedChar write FFixedChar;
property Transliterate: Boolean read FTransliterate write FTransliterate;
published
property Size default 20;
end;
@ -901,6 +921,8 @@ type
TDataSetNotifyEvent = procedure(DataSet: TDataSet) of object;
TDataSetErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
var DataAction: TDataAction) of object;
TResolverErrorEvent = procedure(Sender: TObject; DataSet: TBufDataset; E: EUpdateError;
UpdateKind: TUpdateKind; var Response: TResolverResponse) of object;
TFilterOption = (foCaseInsensitive, foNoPartialCompare);
TFilterOptions = set of TFilterOption;
@ -1514,6 +1536,7 @@ type
FFieldBufPositions : array of longint;
FAllPacketsFetched : boolean;
FOnUpdateError : TResolverErrorEvent;
procedure CalcRecordSize;
function LoadBuffer(Buffer : PChar): TGetResult;
function GetFieldSize(FieldDef : TFieldDef) : longint;
@ -1551,13 +1574,15 @@ type
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
function IsCursorOpen: Boolean; override;
function GetRecordCount: Longint; override;
function ApplyRecUpdate(UpdateKind : TUpdateKind) : boolean; virtual;
procedure ApplyRecUpdate(UpdateKind : TUpdateKind); virtual;
procedure SetOnUpdateError(const aValue: TResolverErrorEvent);
{abstracts, must be overidden by descendents}
function Fetch : boolean; virtual; abstract;
function LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean; virtual; abstract;
public
constructor Create(AOwner: TComponent); override;
procedure ApplyUpdates; virtual;
procedure ApplyUpdates; virtual; overload;
procedure ApplyUpdates(MaxErrors: Integer); virtual; overload;
procedure CancelUpdates; virtual;
destructor Destroy; override;
function Locate(const keyfields: string; const keyvalues: Variant; options: TLocateOptions) : boolean; override;
@ -1565,6 +1590,7 @@ type
property ChangeCount : Integer read GetChangeCount;
published
property PacketRecords : Integer read FPacketRecords write FPacketRecords default 10;
property OnUpdateError: TResolverErrorEvent read FOnUpdateError write SetOnUpdateError;
end;
{ TParam }
@ -1906,6 +1932,24 @@ begin
Pos := Length(Fields) + 1;
end;
{ EUpdateError }
constructor EUpdateError.Create(NativeError, Context : String;
ErrCode, PrevError : integer; E: Exception);
begin
Inherited CreateFmt(NativeError,[Context]);
FContext := Context;
FErrorCode := ErrCode;
FPreviousError := PrevError;
FOriginalException := E;
end;
Destructor EUpdateError.Destroy;
begin
FOriginalException.Free;
end;
{ TIndexDef }
constructor TIndexDef.Create(Owner: TIndexDefs; const AName, TheFields: string;

2
fcl/db/dbconst.pp
View File

@ -79,6 +79,8 @@ Const
SInvPacketRecordsValue = 'PacketRecords has to be larger then 0';
SInvalidSearchFieldType = 'Searching in fields of type %s is not supported';
SDatasetEmpty = 'The dataset is empty';
SOnUpdateError = 'An error occured while applying the updates in a record: %s';
SApplyRecNotSupported = 'Applying updates is not supported by this TDataset descendent';
Implementation

20
fcl/db/fields.inc
View File

@ -961,6 +961,7 @@ begin
Inherited Create(AOwner);
SetDataType(ftString);
FFixedChar := False;
FTransliterate := False;
Size:=20;
end;
@ -1037,12 +1038,20 @@ end;
function TStringField.GetValue(var AValue: string): Boolean;
Var Buf : TStringFieldBuffer;
Var Buf, TBuf : TStringFieldBuffer;
begin
Result:=GetData(@Buf);
If Result then
AValue:=Buf;
begin
if transliterate then
begin
DataSet.Translate(Buf,TBuf,False);
AValue:=TBuf;
end
else
AValue:=Buf
end
end;
procedure TStringField.SetAsBoolean(AValue: Boolean);
@ -1076,9 +1085,16 @@ procedure TStringField.SetAsString(const AValue: string);
Const NullByte : char = #0;
var Buf : TStringFieldBuffer;
begin
IF Length(AValue)=0 then
SetData(@NullByte)
else if FTransliterate then
begin
DataSet.Translate(@AValue[1],Buf,True);
SetData(@buf);
end
else
SetData(@AValue[1]);
end;

29
fcl/db/sqldb/interbase/ibconnection.pp
View File

@ -51,6 +51,7 @@ type
procedure GetDateTime(CurrBuff, Buffer : pointer; AType : integer);
procedure SetDateTime(CurrBuff: pointer; PTime : TDateTime; AType : integer);
procedure GetFloat(CurrBuff, Buffer : pointer; Field : TFieldDef);
procedure SetFloat(CurrBuff: pointer; Dbl: Double; Size: integer);
procedure CheckError(ProcName : string; Status : array of ISC_STATUS);
function getMaxBlobSize(blobHandle : TIsc_Blob_Handle) : longInt;
procedure SetParameters(cursor : TSQLCursor;AParams : TParams);
@ -655,6 +656,10 @@ begin
Move(li, in_sqlda^.SQLvar[SQLVarNr].SQLData^, in_SQLDA^.SQLVar[SQLVarNr].SQLLen);
{$R+}
end;
ftFloat:
{$R-}
SetFloat(in_sqlda^.SQLvar[SQLVarNr].SQLData, AParams[ParNr].AsFloat, in_SQLDA^.SQLVar[SQLVarNr].SQLLen);
{$R+}
else
DatabaseErrorFmt(SUnsupportedParameter,[Fieldtypenames[AParams[ParNr].DataType]],self);
end {case}
@ -912,6 +917,30 @@ begin
qry.free;
end;
procedure TIBConnection.SetFloat(CurrBuff: pointer; Dbl: Double; Size: integer);
var
Ext : extended;
Sin : single;
begin
case Size of
4 :
begin
Sin := Dbl;
Move(Sin, CurrBuff^, 4);
end;
8 :
begin
Move(Dbl, CurrBuff^, 8);
end;
10:
begin
Ext := Dbl;
Move(Ext, CurrBuff^, 10);
end;
end;
end;
procedure TIBConnection.GetFloat(CurrBuff, Buffer : pointer; Field : TFieldDef);
var
Ext : extended;

25
fcl/db/sqldb/postgres/pqconnection.pp
View File

@ -503,7 +503,9 @@ begin
pqclear(res);
tr.ErrorOccured := True;
atransaction.Rollback;
// Don't perform the rollback, only make it possible to do a rollback.
// The other databases also don't do this.
// atransaction.Rollback;
DatabaseError(SErrExecuteFailed + ' (PostgreSQL: ' + s + ')',self);
end;
end;
@ -597,8 +599,14 @@ begin
case FieldDef.DataType of
ftInteger, ftSmallint, ftLargeInt,ftfloat :
begin
for tel := 1 to i do // postgres returns big-endian numbers
pchar(Buffer)[tel-1] := CurrBuff[i-tel];
case i of // postgres returns big-endian numbers
sizeof(int64) : pint64(buffer)^ := BEtoN(pint64(CurrBuff)^);
sizeof(integer) : pinteger(buffer)^ := BEtoN(pinteger(CurrBuff)^);
sizeof(smallint) : psmallint(buffer)^ := BEtoN(psmallint(CurrBuff)^);
else
for tel := 1 to i do
pchar(Buffer)[tel-1] := CurrBuff[i-tel];
end; {case}
end;
ftString :
begin
@ -609,21 +617,14 @@ begin
end;
ftdate :
begin
li := 0;
for tel := 1 to i do // postgres returns big-endian numbers
pchar(@li)[tel-1] := CurrBuff[i-tel];
// double(buffer^) := x + 36526; This doesn't work, please tell me what is wrong with it?
dbl := pointer(buffer);
dbl^ := li + 36526;
dbl^ := BEtoN(plongint(CurrBuff)^) + 36526;
i := sizeof(double);
end;
ftDateTime, fttime :
begin
pint64(buffer)^ := BEtoN(pint64(CurrBuff)^);
dbl := pointer(buffer);
dbl^ := 0;
for tel := 1 to i do // postgres returns big-endian numbers
pchar(Buffer)[tel-1] := CurrBuff[i-tel];
dbl^ := (dbl^+3.1558464E+009)/86400; // postgres counts seconds elapsed since 1-1-2000
// Now convert the mathematically-correct datetime to the
// illogical windows/delphi/fpc TDateTime:

11
fcl/db/sqldb/sqldb.pp
View File

@ -215,7 +215,7 @@ type
procedure InternalInitFieldDefs; override;
procedure InternalOpen; override;
function GetCanModify: Boolean; override;
function ApplyRecUpdate(UpdateKind : TUpdateKind) : boolean; override;
procedure ApplyRecUpdate(UpdateKind : TUpdateKind); override;
Function IsPrepared : Boolean; virtual;
Procedure SetActive (Value : Boolean); override;
procedure SetFiltered(Value: Boolean); override;
@ -1061,7 +1061,7 @@ begin
(DataBase as TSQLConnection).UpdateIndexDefs(FIndexDefs,FTableName);
end;
function TSQLQuery.ApplyRecUpdate(UpdateKind : TUpdateKind) : boolean;
Procedure TSQLQuery.ApplyRecUpdate(UpdateKind : TUpdateKind);
var
s : string;
@ -1141,7 +1141,6 @@ var qry : tsqlquery;
Fld : TField;
begin
Result := True;
case UpdateKind of
ukModify : begin
qry := FUpdateQry;
@ -1156,7 +1155,6 @@ begin
if trim(qry.sql.Text) = '' then qry.SQL.Add(DeleteRecQuery);
end;
end;
try
with qry do
begin
for x := 0 to Params.Count-1 do with params[x] do if leftstr(name,4)='OLD_' then
@ -1171,11 +1169,6 @@ begin
end;
execsql;
end;
except
on EDatabaseError do Result := False
else
raise;
end;
end;

94
fcl/dbtests/testsqlfieldtypes.pas
View File

@ -22,6 +22,7 @@ type
procedure RunTest; override;
published
procedure TestInt;
procedure TestNumeric;
procedure TestString;
procedure TestUnlVarChar;
procedure TestDate;
@ -30,6 +31,7 @@ type
procedure TestNullValues;
procedure TestParamQuery;
procedure TestStringParamQuery;
procedure TestAggregates;
end;
@ -65,6 +67,35 @@ begin
end;
end;
procedure TTestFieldTypes.TestNumeric;
const
testValuesCount = 13;
testValues : Array[0..testValuesCount-1] of currency = (-123456.789,-10200,-10000,-1875.25,-10,-0.5,0,0.5,10,1875.25,10000,10200,123456.789);
var
i : byte;
begin
CreateTableWithFieldType(ftBCD,'NUMERIC(10,4)');
TestFieldDeclaration(ftBCD,sizeof(Currency));
for i := 0 to testValuesCount-1 do
TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (' + CurrToStrF(testValues[i],ffFixed,3) + ')');
with TSQLDBConnector(DBConnector).Query do
begin
Open;
for i := 0 to testValuesCount-1 do
begin
AssertEquals(testValues[i],fields[0].AsCurrency);
Next;
end;
close;
end;
end;
procedure TTestFieldTypes.TestString;
const
@ -407,6 +438,69 @@ begin
end;
procedure TTestFieldTypes.TestStringParamQuery;
const
testValuesCount = 20;
testValues : Array[0..testValuesCount-1] of string = (
'',
'a',
'ab',
'abc',
'abcd',
'abcde',
'abcdef',
'abcdefg',
'abcdefgh',
'abcdefghi',
'abcdefghij',
'lMnOpQrStU',
'1234567890',
'_!@#$%^&*(',
' ''quotes'' ',
')-;:/?.<>',
'~`|{}- =', // note that there's no \ (backslash) since some db's uses that as escape-character
' WRaP ',
'wRaP ',
' wRAP'
);
var i : integer;
begin
TSQLDBConnector(DBConnector).Connection.ExecuteDirect('create table FPDEV2 (ID INT, FIELD1 VARCHAR(10))');
// Firebird/Interbase need a commit after a DDL statement. Not necessary for the other connections
TSQLDBConnector(DBConnector).Transaction.CommitRetaining;
with TSQLDBConnector(DBConnector).Query do
begin
sql.clear;
sql.append('insert into FPDEV2 (ID,FIELD1) values (:id,:field1)');
for i := 0 to testValuesCount -1 do
begin
Params.ParamByName('id').AsInteger := i;
Params.ParamByName('field1').AsString := testValues[i];
ExecSQL;
end;
TSQLDBConnector(DBConnector).Transaction.CommitRetaining;
sql.clear;
sql.append('select * from FPDEV2 order by ID');
open;
for i := 0 to testValuesCount -1 do
begin
AssertEquals(i,FieldByName('ID').AsInteger);
AssertEquals(testValues[i],FieldByName('FIELD1').AsString);
Next;
end;
close;
end;
TSQLDBConnector(DBConnector).Transaction.CommitRetaining;
end;
procedure TTestFieldTypes.TestAggregates;
begin
TSQLDBConnector(DBConnector).Connection.ExecuteDirect('create table FPDEV2 (FIELD1 INT, FIELD2 INT)');