fcl-db:

- introduce ESQLDatabaseError (with fields: ErrorCode and SQLState) as direct descendant of EDatabaseError and an ancestor for all SQLConnection specific exceptions (like EPQDatabaseError, EIBDatabaseError, EODBCException, etc.)
- add overriden method PSGetUpdateException to create EUpdateException with ErrorCode taken from this new ESQLDatabaseException
- adapted some connections to use this new TSQLDatabaseError
Bug #23798

git-svn-id: trunk@26765 -

packages/fcl-db/src/base/bufdataset.pas

@@ -563,7 +563,6 @@ type
     procedure ApplyUpdates; virtual; overload;
     procedure ApplyUpdates(MaxErrors: Integer); virtual; overload;
     procedure MergeChangeLog;
-    Procedure ClearIndexes;
     procedure CancelUpdates; virtual;
     destructor Destroy; override;
     function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions) : boolean; override;
@@ -572,6 +571,7 @@ type
     function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
     procedure AddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string = '';
       const ACaseInsFields: string = ''); virtual;
+    procedure ClearIndexes;
 
     procedure SetDatasetPacket(AReader : TDataPacketReader);
     procedure GetDatasetPacket(AWriter : TDataPacketReader);
@@ -1102,6 +1102,17 @@ begin
       BuildIndex(FIndexes[i]);
 end;
 
+procedure TCustomBufDataset.ClearIndexes;
+var
+  i:integer;
+begin
+  CheckInactive;
+  For I:=0 to Length(FIndexes)-1 do
+    FreeAndNil(Findexes[I]);
+  SetLength(FIndexes,0);
+  FIndexesCount:=0;
+end;
+
 procedure TCustomBufDataset.RemoveRecordFromIndexes(const ABookmark: TBufBookmark);
 var i: integer;
 begin
@@ -2283,7 +2294,7 @@ begin
             else Response := rrSkip;
             if assigned(FOnUpdateError) then
               begin
-              AUpdateErr := EUpdateError.Create(SOnUpdateError,E.Message,0,0,Exception(AcquireExceptionObject));
+              AUpdateErr := PSGetUpdateException(Exception(AcquireExceptionObject), nil);
               FOnUpdateError(Self,Self,AUpdateErr,FUpdateBuffer[r].UpdateKind,Response);
               AUpdateErr.Free;
               if Response in [rrApply, rrIgnore] then dec(FailedCount);
@@ -2295,7 +2306,7 @@ begin
           else
             raise;
         end;
-        if response in [rrApply, rrIgnore] then
+        if Response in [rrApply, rrIgnore] then
           begin
           FreeRecordBuffer(FUpdateBuffer[r].OldValuesBuffer);
           if FUpdateBuffer[r].UpdateKind = ukDelete then
@@ -2604,17 +2615,6 @@ begin
   result := ABlobBuffer;
 end;
 
-procedure TCustomBufDataset.ClearIndexes;
-var
-  i:integer;
-begin
-  CheckInactive;
-  For I:=0 to Length(FIndexes)-1 do
-    FreeAndNil(Findexes[I]);
-  SetLength(FIndexes,0);
-  FIndexesCount:=0;
-end;
-
 function TCustomBufDataset.GetNewWriteBlobBuffer : PBlobBuffer;
 
 var ABlobBuffer : PBlobBuffer;

packages/fcl-db/src/sqldb/mssql/mssqlconn.pp

@@ -137,9 +137,9 @@ type
 
   { EMSSQLDatabaseError }
 
-  EMSSQLDatabaseError = class(EDatabaseError)
+  EMSSQLDatabaseError = class(ESQLDatabaseError)
     public
-      DBErrorCode : integer;
+      property DBErrorCode: integer read ErrorCode; deprecated 'Please use ErrorCode instead of DBErrorCode'; // Feb 2014
   end;
 
   { TMSSQLConnectionDef }
@@ -168,7 +168,7 @@ var
 
 implementation
 
-uses DBConst, StrUtils, FmtBCD;
+uses StrUtils, FmtBCD;
 
 type
 
@@ -293,7 +293,6 @@ end;
 
 function TMSSQLConnection.CheckError(const Ret: RETCODE): RETCODE;
 var E: EMSSQLDatabaseError;
-    CompName: string;
 begin
   if Ret=FAIL then
   begin
@@ -301,9 +300,7 @@ begin
       case DBErrorNo of
         SYBEFCON: DBErrorStr:='SQL Server connection failed!';
       end;
