trunk/runtime/IB.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise 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.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011                                                 }
{                                                                        }
{************************************************************************}

unit IB;

{$Mode Delphi}

interface

uses
{$IFDEF WINDOWS }
  Windows,
{$ELSE}
  unix,
{$ENDIF}
  SysUtils, Classes, 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);
  EIBClientError            = 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,
    ibxeSV5APIError,
    ibxeThreadFailed,
    ibxeFieldSizeError,
    ibxeTransactionNotEnding,
    ibxeDscInfoTokenMissing
    );

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

  {TResultBuffer inspired by IBPP RB class - access a isc_dsql_sql_info result buffer}

  TResultBuffer = class
  private
    mBuffer: PChar;
    mSize: short;
    function FindToken(token: char): PChar; overload;
    function FindToken(token: char; subtoken: char): PChar; overload;
  public
    constructor Create(aSize: integer = 1024);
    destructor Destroy; override;
    function Size: short;
    procedure Reset;
    function GetValue(token: char): integer; overload;
    function GetValue(token: char; subtoken: char): integer; overload;
    function GetCountValue(token: char): integer;
    function GetBool(token: char): boolean;
    function GetString(token: char; var data: string): integer;
    function buffer: PChar;
  end;

const
  IBPalette1 = 'Firebird'; {do not localize}
  IBPalette2 = 'Firebird Admin'; {do not localize}
  IBPalette3 = 'Firebird Data Controls';   {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,
    SSV5APIError,
    SThreadFailed,
    SFieldSizeError,
    STransactionNotEnding,
    SDscInfoTokenMissing
  );

var
  IBCS: TRTLCriticalSection;

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

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

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

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

implementation

uses
  IBIntf, IBHeader;

var
  IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
threadvar
  FStatusVector : TStatusVector;

procedure IBAlloc(var P; OldSize, NewSize: Integer);
var
  i: Integer;
begin
  ReallocMem(Pointer(P), NewSize);
  for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
end;

procedure IBError(ErrMess: TIBClientError; const Args: array of const);
begin
  raise EIBClientError.Create(Ord(ErrMess),
                              Format(IBErrorMessages[ErrMess], Args));
end;

procedure IBDataBaseError;
var
  sqlcode: Long;
  IBErrorCode: Long;
  local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
  usr_msg: string;
  status_vector: PISC_STATUS;
  IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
