zdiribsql.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{              Interbase direct class API                }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2001 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZDirIbSql;

interface

{$IFNDEF LINUX}
{$INCLUDE ..\ZeosDef.inc}
{$ELSE}
{$INCLUDE ../ZeosDef.inc}
{$ENDIF}

uses Windows,Variants, Classes, SysUtils, DB, ZLibIbSql, ZDirSql, 
ZSqlTypes, ZTransact, DbTables;

{$IFNDEF LINUX}
{$INCLUDE ..\Zeos.inc}
{$ELSE}
{$INCLUDE ../Zeos.inc}
{$ENDIF}

type
  { Interbase Parameter Block class }
  TIbParamList = class
  private
    FList: TStringList;

    function GetParam(Index: Word): string;
    procedure SetParam(Index: Word; Value: string);
  public
    constructor Create;
    destructor Destroy; override;

    function IndexOf(Index: Word): Integer;
    procedure Add(Index: Word; Value: string);
    procedure AddParams(Value: TIbParamList);
    procedure Delete(Index: Word);
    procedure Clear;

    procedure GenerateDPB(var DPB: string; var DPBLength: Word);
    procedure GenerateTPB(var TPB: string; var TPBLength: Word);

    property Params[Index: Word]: string read GetParam write SetParam;
  end;

  { Interbase status array }
  ARRAY_ISC_STATUS = array[0..20] of ISC_STATUS;
  PARRAY_ISC_STATUS = ^ARRAY_ISC_STATUS;

  { Direct connection to Interbase database }
  TDirIbSqlConnect = class(TDirConnect)
  private
    FHandle: TISC_DB_HANDLE;
    FStatusVector: ARRAY_ISC_STATUS;
    FParams: TIbParamList;
    FDialect: Word;

    function HasError: Boolean;
  protected
    function GetErrorMsg: ShortString; override;
    function GetFullDbName: string;
    function CheckResult(Cmd: string): Boolean;
    function GetStatusVector(Index: Word): ISC_STATUS;
    procedure SetStatusVector(Index: Word; Value: ISC_STATUS);
  public
    constructor Create;
    destructor Destroy; override;

    procedure Connect; override;
    procedure Disconnect; override;
    procedure CreateDatabase(Params: string); override;
    procedure DropDatabase; override;

    property Handle: TISC_DB_HANDLE read FHandle;
    property StatusVector[Index: Word]: ISC_STATUS read GetStatusVector
      write SetStatusVector;
    property Params: TIbParamList read FParams;
    property Dialect: Word read FDialect write FDialect;
  end;

  { Transaction types }
  TZIbSqlTransIsolation = (itDefault, itConcurrency, itConsistency,
    itReadCommitted, itReadCommittedRec);

  { Direct Interbase transaction }
  TDirIbSqlTransact = class(TDirTransact)
  private
    FHandle: TISC_TR_HANDLE;
    FParams: TIbParamList;
    FTransIsolation: TZIbSqlTransIsolation;
  public
    constructor Create(AConnect: TDirIbSqlConnect);
    destructor Destroy; override;

    procedure Open; override;
    procedure Close; override;
    procedure StartTransaction; override;
    procedure EndTransaction; override;
    procedure Commit; override;
    procedure Rollback; override;

    property Handle: TISC_TR_HANDLE read FHandle;
    property Params: TIbParamList read FParams;
    property TransIsolation: TZIbSqlTransIsolation read FTransIsolation
      write FTransIsolation;
  end;

  { Interbase Statement Type }
  TIbSqlStmtType = (stUnknown, stSelect, stInsert, stUpdate, stDelete, stDDL,
    stGetSegment, stPutSegment, stExecProc, stStartTrans, stCommit, stRollback,
    stSelectForUpdate, stSetGenerator);

  TProcParamType = (ppInput, ppOutput);
  TProcParamTypes = set of TProcParamType;

{ Maximum xsqlvar buffer }
const
  MAX_XSQLVAR = 3;
  NULL_FLAG: SmallInt = ISC_NULL;