-    if Self.Name = '' then CompName := Self.ClassName else CompName := Self.Name;
-    E:=EMSSQLDatabaseError.CreateFmt('%s : Error %d : %s'+LineEnding+'%s', [CompName, DBErrorNo, DBErrorStr, DBMsgStr]);
-    E.DBErrorCode:=DBErrorNo;
+    E:=EMSSQLDatabaseError.CreateFmt('Error %d : %s'+LineEnding+'%s', [DBErrorNo, DBErrorStr, DBMsgStr], Self, DBErrorNo, '');
     DBErrorStr:='';
     DBMsgStr:='';
     raise E;

packages/fcl-db/src/sqldb/mysql/mysqlconn.inc

@@ -162,7 +162,6 @@ Type
   end;
 
 
-  EMySQLError = Class(Exception);
   {$IFDEF mysql56}
     TMySQL56Connection = Class(TConnectionName);
     TMySQL56ConnectionDef = Class(TMySQLConnectionDef);
@@ -254,19 +253,27 @@ Resourcestring
   SErrVersionMismatch = '%s can not work with the installed MySQL client version: Expected (%s), got (%s).';
   SErrSettingParameter = 'Error setting parameter "%s"';
 
-Procedure MySQLError(R : PMySQL;Msg: String;Comp : TComponent);
+Procedure MySQLError(R : PMySQL; Msg: String; Comp : TComponent);
 
 Var
-  MySQLMsg : String;
+  MySQLError, MySQLState : String;
+  MySQLErrno: integer;
 
 begin
- If (R<>Nil) then
-   begin
-   MySQLMsg:=Strpas(mysql_error(R));
-   DatabaseErrorFmt(Msg,[MySQLMsg],Comp);
-   end
- else
-   DatabaseError(Msg,Comp);
+  If (R<>Nil) then
+    begin
+    MySQLError:=StrPas(mysql_error(R));
+    MySQLErrno:=mysql_errno(R);
+    MySQLState:=StrPas(mysql_sqlstate(R));
+    end
+  else
+    begin
+    MySQLError:='';
+    MySQLErrno:=0;
+    MySQLState:='';
+    end;
+
+  raise ESQLDatabaseError.CreateFmt(Msg, [MySQLError], Comp, MySQLErrno, MySQLState);
 end;
 
 function MysqlOption(const OptionName: string; out AMysql_Option: mysql_option) : boolean;

packages/fcl-db/src/sqldb/odbc/odbcconn.pas

@@ -133,10 +133,7 @@ type
     property OnLogin;
   end;
 
