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

http://[email protected]/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

@@ -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;

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;

fcl/db/datasource.inc

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

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;

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
 

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;

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;

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:

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;
 
 

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)');