{*************************************************************}
{                                                             }
{       Borland Delphi Visual Component Library               }
{       InterBase Express core components                     }
{                                                             }
{       Copyright (c) 1998-2003 Borland Software Corporation  }
{                                                             }
{    InterBase Express is based in part on the product        }
{    Free IB Components, written by Gregory H. Deatz for      }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.          }
{    Free IB Components is used under license.                }
{                                                             }
{    Additional code created by Jeff Overcash and used        }
{    with permission.                                         }
{*************************************************************}

unit Borland.Vcl.IB;

{$A8,R-}

interface

uses
    Windows, SysUtils, Classes, IBHeader, IBExternals, IBUtils, DB, IBXConst;

type
  TTraceFlag = (tfQPrepare, tfQExecute, tfQFetch, tfError, tfStmt, tfConnect,
     tfTransact, tfBlob, tfService, tfMisc);
  TTraceFlags = set of TTraceFlag;

  EIBError                  = class(EDatabaseError)
  private
    FSQLCode: Long;
    FIBErrorCode: Long;
  public
    constructor Create(ASQLCode: Long; Msg: string); overload;
    constructor Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string); overload;
    property SQLCode: Long read FSQLCode;
    property IBErrorCode: Long read FIBErrorCode;
  end;

  EIBInterBaseError         = class(EIBError);
  EIBInterBaseRoleError     = class(EIBError);
  EIBClientError            = class(EIBError);
  EIBPlanError              = class(EIBError);
  
  TIBDataBaseErrorMessage    = (ShowSQLCode,
                                ShowIBMessage,
                                ShowSQLMessage);
  TIBDataBaseErrorMessages   = set of TIBDataBaseErrorMessage;
  TIBClientError            = (
    ibxeUnknownError,
    ibxeInterBaseMissing,
    ibxeInterBaseInstallMissing,
    ibxeIB60feature,
    ibxeNotSupported,
    ibxeNotPermitted,
    ibxeFileAccessError,
    ibxeConnectionTimeout,
    ibxeCannotSetDatabase,
    ibxeCannotSetTransaction,
    ibxeOperationCancelled,
    ibxeDPBConstantNotSupported,
    ibxeDPBConstantUnknown,
    ibxeTPBConstantNotSupported,
    ibxeTPBConstantUnknown,
    ibxeDatabaseClosed,
    ibxeDatabaseOpen,
    ibxeDatabaseNameMissing,
    ibxeNotInTransaction,
    ibxeInTransaction,
    ibxeTimeoutNegative,
    ibxeNoDatabasesInTransaction,
    ibxeUpdateWrongDB,
    ibxeUpdateWrongTR,
    ibxeDatabaseNotAssigned,
    ibxeTransactionNotAssigned,
    ibxeXSQLDAIndexOutOfRange,
    ibxeXSQLDANameDoesNotExist,
    ibxeEOF,
    ibxeBOF,
    ibxeInvalidStatementHandle,
    ibxeSQLOpen,
    ibxeSQLClosed,
    ibxeDatasetOpen,
    ibxeDatasetClosed,
    ibxeUnknownSQLDataType,
    ibxeInvalidColumnIndex,
    ibxeInvalidParamColumnIndex,
    ibxeInvalidDataConversion,
    ibxeColumnIsNotNullable,
    ibxeBlobCannotBeRead,
    ibxeBlobCannotBeWritten,
    ibxeEmptyQuery,
    ibxeCannotOpenNonSQLSelect,
    ibxeNoFieldAccess,
    ibxeFieldReadOnly,
    ibxeFieldNotFound,
    ibxeNotEditing,
    ibxeCannotInsert,
    ibxeCannotPost,
    ibxeCannotUpdate,
    ibxeCannotDelete,
    ibxeCannotRefresh,
    ibxeBufferNotSet,
    ibxeCircularReference,
    ibxeSQLParseError,
    ibxeUserAbort,
    ibxeDataSetUniDirectional,
    ibxeCannotCreateSharedResource,
    ibxeWindowsAPIError,
    ibxeColumnListsDontMatch,
    ibxeColumnTypesDontMatch,
    ibxeCantEndSharedTransaction,
    ibxeFieldUnsupportedType,
    ibxeCircularDataLink,
    ibxeEmptySQLStatement,
    ibxeIsASelectStatement,
    ibxeRequiredParamNotSet,
    ibxeNoStoredProcName,
    ibxeIsAExecuteProcedure,
    ibxeUpdateFailed,
    ibxeNotCachedUpdates,
    ibxeNotLiveRequest,
    ibxeNoProvider,
    ibxeNoRecordsAffected,
    ibxeNoTableName,
    ibxeCannotCreatePrimaryIndex,
    ibxeCannotDropSystemIndex,
    ibxeTableNameMismatch,
    ibxeIndexFieldMissing,
    ibxeInvalidCancellation,
    ibxeInvalidEvent,
    ibxeMaximumEvents,
    ibxeNoEventsRegistered,
    ibxeInvalidQueueing,
    ibxeInvalidRegistration,
    ibxeInvalidBatchMove,
    ibxeSQLDialectInvalid,
    ibxeSPBConstantNotSupported,
    ibxeSPBConstantUnknown,
    ibxeServiceActive,
    ibxeServiceInActive,
    ibxeServerNameMissing,
    ibxeQueryParamsError,
    ibxeStartParamsError,
    ibxeOutputParsingError,
    ibxeUseSpecificProcedures,
    ibxeSQLMonitorAlreadyPresent,
    ibxeCantPrintValue,
    ibxeEOFReached,
    ibxeEOFInComment,
    ibxeEOFInString,
    ibxeParamNameExpected,
    ibxeSuccess,
    ibxeDelphiException,
    ibxeNoOptionsSet,
    ibxeNoDestinationDirectory,
    ibxeNosourceDirectory,
    ibxeNoUninstallFile,
    ibxeOptionNeedsClient,
    ibxeOptionNeedsServer,
    ibxeInvalidOption,
    ibxeInvalidOnErrorResult,
    ibxeInvalidOnStatusResult,
    ibxeDPBConstantUnknownEx,
    ibxeTPBConstantUnknownEx,
    ibxeUnknownPlan,
    ibxeFieldSizeMismatch,
    ibxeEventAlreadyRegistered,
    ibxeStringTooLarge,
    ibxeIB65feature,
    ibxeIB70Feature
    );


  TStatusVector = array[0..19] of ISC_STATUS;
  PStatusVector = IntPtr;