-  EODBCException = class(EDatabaseError)
-    NativeError: integer;
-    SQLState: string;
-  end;
+  EODBCException = class(ESQLDatabaseError);
 
 {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
   { TODBCConnectionDef }
@@ -151,7 +148,7 @@ type
 implementation
 
 uses
-  DBConst, ctypes;
+  ctypes;
 
 const
   DefaultEnvironment:TODBCEnvironment = nil;
@@ -195,12 +192,11 @@ procedure ODBCCheckResult(LastReturnCode:SQLRETURN; HandleType:SQLSMALLINT; AHan
   end;
 
 var
-  NativeError:SQLINTEGER;
+  NativeError, NativeError1: SQLINTEGER;
   TextLength:SQLSMALLINT;
   Res:SQLRETURN;
-  SqlState,MessageText,TotalMessage:string;
+  SqlState, SQLState1, MessageText, TotalMessage: string;
   RecNumber:SQLSMALLINT;
-  Error: EODBCException;
 begin
   // check result
   if ODBCSucces(LastReturnCode) then
@@ -208,14 +204,15 @@ begin
 
   //WriteLn('LastResultCode: ',ODBCResultToStr(LastReturnCode));
   try
+    NativeError1:=0;
+    SQLState1:='';
     // build TotalMessage for exception to throw
     TotalMessage:=Format(ErrorMsg,FmtArgs)+Format(' ODBC error details: LastReturnCode: %s;',[ODBCResultToStr(LastReturnCode)]);
     // retrieve status records
-    NativeError:=0;
-    SetLength(SqlState,5); // SqlState buffer
     SetLength(MessageText,1);
     RecNumber:=1;
     repeat
+      SetLength(SqlState,5); // reset 5-character buffer
       // dummy call to get correct TextLength
       //WriteLn('Getting error record ',RecNumber);
       Res:=SQLGetDiagRec(HandleType,AHandle,RecNumber,@(SqlState[1]),NativeError,@(MessageText[1]),0,TextLength);
@@ -232,6 +229,12 @@ begin
       end;
       // add to TotalMessage
       TotalMessage:=TotalMessage+Format(' Record %d: SqlState: %s; NativeError: %d; Message: %s;',[RecNumber,SqlState,NativeError,MessageText]);
+      // save most significant error
+      if RecNumber = 1 then
+      begin
+        NativeError1 := NativeError;
+        SQLState1 := SqlState;
+      end;
       // incement counter
       Inc(RecNumber);
     until false;
@@ -241,10 +244,7 @@ begin
     end
   end;
   // raise error
-  Error := EODBCException.Create(TotalMessage);
-  Error.NativeError := NativeError;
-  Error.SQLState := SqlState;
-  raise Error;
+  raise EODBCException.CreateFmt(TotalMessage, [], nil, NativeError1, SQLState1);
 end;
 
 procedure ODBCCheckResult(LastReturnCode:SQLRETURN; HandleType:SQLSMALLINT; AHandle: SQLHANDLE; ErrorMsg: string);

packages/fcl-db/src/sqldb/sqldb.pp

@@ -70,7 +70,17 @@ type
     FSchemaType    : TSchemaType;
   end;
 
-type TQuoteChars = array[0..1] of char;
+  { ESQLDatabaseError}
+
+  ESQLDatabaseError = class(EDatabaseError)
+    public
+      ErrorCode: integer;
+      SQLState : string;
+      constructor CreateFmt(const Fmt: string; const Args: array of const;
+                            Comp : TComponent; AErrorCode: integer; ASQLState: string); overload;
+  end;
+
+  TQuoteChars = array[0..1] of char;
 
 const
   SingleQuotes : TQuoteChars = ('''','''');
@@ -352,6 +362,7 @@ type
     Function Cursor : TSQLCursor;
     function LoadField(FieldDef : TFieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; override;
     procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField); override;
+    procedure ApplyRecUpdate(UpdateKind : TUpdateKind); override;
     // abstract & virtual methods of TDataset
     procedure UpdateServerIndexDefs; virtual;
     procedure SetDatabase(Value : TDatabase); override;
@@ -361,7 +372,6 @@ type
     procedure InternalInitFieldDefs; override;
     procedure InternalOpen; override;
     function  GetCanModify: Boolean; override;
-    procedure ApplyRecUpdate(UpdateKind : TUpdateKind); override;
     Function IsPrepared : Boolean; virtual;
     Procedure SetActive (Value : Boolean); override;
     procedure SetServerFiltered(Value: Boolean); virtual;
@@ -370,9 +380,12 @@ type
     Procedure SetDataSource(AValue : TDataSource);
     procedure BeforeRefreshOpenCursor; override;
     procedure SetReadOnly(AValue : Boolean); override;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    // IProviderSupport methods
+    function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override;
+
     Function LogEvent(EventType : TDBEventType) : Boolean;
     Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
-    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
   public
     procedure Prepare; virtual;
     procedure UnPrepare; virtual;
@@ -636,6 +649,25 @@ begin
   result := Format('%.2d:%.2d:%.2d.%.3d',[hour,minute,second,millisecond]);
 end;
 
+{ ESQLDatabaseError }
+
+constructor ESQLDatabaseError.CreateFmt(const Fmt: string; const Args: array of const;
+  Comp: TComponent; AErrorCode: integer; ASQLState: string);
+const CompNameFmt='%s : %s';
+var Msg: string;
+begin
+  if not assigned(Comp) then
+    Msg := Fmt
+  else if Comp.Name = '' then
+    Msg := Format(CompNameFmt, [Comp.ClassName,Fmt])
+  else
+    Msg := Format(CompNameFmt, [Comp.Name,Fmt]);
+
+  inherited CreateFmt(Msg, Args);
+  ErrorCode := AErrorCode;
+  SQLState  := ASQLState;
+end;
+
 { TCustomSQLStatement }
 
 procedure TCustomSQLStatement.OnChangeSQL(Sender: TObject);
@@ -2373,6 +2405,23 @@ begin
     DataSource:=Nil;
 end;
 
+function TCustomSQLQuery.PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError;
+var
+  PrevErrorCode, ErrorCode: Integer;
+begin
+  if Assigned(Prev) then
+    PrevErrorCode := Prev.ErrorCode
+  else
+    PrevErrorCode := 0;
+
+  if E is ESQLDatabaseError then
+    ErrorCode := ESQLDatabaseError(E).ErrorCode
+  else
+    ErrorCode := 0;
+
+  Result := EUpdateError.Create(SOnUpdateError, E.Message, ErrorCode, PrevErrorCode, E);
+end;
+
 { TSQLScript }
 
 procedure TSQLScript.ExecuteStatement(SQLStatement: TStrings;