From 868de60ed23340fbb27c4715517bba3804df6184 Mon Sep 17 00:00:00 2001 From: peter Date: Mon, 26 Jun 2006 06:37:29 +0000 Subject: [PATCH] Merged revisions 3896,3926,3928,3943,3950-3951 via svnmerge from 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 - --- fcl/db/bufdataset.inc | 43 ++++++++++-- fcl/db/dataset.inc | 2 +- fcl/db/datasource.inc | 1 + fcl/db/db.pp | 50 +++++++++++++- fcl/db/dbconst.pp | 2 + fcl/db/fields.inc | 20 +++++- fcl/db/sqldb/interbase/ibconnection.pp | 29 ++++++++ fcl/db/sqldb/postgres/pqconnection.pp | 25 +++---- fcl/db/sqldb/sqldb.pp | 11 +-- fcl/dbtests/testsqlfieldtypes.pas | 94 ++++++++++++++++++++++++++ 10 files changed, 243 insertions(+), 34 deletions(-) diff --git a/fcl/db/bufdataset.inc b/fcl/db/bufdataset.inc index 57bf85a9e0..767b46c868 100644 --- a/fcl/db/bufdataset.inc +++ b/fcl/db/bufdataset.inc @@ -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; diff --git a/fcl/db/dataset.inc b/fcl/db/dataset.inc index d3dc61750f..21916f01e4 100644 --- a/fcl/db/dataset.inc +++ b/fcl/db/dataset.inc @@ -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; diff --git a/fcl/db/datasource.inc b/fcl/db/datasource.inc index f138c00964..4be5b2b112 100644 --- a/fcl/db/datasource.inc +++ b/fcl/db/datasource.inc @@ -112,6 +112,7 @@ begin RecordChanged(TField(Info)); deDataSetChange: begin SetActive(DataSource.DataSet.Active); + CalcRange; CalcFirstRecord(Info); DatasetChanged; end; diff --git a/fcl/db/db.pp b/fcl/db/db.pp index cbbabd2853..08af8e9026 100644 --- a/fcl/db/db.pp +++ b/fcl/db/db.pp @@ -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; diff --git a/fcl/db/dbconst.pp b/fcl/db/dbconst.pp index cd35c43c2a..3387f5adab 100644 --- a/fcl/db/dbconst.pp +++ b/fcl/db/dbconst.pp @@ -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 diff --git a/fcl/db/fields.inc b/fcl/db/fields.inc index b5d71d17b8..e43a370867 100644 --- a/fcl/db/fields.inc +++ b/fcl/db/fields.inc @@ -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; diff --git a/fcl/db/sqldb/interbase/ibconnection.pp b/fcl/db/sqldb/interbase/ibconnection.pp index 6a1f6ae18d..07a3059800 100644 --- a/fcl/db/sqldb/interbase/ibconnection.pp +++ b/fcl/db/sqldb/interbase/ibconnection.pp @@ -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; diff --git a/fcl/db/sqldb/postgres/pqconnection.pp b/fcl/db/sqldb/postgres/pqconnection.pp index b735615fa7..238a1f995a 100644 --- a/fcl/db/sqldb/postgres/pqconnection.pp +++ b/fcl/db/sqldb/postgres/pqconnection.pp @@ -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: diff --git a/fcl/db/sqldb/sqldb.pp b/fcl/db/sqldb/sqldb.pp index 96f277e85b..8f43d3c548 100644 --- a/fcl/db/sqldb/sqldb.pp +++ b/fcl/db/sqldb/sqldb.pp @@ -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; diff --git a/fcl/dbtests/testsqlfieldtypes.pas b/fcl/dbtests/testsqlfieldtypes.pas index 4ac57057d5..40b217fe6f 100644 --- a/fcl/dbtests/testsqlfieldtypes.pas +++ b/fcl/dbtests/testsqlfieldtypes.pas @@ -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)');