const
  IBPalette1 = 'InterBase'; {do not localize}
  IBPalette2 = 'InterBase Admin'; {do not localize}

  IBLocalBufferLength = 512;
  IBBigLocalBufferLength = IBLocalBufferLength * 2;
  IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;

  IBErrorMessages: array[TIBClientError] of string = (
    SUnknownError,
    SInterBaseMissing,
    SInterBaseInstallMissing,
    SIB60feature,
    SNotSupported,
    SNotPermitted,
    SFileAccessError,
    SConnectionTimeout,
    SCannotSetDatabase,
    SCannotSetTransaction,
    SOperationCancelled,
    SDPBConstantNotSupported,
    SDPBConstantUnknown,
    STPBConstantNotSupported,
    STPBConstantUnknown,
    SDatabaseClosed,
    SDatabaseOpen,
    SDatabaseNameMissing,
    SNotInTransaction,
    SInTransaction,
    STimeoutNegative,
    SNoDatabasesInTransaction,
    SUpdateWrongDB,
    SUpdateWrongTR,
    SDatabaseNotAssigned,
    STransactionNotAssigned,
    SXSQLDAIndexOutOfRange,
    SXSQLDANameDoesNotExist,
    SEOF,
    SBOF,
    SInvalidStatementHandle,
    SSQLOpen,
    SSQLClosed,
    SDatasetOpen,
    SDatasetClosed,
    SUnknownSQLDataType,
    SInvalidColumnIndex,
    SInvalidParamColumnIndex,
    SInvalidDataConversion,
    SColumnIsNotNullable,
    SBlobCannotBeRead,
    SBlobCannotBeWritten,
    SEmptyQuery,
    SCannotOpenNonSQLSelect,
    SNoFieldAccess,
    SFieldReadOnly,
    SFieldNotFound,
    SNotEditing,
    SCannotInsert,
    SCannotPost,
    SCannotUpdate,
    SCannotDelete,
    SCannotRefresh,
    SBufferNotSet,
    SCircularReference,
    SSQLParseError,
    SUserAbort,
    SDataSetUniDirectional,
    SCannotCreateSharedResource,
    SWindowsAPIError,
    SColumnListsDontMatch,
    SColumnTypesDontMatch,
    SCantEndSharedTransaction,
    SFieldUnsupportedType,
    SCircularDataLink,
    SEmptySQLStatement,
    SIsASelectStatement,
    SRequiredParamNotSet,
    SNoStoredProcName,
    SIsAExecuteProcedure,
    SUpdateFailed,
    SNotCachedUpdates,
    SNotLiveRequest,
    SNoProvider,
    SNoRecordsAffected,
    SNoTableName,
    SCannotCreatePrimaryIndex,
    SCannotDropSystemIndex,
    STableNameMismatch,
    SIndexFieldMissing,
    SInvalidCancellation,
    SInvalidEvent,
    SMaximumEvents,
    SNoEventsRegistered,
    SInvalidQueueing,
    SInvalidRegistration,
    SInvalidBatchMove,
    SSQLDialectInvalid,
    SSPBConstantNotSupported,
    SSPBConstantUnknown,
    SServiceActive,
    SServiceInActive,
    SServerNameMissing,
    SQueryParamsError,
    SStartParamsError,
    SOutputParsingError,
    SUseSpecificProcedures,
    SSQLMonitorAlreadyPresent,
    SCantPrintValue,
    SEOFReached,
    SEOFInComment,
    SEOFInString,
    SParamNameExpected,
    SSuccess,
    SDelphiException,
    SNoOptionsSet,
    SNoDestinationDirectory,
    SNosourceDirectory,
    SNoUninstallFile,
    SOptionNeedsClient,
    SOptionNeedsServer,
    SInvalidOption,
    SInvalidOnErrorResult,
    SInvalidOnStatusResult,
    SDPBConstantUnknownEx,
    STPBConstantUnknownEx,
    SUnknownPlan,
    SFieldSizeMismatch,
    SEventAlreadyRegistered,
    SStringTooLarge,
    SIB65feature,
    SIB70Feature
  );