begin
  usr_msg := '';

  { Get a local reference to the status vector.
    Get a local copy of the IBDataBaseErrorMessages options.
    Get the SQL error code }
  status_vector := StatusVector;
  IBErrorCode := StatusVectorArray[1];
  IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
  sqlcode := isc_sqlcode(status_vector);

  if (ShowSQLCode in IBDataBaseErrorMessages) then
    usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
  Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
  if (ShowSQLMessage in IBDataBaseErrorMessages) then
  begin
    isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
    if (ShowSQLCode in IBDataBaseErrorMessages) then
      usr_msg := usr_msg + CRLF;
    usr_msg := usr_msg + strpas(local_buffer);
  end;

  if (ShowIBMessage in IBDataBaseErrorMessages) then
  begin
    if (ShowSQLCode in IBDataBaseErrorMessages) or
       (ShowSQLMessage in IBDataBaseErrorMessages) then
      usr_msg := usr_msg + CRLF;
    while (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 + strpas(local_buffer);
    end;
  end;
  if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
    Delete(usr_msg, Length(usr_msg), 1);
  raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
end;

{ Return the status vector for the current thread }
function StatusVector: PISC_STATUS;
begin
  result := @FStatusVector;
end;

function StatusVectorArray: PStatusVector;
begin
  result := @FStatusVector;
end;

function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
var
  p: PISC_STATUS;
  i: Integer;
  procedure NextP(i: Integer);
  begin
    p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
  end;
begin
  p := @FStatusVector;
  result := False;
  while (p^ <> 0) and (not result) do
    case p^ of
      3: NextP(3);
      1, 4:
      begin
        NextP(1);
        i := 0;
        while (i <= High(ErrorCodes)) and (not result) do
        begin
          result := p^ = ErrorCodes[i];
          Inc(i);
        end;
        NextP(1);
      end;
      else
        NextP(2);
    end;
end;

function StatusVectorAsText: string;
var
  p: PISC_STATUS;
  function NextP(i: Integer): PISC_STATUS;
  begin
    p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
    result := p;
  end;
begin
  p := @FStatusVector;
  result := '';
  while (p^ <> 0) do
    if (p^ = 3) then
    begin
      result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
      NextP(1);
    end
    else begin
      result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
      NextP(1);
    end;
end;

{ TResultBuffer }

constructor TResultBuffer.Create(aSize: integer);
begin
  inherited Create;
  mSize := aSize;
  GetMem(mBuffer,aSize);
  FillChar(mBuffer^,mSize,255);
end;

destructor TResultBuffer.Destroy;
begin
  if mBuffer <> nil then FreeMem(mBuffer);
  inherited;
end;

function TResultBuffer.buffer: PChar;
begin
  Result := mBuffer;
end;

function TResultBuffer.FindToken(token: char): PChar;
var p: PChar;
    len: integer;
begin
  Result := nil;
  p := mBuffer;

  while p^ <> char(isc_info_end) do
  begin
    if p^ = token then
    begin
      Result := p;
      Exit;
    end;
    len := isc_vax_integer(p+1,2);
    Inc(p,len+3);
  end;
end;

function TResultBuffer.FindToken(token: char; subtoken: char): PChar;
var p: PChar;
    len, inlen: integer;
begin
  Result := nil;
  p := mBuffer;

  while p^ <> char(isc_info_end) do
  begin
    if p^ = token then
    begin
      {Found token, now find subtoken}
      inlen := isc_vax_integer(p+1, 2);
      Inc(p,3);
      while inlen > 0 do
      begin
        if p^ = subtoken then
        begin
          Result := p;
          Exit;
        end;
        len := isc_vax_integer(p+1, 2);
        Inc(p,len + 3);
        Dec(inlen,len + 3);
      end;
      Exit;
    end;
    len := isc_vax_integer(p+1, 2);
    inc(p,len+3);
  end;
end;

function TResultBuffer.GetBool(token: char): boolean;
var aValue: integer;
    p: PChar;
begin
  p := FindToken(token);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  aValue := isc_vax_integer(p+1, 4);
  Result := aValue <> 0;
end;

function TResultBuffer.GetCountValue(token: char): integer;
var len: integer;
    p: PChar;
begin
  {Specifically used on tokens like isc_info_insert_count and the like
   which return detailed counts per relation. We sum up the values.}

  p := FindToken(token);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  {len is the number of bytes in the following array}

  len := isc_vax_integer(p+1, 2);
  Inc(p,3);
  Result := 0;
  while len > 0 do
  begin
    {Each array item is 6 bytes : 2 bytes for the relation_id which
     we skip, and 4 bytes for the count value which we sum up across
     all tables.}

     Inc(Result,isc_vax_integer(p+2, 4));
     Inc(p,6);
     Dec(len,6);
  end;
end;

function TResultBuffer.GetString(token: char; var data: string): integer;
var p: PChar;
begin
  Result := 0;
  p := FindToken(token);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  Result := isc_vax_integer(p+1, 2);
  SetString(data,p+3,Result);
end;

function TResultBuffer.GetValue(token: char): integer;
var len: integer;
    p: PChar;
begin
  Result := 0;
  p := FindToken(token);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  len := isc_vax_integer(p+1, 2);
  if (len <> 0) then
    Result := isc_vax_integer(p+3, len);
end;

function TResultBuffer.GetValue(token: char; subtoken: char): integer;
var len: integer;
    p: PChar;
begin
  Result := 0;
  p := FindToken(token, subtoken);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  len := isc_vax_integer(p+1, 2);
  if (len <> 0) then
    Result := isc_vax_integer(p+3, len);
end;

function TResultBuffer.Size: short;
begin
  Result := mSize;
end;

procedure TResultBuffer.Reset;
begin
  if mBuffer <> nil then FreeMem(mBuffer);
  GetMem(mBuffer,mSize);
  FillChar(mBuffer^,mSize,255);
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;

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

finalization
  DoneCriticalSection(IBCS);

end.
Revision:	27
Committed:	Tue Apr 14 13:10:23 2015 UTC (9 years, 7 months ago) by tony
Content type:	text/x-pascal
File size:	19541 byte(s)
Log Message:	Committing updates for Release R1-2-3
#	Content
1	{************************************************************************}
2	{ }
3	{ Borland Delphi Visual Component Library }
4	{ InterBase Express core components }
5	{ }
6	{ Copyright (c) 1998-2000 Inprise Corporation }
7	{ }
8	{ InterBase Express is based in part on the product }
9	{ Free IB Components, written by Gregory H. Deatz for }
10	{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11	{ Free IB Components is used under license. }
12	{ }
13	{ The contents of this file are subject to the InterBase }
14	{ Public License Version 1.0 (the "License"); you may not }
15	{ use this file except in compliance with the License. You }
16	{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	{ Software distributed under the License is distributed on }
18	{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19	{ express or implied. See the License for the specific language }
20	{ governing rights and limitations under the License. }
21	{ The Original Code was created by InterBase Software Corporation }
22	{ and its successors. }
23	{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24	{ Corporation. All Rights Reserved. }
25	{ Contributor(s): Jeff Overcash }
26	{ }
27	{ IBX For Lazarus (Firebird Express) }
28	{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	{ Portions created by MWA Software are copyright McCallum Whyman }
30	{ Associates Ltd 2011 }
31	{ }
32	{************************************************************************}
33
34	unit IB;
35
36	{$Mode Delphi}
37
38	interface
39
40	uses
41	{$IFDEF WINDOWS }
42	Windows,
43	{$ELSE}
44	unix,
45	{$ENDIF}
46	SysUtils, Classes, IBExternals, IBUtils, DB, IBXConst;
47
48	type
49	TTraceFlag = (tfQPrepare, tfQExecute, tfQFetch, tfError, tfStmt, tfConnect,
50	tfTransact, tfBlob, tfService, tfMisc);
51	TTraceFlags = set of TTraceFlag;
52
53	EIBError = class(EDatabaseError)
54	private
55	FSQLCode: Long;
56	FIBErrorCode: Long;
57	public
58	constructor Create(ASQLCode: Long; Msg: string); overload;
59	constructor Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string); overload;
60	property SQLCode: Long read FSQLCode;
61	property IBErrorCode: Long read FIBErrorCode;
62	end;
63
64	EIBInterBaseError = class(EIBError);
65	EIBClientError = class(EIBError);
66
67	TIBDataBaseErrorMessage = (ShowSQLCode,
68	ShowIBMessage,
69	ShowSQLMessage);
70	TIBDataBaseErrorMessages = set of TIBDataBaseErrorMessage;
71	TIBClientError = (
72	ibxeUnknownError,
73	ibxeInterBaseMissing,
74	ibxeInterBaseInstallMissing,
75	ibxeIB60feature,
76	ibxeNotSupported,
77	ibxeNotPermitted,
78	ibxeFileAccessError,
79	ibxeConnectionTimeout,
80	ibxeCannotSetDatabase,
81	ibxeCannotSetTransaction,
82	ibxeOperationCancelled,
83	ibxeDPBConstantNotSupported,
84	ibxeDPBConstantUnknown,
85	ibxeTPBConstantNotSupported,
86	ibxeTPBConstantUnknown,
87	ibxeDatabaseClosed,
88	ibxeDatabaseOpen,
89	ibxeDatabaseNameMissing,
90	ibxeNotInTransaction,
91	ibxeInTransaction,
92	ibxeTimeoutNegative,
93	ibxeNoDatabasesInTransaction,
94	ibxeUpdateWrongDB,
95	ibxeUpdateWrongTR,
96	ibxeDatabaseNotAssigned,
97	ibxeTransactionNotAssigned,
98	ibxeXSQLDAIndexOutOfRange,
99	ibxeXSQLDANameDoesNotExist,
100	ibxeEOF,
101	ibxeBOF,
102	ibxeInvalidStatementHandle,
103	ibxeSQLOpen,
104	ibxeSQLClosed,
105	ibxeDatasetOpen,
106	ibxeDatasetClosed,
107	ibxeUnknownSQLDataType,
108	ibxeInvalidColumnIndex,
109	ibxeInvalidParamColumnIndex,
110	ibxeInvalidDataConversion,
111	ibxeColumnIsNotNullable,
112	ibxeBlobCannotBeRead,
113	ibxeBlobCannotBeWritten,
114	ibxeEmptyQuery,
115	ibxeCannotOpenNonSQLSelect,
116	ibxeNoFieldAccess,
117	ibxeFieldReadOnly,
118	ibxeFieldNotFound,
119	ibxeNotEditing,
120	ibxeCannotInsert,
121	ibxeCannotPost,
122	ibxeCannotUpdate,
123	ibxeCannotDelete,
124	ibxeCannotRefresh,
125	ibxeBufferNotSet,
126	ibxeCircularReference,
127	ibxeSQLParseError,
128	ibxeUserAbort,
129	ibxeDataSetUniDirectional,
130	ibxeCannotCreateSharedResource,
131	ibxeWindowsAPIError,
132	ibxeColumnListsDontMatch,
133	ibxeColumnTypesDontMatch,
134	ibxeCantEndSharedTransaction,
135	ibxeFieldUnsupportedType,
136	ibxeCircularDataLink,
137	ibxeEmptySQLStatement,
138	ibxeIsASelectStatement,
139	ibxeRequiredParamNotSet,
140	ibxeNoStoredProcName,
141	ibxeIsAExecuteProcedure,
142	ibxeUpdateFailed,
143	ibxeNotCachedUpdates,
144	ibxeNotLiveRequest,
145	ibxeNoProvider,
146	ibxeNoRecordsAffected,
147	ibxeNoTableName,
148	ibxeCannotCreatePrimaryIndex,
149	ibxeCannotDropSystemIndex,
150	ibxeTableNameMismatch,
151	ibxeIndexFieldMissing,
152	ibxeInvalidCancellation,
153	ibxeInvalidEvent,
154	ibxeMaximumEvents,
155	ibxeNoEventsRegistered,
156	ibxeInvalidQueueing,
157	ibxeInvalidRegistration,
158	ibxeInvalidBatchMove,
159	ibxeSQLDialectInvalid,
160	ibxeSPBConstantNotSupported,
161	ibxeSPBConstantUnknown,
162	ibxeServiceActive,
163	ibxeServiceInActive,
164	ibxeServerNameMissing,
165	ibxeQueryParamsError,
166	ibxeStartParamsError,
167	ibxeOutputParsingError,
168	ibxeUseSpecificProcedures,
169	ibxeSQLMonitorAlreadyPresent,
170	ibxeCantPrintValue,
171	ibxeEOFReached,
172	ibxeEOFInComment,
173	ibxeEOFInString,
174	ibxeParamNameExpected,
175	ibxeSuccess,
176	ibxeDelphiException,
177	ibxeNoOptionsSet,
178	ibxeNoDestinationDirectory,
179	ibxeNosourceDirectory,
180	ibxeNoUninstallFile,
181	ibxeOptionNeedsClient,
182	ibxeOptionNeedsServer,
183	ibxeInvalidOption,
184	ibxeInvalidOnErrorResult,
185	ibxeInvalidOnStatusResult,
186	ibxeDPBConstantUnknownEx,
187	ibxeTPBConstantUnknownEx,
188	ibxeSV5APIError,
189	ibxeThreadFailed,
190	ibxeFieldSizeError,
191	ibxeTransactionNotEnding,
192	ibxeDscInfoTokenMissing
193	);
194
195	TStatusVector = array[0..19] of ISC_STATUS;
196	PStatusVector = ^TStatusVector;
197
198	{TResultBuffer inspired by IBPP RB class - access a isc_dsql_sql_info result buffer}
199
200	TResultBuffer = class
201	private
202	mBuffer: PChar;
203	mSize: short;
204	function FindToken(token: char): PChar; overload;
205	function FindToken(token: char; subtoken: char): PChar; overload;
206	public
207	constructor Create(aSize: integer = 1024);
208	destructor Destroy; override;
209	function Size: short;
210	procedure Reset;
211	function GetValue(token: char): integer; overload;
212	function GetValue(token: char; subtoken: char): integer; overload;
213	function GetCountValue(token: char): integer;
214	function GetBool(token: char): boolean;
215	function GetString(token: char; var data: string): integer;
216	function buffer: PChar;
217	end;
218
219	const
220	IBPalette1 = 'Firebird'; {do not localize}
221	IBPalette2 = 'Firebird Admin'; {do not localize}
222	IBPalette3 = 'Firebird Data Controls'; {do not localize}
223
224	IBLocalBufferLength = 512;
225	IBBigLocalBufferLength = IBLocalBufferLength * 2;
226	IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
227
228	IBErrorMessages: array[TIBClientError] of string = (
229	SUnknownError,
230	SInterBaseMissing,
231	SInterBaseInstallMissing,
232	SIB60feature,
233	SNotSupported,
234	SNotPermitted,
235	SFileAccessError,
236	SConnectionTimeout,
237	SCannotSetDatabase,
238	SCannotSetTransaction,
239	SOperationCancelled,
240	SDPBConstantNotSupported,
241	SDPBConstantUnknown,
242	STPBConstantNotSupported,
243	STPBConstantUnknown,
244	SDatabaseClosed,
245	SDatabaseOpen,
246	SDatabaseNameMissing,
247	SNotInTransaction,
248	SInTransaction,
249	STimeoutNegative,
250	SNoDatabasesInTransaction,
251	SUpdateWrongDB,
252	SUpdateWrongTR,
253	SDatabaseNotAssigned,
254	STransactionNotAssigned,
255	SXSQLDAIndexOutOfRange,
256	SXSQLDANameDoesNotExist,
257	SEOF,
258	SBOF,
259	SInvalidStatementHandle,
260	SSQLOpen,
261	SSQLClosed,
262	SDatasetOpen,
263	SDatasetClosed,
264	SUnknownSQLDataType,
265	SInvalidColumnIndex,
266	SInvalidParamColumnIndex,
267	SInvalidDataConversion,
268	SColumnIsNotNullable,
269	SBlobCannotBeRead,
270	SBlobCannotBeWritten,
271	SEmptyQuery,
272	SCannotOpenNonSQLSelect,
273	SNoFieldAccess,
274	SFieldReadOnly,
275	SFieldNotFound,
276	SNotEditing,
277	SCannotInsert,
278	SCannotPost,
279	SCannotUpdate,
280	SCannotDelete,
281	SCannotRefresh,
282	SBufferNotSet,
283	SCircularReference,
284	SSQLParseError,
285	SUserAbort,
286	SDataSetUniDirectional,
287	SCannotCreateSharedResource,
288	SWindowsAPIError,
289	SColumnListsDontMatch,
290	SColumnTypesDontMatch,
291	SCantEndSharedTransaction,
292	SFieldUnsupportedType,
293	SCircularDataLink,
294	SEmptySQLStatement,
295	SIsASelectStatement,
296	SRequiredParamNotSet,
297	SNoStoredProcName,
298	SIsAExecuteProcedure,
299	SUpdateFailed,
300	SNotCachedUpdates,
301	SNotLiveRequest,
302	SNoProvider,
303	SNoRecordsAffected,
304	SNoTableName,
305	SCannotCreatePrimaryIndex,
306	SCannotDropSystemIndex,
307	STableNameMismatch,
308	SIndexFieldMissing,
309	SInvalidCancellation,
310	SInvalidEvent,
311	SMaximumEvents,
312	SNoEventsRegistered,
313	SInvalidQueueing,
314	SInvalidRegistration,
315	SInvalidBatchMove,
316	SSQLDialectInvalid,
317	SSPBConstantNotSupported,
318	SSPBConstantUnknown,
319	SServiceActive,
320	SServiceInActive,
321	SServerNameMissing,
322	SQueryParamsError,
323	SStartParamsError,
324	SOutputParsingError,
325	SUseSpecificProcedures,
326	SSQLMonitorAlreadyPresent,
327	SCantPrintValue,
328	SEOFReached,
329	SEOFInComment,
330	SEOFInString,
331	SParamNameExpected,
332	SSuccess,
333	SDelphiException,
334	SNoOptionsSet,
335	SNoDestinationDirectory,
336	SNosourceDirectory,
337	SNoUninstallFile,
338	SOptionNeedsClient,
339	SOptionNeedsServer,
340	SInvalidOption,
341	SInvalidOnErrorResult,
342	SInvalidOnStatusResult,
343	SDPBConstantUnknownEx,
344	STPBConstantUnknownEx,
345	SSV5APIError,
346	SThreadFailed,
347	SFieldSizeError,
348	STransactionNotEnding,
349	SDscInfoTokenMissing
350	);
351
352	var
353	IBCS: TRTLCriticalSection;
354
355	procedure IBAlloc(var P; OldSize, NewSize: Integer);
356
357	procedure IBError(ErrMess: TIBClientError; const Args: array of const);
358	procedure IBDataBaseError;
359
360	function StatusVector: PISC_STATUS;
361	function StatusVectorArray: PStatusVector;
362	function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
363	function StatusVectorAsText: string;
364
365	procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
366	function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
367
368	implementation
369
370	uses
371	IBIntf, IBHeader;
372
373	var
374	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
375	threadvar
376	FStatusVector : TStatusVector;
377
378	procedure IBAlloc(var P; OldSize, NewSize: Integer);
379	var
380	i: Integer;
381	begin
382	ReallocMem(Pointer(P), NewSize);
383	for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
384	end;
385
386	procedure IBError(ErrMess: TIBClientError; const Args: array of const);
387	begin
388	raise EIBClientError.Create(Ord(ErrMess),
389	Format(IBErrorMessages[ErrMess], Args));
390	end;
391
392	procedure IBDataBaseError;
393	var
394	sqlcode: Long;
395	IBErrorCode: Long;
396	local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
397	usr_msg: string;
398	status_vector: PISC_STATUS;
399	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
400	begin
401	usr_msg := '';
402
403	{ Get a local reference to the status vector.
404	Get a local copy of the IBDataBaseErrorMessages options.
405	Get the SQL error code }
406	status_vector := StatusVector;
407	IBErrorCode := StatusVectorArray[1];
408	IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
409	sqlcode := isc_sqlcode(status_vector);
410
411	if (ShowSQLCode in IBDataBaseErrorMessages) then
412	usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
413	Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
414	if (ShowSQLMessage in IBDataBaseErrorMessages) then
415	begin
416	isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
417	if (ShowSQLCode in IBDataBaseErrorMessages) then
418	usr_msg := usr_msg + CRLF;
419	usr_msg := usr_msg + strpas(local_buffer);
420	end;
421
422	if (ShowIBMessage in IBDataBaseErrorMessages) then
423	begin
424	if (ShowSQLCode in IBDataBaseErrorMessages) or
425	(ShowSQLMessage in IBDataBaseErrorMessages) then
426	usr_msg := usr_msg + CRLF;
427	while (isc_interprete(local_buffer, @status_vector) > 0) do
428	begin
429	if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
430	usr_msg := usr_msg + CRLF;
431	usr_msg := usr_msg + strpas(local_buffer);
432	end;
433	end;
434	if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
435	Delete(usr_msg, Length(usr_msg), 1);
436	raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
437	end;
438
439	{ Return the status vector for the current thread }
440	function StatusVector: PISC_STATUS;
441	begin
442	result := @FStatusVector;
443	end;
444
445	function StatusVectorArray: PStatusVector;
446	begin
447	result := @FStatusVector;
448	end;
449
450	function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
451	var
452	p: PISC_STATUS;
453	i: Integer;
454	procedure NextP(i: Integer);
455	begin
456	p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
457	end;
458	begin
459	p := @FStatusVector;
460	result := False;
461	while (p^ <> 0) and (not result) do
462	case p^ of
463	3: NextP(3);
464	1, 4:
465	begin
466	NextP(1);
467	i := 0;
468	while (i <= High(ErrorCodes)) and (not result) do
469	begin
470	result := p^ = ErrorCodes[i];
471	Inc(i);
472	end;
473	NextP(1);
474	end;
475	else
476	NextP(2);
477	end;
478	end;
479
480	function StatusVectorAsText: string;
481	var
482	p: PISC_STATUS;
483	function NextP(i: Integer): PISC_STATUS;
484	begin
485	p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
486	result := p;
487	end;
488	begin
489	p := @FStatusVector;
490	result := '';
491	while (p^ <> 0) do
492	if (p^ = 3) then
493	begin
494	result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
495	NextP(1);
496	end
497	else begin
498	result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
499	NextP(1);
500	end;
501	end;
502
503	{ TResultBuffer }
504
505	constructor TResultBuffer.Create(aSize: integer);
506	begin
507	inherited Create;
508	mSize := aSize;
509	GetMem(mBuffer,aSize);
510	FillChar(mBuffer^,mSize,255);
511	end;
512
513	destructor TResultBuffer.Destroy;
514	begin
515	if mBuffer <> nil then FreeMem(mBuffer);
516	inherited;
517	end;
518
519	function TResultBuffer.buffer: PChar;
520	begin
521	Result := mBuffer;
522	end;
523
524	function TResultBuffer.FindToken(token: char): PChar;
525	var p: PChar;
526	len: integer;
527	begin
528	Result := nil;
529	p := mBuffer;
530
531	while p^ <> char(isc_info_end) do
532	begin
533	if p^ = token then
534	begin
535	Result := p;
536	Exit;
537	end;
538	len := isc_vax_integer(p+1,2);
539	Inc(p,len+3);
540	end;
541	end;
542
543	function TResultBuffer.FindToken(token: char; subtoken: char): PChar;
544	var p: PChar;
545	len, inlen: integer;
546	begin
547	Result := nil;
548	p := mBuffer;
549
550	while p^ <> char(isc_info_end) do
551	begin
552	if p^ = token then
553	begin
554	{Found token, now find subtoken}
555	inlen := isc_vax_integer(p+1, 2);
556	Inc(p,3);
557	while inlen > 0 do
558	begin
559	if p^ = subtoken then
560	begin
561	Result := p;
562	Exit;
563	end;
564	len := isc_vax_integer(p+1, 2);
565	Inc(p,len + 3);
566	Dec(inlen,len + 3);
567	end;
568	Exit;
569	end;
570	len := isc_vax_integer(p+1, 2);
571	inc(p,len+3);
572	end;
573	end;
574
575	function TResultBuffer.GetBool(token: char): boolean;
576	var aValue: integer;
577	p: PChar;
578	begin
579	p := FindToken(token);
580
581	if p = nil then
582	IBError(ibxeDscInfoTokenMissing,[token]);
583
584	aValue := isc_vax_integer(p+1, 4);
585	Result := aValue <> 0;
586	end;
587
588	function TResultBuffer.GetCountValue(token: char): integer;
589	var len: integer;
590	p: PChar;
591	begin
592	{Specifically used on tokens like isc_info_insert_count and the like
593	which return detailed counts per relation. We sum up the values.}
594
595	p := FindToken(token);
596
597	if p = nil then
598	IBError(ibxeDscInfoTokenMissing,[token]);
599
600	{len is the number of bytes in the following array}
601
602	len := isc_vax_integer(p+1, 2);
603	Inc(p,3);
604	Result := 0;
605	while len > 0 do
606	begin
607	{Each array item is 6 bytes : 2 bytes for the relation_id which
608	we skip, and 4 bytes for the count value which we sum up across
609	all tables.}
610
611	Inc(Result,isc_vax_integer(p+2, 4));
612	Inc(p,6);
613	Dec(len,6);
614	end;
615	end;
616
617	function TResultBuffer.GetString(token: char; var data: string): integer;
618	var p: PChar;
619	begin
620	Result := 0;
621	p := FindToken(token);
622
623	if p = nil then
624	IBError(ibxeDscInfoTokenMissing,[token]);
625
626	Result := isc_vax_integer(p+1, 2);
627	SetString(data,p+3,Result);
628	end;
629
630	function TResultBuffer.GetValue(token: char): integer;
631	var len: integer;
632	p: PChar;
633	begin
634	Result := 0;
635	p := FindToken(token);
636
637	if p = nil then
638	IBError(ibxeDscInfoTokenMissing,[token]);
639
640	len := isc_vax_integer(p+1, 2);
641	if (len <> 0) then
642	Result := isc_vax_integer(p+3, len);
643	end;
644
645	function TResultBuffer.GetValue(token: char; subtoken: char): integer;
646	var len: integer;
647	p: PChar;
648	begin
649	Result := 0;
650	p := FindToken(token, subtoken);
651
652	if p = nil then
653	IBError(ibxeDscInfoTokenMissing,[token]);
654
655	len := isc_vax_integer(p+1, 2);
656	if (len <> 0) then
657	Result := isc_vax_integer(p+3, len);
658	end;
659
660	function TResultBuffer.Size: short;
661	begin
662	Result := mSize;
663	end;
664
665	procedure TResultBuffer.Reset;
666	begin
667	if mBuffer <> nil then FreeMem(mBuffer);
668	GetMem(mBuffer,mSize);
669	FillChar(mBuffer^,mSize,255);
670	end;
671
672
673	{ EIBError }
674	constructor EIBError.Create(ASQLCode: Long; Msg: string);
675	begin
676	inherited Create(Msg);
677	FSQLCode := ASQLCode;
678	end;
679
680	constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
681	begin
682	inherited Create(Msg);
683	FSQLCode := ASQLCode;
684	FIBErrorCode := AIBErrorCode;
685	end;
686
687	procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
688	begin
689	EnterCriticalSection(IBCS);
690	try
691	IBDataBaseErrorMessages := Value;
692	finally
693	LeaveCriticalSection(IBCS);
694	end;
695	end;
696
697	function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
698	begin
699	EnterCriticalSection(IBCS);
700	try
701	result := IBDataBaseErrorMessages;
702	finally
703	LeaveCriticalSection(IBCS);
704	end;
705	end;
706
707	initialization
708	// IsMultiThread := True;
709	InitCriticalSection(IBCS);
710	IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
711
712	finalization
713	DoneCriticalSection(IBCS);
714
715	end.