+ implemented error-handling on ApplyUpdates

git-svn-id: trunk@3943 -

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/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 }
 
@@ -903,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;
@@ -1516,6 +1536,7 @@ type
     FFieldBufPositions : array of longint;
     
     FAllPacketsFetched : boolean;
+    FOnUpdateError  : TResolverErrorEvent;
     procedure CalcRecordSize;
     function LoadBuffer(Buffer : PChar): TGetResult;
     function GetFieldSize(FieldDef : TFieldDef) : longint;
@@ -1553,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;
@@ -1567,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 }
@@ -1908,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/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;