var
  IBCS: TRTLCriticalSection;


procedure IBAlloc(var P : IntPtr; OldSize, NewSize: Integer);

procedure IBError(ErrMess: TIBClientError; const Args: array of const);
procedure IBDataBaseError;

function StatusVector: PISC_STATUS;
function CheckStatusVector(ErrorCodes : array of ISC_STATUS) : Boolean;
function StatusVectorAsText : string;

procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;

implementation

uses
  IBIntf, Borland.Vcl.IBSQLMonitor, System.Runtime.InteropServices;

type

  TISC_STATUS = class
  private
    FStatusVector : IntPtr;
  public
    constructor Create; 
    destructor Destroy; override;
    property StatusVector : IntPtr read FStatusVector;
  end;

var
  IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
threadvar
  FStatusVector : TISC_Status;

function StatusVector: PISC_STATUS;
begin
  if FStatusVector = nil then
  begin
    FStatusVector := TISC_Status.Create;
  end;
  result := FStatusVector.StatusVector;
end;

procedure IBAlloc(var P : IntPtr; OldSize, NewSize: Integer);
var
  i : Integer;
begin
  if NewSize = 0 then
    Marshal.FreeHGlobal(p)
  else
  begin
    if Assigned(p) then
      p := Marshal.ReAllocHGlobal(p, IntPtr(NewSize))
    else
      p := Marshal.AllocHGlobal(NewSize);
    for i := OldSize to NewSize - 1 do
      Marshal.WriteByte(p, i, 0);
  end;
end;

procedure IBError(ErrMess: TIBClientError; const Args: array of const);
begin
  if ErrMess <> ibxeCannotCreateSharedResource then
    MonitorHook.SendError(Format(IBErrorMessages[ErrMess], Args));
  raise EIBClientError.Create(Ord(ErrMess),
          Format(IBErrorMessages[ErrMess], Args));
end;

procedure IBDataBaseError;
var
  sqlcode: Long;
  IBErrorCode: Long;
  local_buffer: IntPtr;
  usr_msg: string;
  status_vector: PISC_STATUS;
  IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