type

  { Direct Interbase Query }
  TDirIbSqlQuery = class(TDirQuery)
  private
    FHandle: TISC_STMT_HANDLE;
    FOutSqlDa: PXSQLDA;
    FInSqlDa: PXSQLDA;

    FPrepared: Boolean;
    FStatementType: TIbSqlStmtType;

    function GetPlan: string;
    function SqlStatementType: Boolean;
    function SqlAffectedRows: Integer;
    procedure AbortOnError;

    function FreeStatement: Boolean;
  protected
    function GetErrorMsg: ShortString; override;

    procedure UpdateParams(Params: TParams);
    function PrepareStatement: Boolean;
    function ExecStatement: Boolean;
  public
    constructor Create(AConnect: TDirIbSqlConnect; ATransact: TDirIbSqlTransact);
    destructor Destroy; override;

    function Execute: LongInt; override;
    function ExecuteImmediate: LongInt;

    function ExecuteParams(Params: TVarRecArray;
      ParamCount: Integer): LongInt; override;

    procedure Open; override;
    procedure Close; override;
    function CreateBlobObject: TDirBlob; override;

    procedure ShowDatabases(DatabaseName: ShortString); override;
    procedure ShowTables(TableName: ShortString); override;
    procedure ShowColumns(TableName, ColumnName: ShortString); override;
    procedure ShowIndexes(TableName: ShortString); override;
    procedure ShowProcs(ProcName: ShortString);
    procedure ShowProcsParams(ProcName: ShortString);

    procedure First; override;
    procedure Last; override;
    procedure Prev; override;
    procedure Next; override;
    procedure Go(Num: Integer); override;

    function FieldCount: Integer; override;
    function RecordCount: Integer; override;

    function FieldName(FieldNum: Integer): ShortString; override;
    function FieldSize(FieldNum: Integer): Integer; override;
    function FieldMaxSize(FieldNum: Integer): Integer; override;
    function FieldDecimals(FieldNum: Integer): Integer; override;
    function FieldType(FieldNum: Integer): Integer; override;
    function FieldDataType(FieldNum: Integer): TFieldType; override;
    function FieldIsNull(FieldNum: Integer): Boolean; override;
    function FieldReadOnly(FieldNum: Integer): Boolean; override;
    function Field(FieldNum: Integer): string; override;
    function FieldBuffer(FieldNum: Integer): PChar; override;

    function FieldSubType(FieldNum: Integer): Integer;
    function FieldValue(FieldNum: Integer): Variant;
    function GetFieldValue(FieldNum: Integer; var Buffer): boolean;

    function StringToSql(Value: string): string; override;

    property Handle: TISC_STMT_HANDLE read FHandle;
    property Prepared: Boolean read FPrepared;
    property Plan: string read GetPlan;
  end;

  { Class for interbase large object }
  TDirIbSqlBlob = class(TDirBlob)
  private
    FBlobHandle: TISC_BLOB_HANDLE;
  public
    constructor Create(AConnect: TDirConnect; ATransact: TDirTransact;
      AHandle: TBlobHandle);

    procedure Open(Mode: Integer); override;
    procedure Close; override;
    procedure CreateBlob; override;
    procedure DropBlob; override;

    function Read(Buffer: PChar; Length: Integer): Integer; override;
    function Write(Buffer: PChar; Length: Integer): Integer; override;

    property BlobHandle: TISC_BLOB_HANDLE read FBlobHandle;
  end;

  TDirIbSqlArray = class(TDirBlob)
  private
    FArrayDesc: TISC_ARRAY_DESC;
    FSQLVAR: PXSQLVAR;
  public
    constructor Create(AConnect: TDirConnect; ATransact: TDirTransact;
      AHandle: TBlobHandle; ASQLVAR: PXSQLVAR);

    procedure Open(Mode: Integer); override;
    procedure Close; override;
    procedure CreateBlob; override;
    procedure DropBlob; override;

    function Read(Buffer: PChar; Length: Integer): Integer; override;
    function Write(Buffer: PChar; Length: Integer): Integer; override;
  end;

  {TDirNotify}
  TDirIbSqlNotify = class(TDirNotify)
  private
    { IB API call parameters }
    WhichEvent: Integer;
    EventID: ISC_LONG;
    EventBuffer: PChar;
    EventBufferLen: SmallInt;
    ResultBuffer: PChar;

    FEvents: TStrings;
    FParent: TZNotify;
    EventCount: Integer;

    AStatusVector: ARRAY_ISC_STATUS;

    //procedure ProcessEvents;
    procedure UpdateResultBuffer(Length: Short; Updated: PChar);
    //procedure DoQueueEvents;
  protected
    function GetErrorMsg: ShortString; override;

    procedure RegisterEvents; virtual;
    procedure UnRegisterEvents; virtual;
  public
    constructor Create(AParent: TZNotify; AConnect: TDirIbSqlConnect; ATransact: TDirIbSqlTransact);
    destructor Destroy; override;

    procedure ListenTo(Event: string); override;
    procedure UnlistenTo(Event: string); override;
    procedure DoNotify(Event: string); override;
    function CheckEvents: string; override;

    property Parent: TZNotify read FParent;
  end;


{ Convert interbase field types to delphi field types }
function IbSqlToDelphiType(Value, SubType, Precision: Integer): TFieldType;

function QuoteIdentifier(Dialect: Integer; Value: string): string;

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

{ Monitor list }
var
  MonitorList: TZMonitorList;

implementation

uses ZExtra, ZDBaseConst, Math, ZSqlExtra;

{*************** TIbParamList class implementation ***************}