begin
  usr_msg := '';
  local_buffer := Marshal.AllocHGlobal(IBHugeLocalBufferLength);
  status_vector := Marshal.AllocHGlobal(SizeOf(IntPtr));
  try
    { Get a local reference to the status vector.
      Get a local copy of the IBDataBaseErrorMessages options.
      Get the SQL error code }
    Marshal.WriteIntPtr(status_vector, StatusVector);
    IBErrorCode := Marshal.ReadInt32(StatusVector, 4);
    IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
    sqlcode := GetGDSLibrary.isc_sqlcode(StatusVector);

    if (ShowSQLCode in IBDataBaseErrorMessages) then
      usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
    Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
    if (ShowSQLMessage in IBDataBaseErrorMessages) then
    begin
      GetGDSLibrary.isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
      if (ShowSQLCode in IBDataBaseErrorMessages) then
        usr_msg := usr_msg + CRLF;
      usr_msg := usr_msg + IntPtr(local_buffer).ToString;
    end;
    if (ShowIBMessage in IBDataBaseErrorMessages) then
    begin
      if (ShowSQLCode in IBDataBaseErrorMessages) or
         (ShowSQLMessage in IBDataBaseErrorMessages) then
        usr_msg := usr_msg + CRLF;
      while (GetGDSLibrary.isc_interprete(local_buffer, status_vector) > 0) do
      begin
        if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
          usr_msg := usr_msg + CRLF;
        usr_msg := usr_msg + Marshal.PtrToStringAnsi(local_buffer);
      end;
    end;
    if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
      Delete(usr_msg, Length(usr_msg), 1);
    MonitorHook.SendError(IntToStr(sqlcode) + ' ' + IntToStr(IBErrorCode) + ' ' + usr_msg);
    if sqlcode <> -551 then
      raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg)
    else
      raise EIBInterBaseRoleError.Create(sqlcode, IBErrorCode, usr_msg)
  finally
    Marshal.FreeHGlobal(local_buffer);
    Marshal.FreeHGlobal(status_vector);
  end;
end;

function CheckStatusVector(ErrorCodes : array of ISC_STATUS) : Boolean;
var
  i, j : Integer;
  p : IntPtr;
begin
  result := False;
  j := 0;
  p := StatusVector;
  while (Marshal.ReadInt32(p, j) <> 0) and (not result) do
    case Marshal.ReadInt32(p, j) of
      3: Inc(j , 3);
      1, 4:
      begin
        Inc(j);
        i := 0;
        while (i <= High(ErrorCodes)) and (not result) do
        begin
          result := Marshal.ReadInt32(p, j) = ErrorCodes[i];
          Inc(i);
        end;
        Inc(j);
      end;
      else
        Inc(j, 2);
    end;
end;

function StatusVectorAsText : string;
var
  p: PISC_STATUS;

  function NextP(i: Integer): PISC_STATUS;
  begin
    Result := Marshal.ReadIntPtr(p, i);
  end;

begin
  p := StatusVector;
  result := '';
  while (p <> nil) do
    if (Marshal.ReadInt32(p) = 3) then
    begin
      result := result + Format('%d %d %d', [Marshal.ReadInt32(p),
             Marshal.ReadInt32(NextP(1)), Marshal.ReadInt32(NextP(1))]) + CRLF;
      NextP(1);
    end
    else begin
      result := result + Format('%d %d', [Marshal.ReadInt32(p),
                Marshal.ReadInt32(NextP(1))]) + CRLF;
      NextP(1);
    end;
end;

{ EIBError }
constructor EIBError.Create(ASQLCode: Long; Msg: string);
begin
  inherited Create(Msg);
  FSQLCode := ASQLCode;
end;

constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
begin
  inherited Create(Msg);
  FSQLCode :=  ASQLCode;
  FIBErrorCode := AIBErrorCode;
end;

procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
begin
  EnterCriticalSection(IBCS);
  try
    IBDataBaseErrorMessages := Value;
  finally
    LeaveCriticalSection(IBCS);
  end;
end;

function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
begin
  EnterCriticalSection(IBCS);
  try
    result := IBDataBaseErrorMessages;
  finally
    LeaveCriticalSection(IBCS);
  end;
end;

{ TISC_STATUS }

constructor TISC_STATUS.Create;
begin
  inherited;
  FStatusVector := Marshal.AllocHGlobal(20 * SizeOf(TStatusVector));
end;

destructor TISC_STATUS.Destroy;
begin
  Marshal.FreeHGlobal(FStatusVector);
  inherited;
end;

initialization
//  IsMultiThread := True;
   InitializeCriticalSection(IBCS);
   IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];

finalization
   DeleteCriticalSection(IBCS);
 end.