{ Class constructor }
constructor TIbParamList.Create;
begin
  FList := TStringList.Create;
end;

{ Class destructor }
destructor TIbParamList.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;

{ Get parameter }
function TIbParamList.GetParam(Index: Word): string;
var
  N: Integer;
begin
  N := IndexOf(Index);
  if N >= 0 then
    Result := FList[N]
  else
    Result := '';
end;

{ Set parameter }
procedure TIbParamList.SetParam(Index: Word; Value: string);
begin
  Add(Index, Value);
end;

{ Assign a value }
procedure TIbParamList.AddParams(Value: TIbParamList);
begin
  FList.AddStrings(Value.FList);
end;


{ Get param index }
function TIbParamList.IndexOf(Index: Word): Integer;
begin
  Result := FList.IndexOfObject(TObject(Index));
end;

{ Add new parameter }
procedure TIbParamList.Add(Index: Word; Value: string);
var
  N: Integer;
begin
  N := IndexOf(Index);
  if N >= 0 then
    FList[N] := Value
  else
    FList.AddObject(Value, TObject(Index));
end;

{ Delete parameter }
procedure TIbParamList.Delete(Index: Word);
var
  N: Integer;
begin
  N := IndexOf(Index);
  if N >= 0 then
    FList.Delete(N);
end;

{ Clear param list }
procedure TIbParamList.Clear;
begin
  FList.Clear;
end;

{ Fill database parameter block }
procedure TIbParamList.GenerateDPB(var DPB: string; var DPBLength: Word);
var
  I, PValue: Integer;
  ParamNo: Word;
  ParamValue: string;
begin
  DPBLength := 1;
  DPB := Char(isc_dpb_version1);

  for I := 0 to FList.Count - 1 do
  begin
    ParamNo := Word(FList.Objects[I]);
    ParamValue := FList[I];

    case ParamNo of
      isc_dpb_user_name, isc_dpb_password, isc_dpb_password_enc,
      isc_dpb_sys_user_name, isc_dpb_license, isc_dpb_encrypt_key,
      isc_dpb_lc_messages, isc_dpb_lc_ctype, isc_dpb_sql_role_name:
        begin
          DPB := DPB + Char(ParamNo) + Char(Length(ParamValue)) + ParamValue;
          Inc(DPBLength, 2 + Length(ParamValue));
        end;
      isc_dpb_num_buffers, isc_dpb_dbkey_scope, isc_dpb_force_write,
      isc_dpb_no_reserve, isc_dpb_damaged, isc_dpb_verify:
        begin
          DPB := DPB + Char(ParamNo) + #1 + Char(StrToInt(ParamValue));
          Inc(DPBLength, 3);
        end;
      isc_dpb_sweep:
        begin
          DPB := DPB + Char(ParamNo) + #1 + Char(isc_dpb_records);
          Inc(DPBLength, 3);
        end;
      isc_dpb_sweep_interval:
        begin
          PValue := StrToInt(ParamValue);
          DPB := DPB + Char(ParamNo) + #4 + PChar(@PValue)[0] + PChar(@PValue)[1] +
            PChar(@PValue)[2] + PChar(@PValue)[3];
          Inc(DPBLength, 6);
        end;
      isc_dpb_activate_shadow, isc_dpb_delete_shadow, isc_dpb_begin_log,
      isc_dpb_quit_log:
        begin
          DPB := DPB + Char(ParamNo) + #1 + #0;
          Inc(DPBLength, 3);
        end;
    end;
  end;
end;

{ Fill transaction parameter block }
procedure TIbParamList.GenerateTPB(var TPB: string; var TPBLength: Word);
var
  I: Integer;
  ParamNo: Word;
  ParamValue: string;
begin
  if FList.Count = 0 then
  begin
    TPB := '';
    TPBLength := 0;
    Exit;
  end
  else
  begin
    TPB := Char(isc_tpb_version3);
    TPBLength := 1;
  end;

  for I := 0 to FList.Count - 1 do
  begin
    ParamNo := Word(FList.Objects[I]);
    ParamValue := FList[I];

    case ParamNo of
      isc_tpb_consistency, isc_tpb_exclusive, isc_tpb_protected,
      isc_tpb_concurrency, isc_tpb_shared, isc_tpb_wait, isc_tpb_nowait,
      isc_tpb_read, isc_tpb_write, isc_tpb_ignore_limbo,
      isc_tpb_read_committed, isc_tpb_rec_version, isc_tpb_no_rec_version:
        begin
          TPB := TPB + Char(ParamNo);
          Inc(TPBLength, 1);
        end;
      isc_tpb_lock_read, isc_tpb_lock_write:
        begin
          TPB := TPB + Char(ParamNo) + Char(Length(ParamValue)) + ParamValue;
          Inc(TPBLength, Length(ParamValue) + 2);
        end;
    end;
  end;
end;