zdirdb2sql.pas

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

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

unit ZDirDb2Sql;

interface

uses Windows, Classes, SysUtils, Db, ZLibDb2Sql, ZDirSql, ZTransact, ZSqlTypes;

{$INCLUDE ..\Zeos.inc}

type
  { Declare the SQL Object }
  TSqlVar = record
    Name:      string;
    Data:      PChar;
    DataType:  SmallInt;
    DataSize:  SmallInt;
    DataLen:   Integer;
    TypeCode:  SmallInt;
    ColType:   TFieldType;
    Scale:     SmallInt;
  end;
  PSqlVar = ^TSqlVar;

  TSqlVars = record
    AllocNum:  SmallInt;
    ActualNum: SmallInt;
    Variables: array[0..0] of TSqlVar;
  end;
  PSqlVars = ^TSqlVars;

  { Direct connection to Oracle database }
  TDirDb2SqlConnect = class (TDirConnect)
  private
    FHandle: SQLHENV;
  public
    procedure Connect; override;
    procedure Disconnect; override;

    property Handle: SQLHENV read FHandle;
  end;

  { Transaction types }
  TZDb2SqlTransIsolation = (dtDefault, dtReadUncommited, dtReadCommited,
    dtRepeatableRead, dtSerializable);

  { Direct DB2 transaction }
  TDirDb2SqlTransact = class (TDirTransact)
  private
    FHandle: SQLHDBC;
    FError: string;
    FTransIsolation: TZDb2SqlTransIsolation;
  protected
    function GetErrorMsg: ShortString; override;
  public
    constructor Create(AConnect: TDirDb2SqlConnect);

    function CheckError(HandleType: Integer; Handle: SQLHANDLE;
      Status: Integer; var Message: string): Boolean;

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

    property Handle: SQLHDBC read FHandle;
    property TransIsolation: TZDb2SqlTransIsolation read FTransIsolation
      write FTransIsolation;
  end;

{ Maximum sqlvar buffer }
const MAX_SQLVAR = 50;

type
  { Direct DB2 Query }
  TDirDb2SqlQuery = class(TDirQuery)
  private
    FHandle: SQLHSTMT;

    FOutSqlVars: PSqlVars;
    FInSqlVars: PSqlVars;
    FError: string;
  protected
    function GetErrorMsg: ShortString; override;
  public
    constructor Create(AConnect: TDirDb2SqlConnect; ATransact: TDirDb2SqlTransact);
    destructor  Destroy; override;

    function  Execute: LongInt; override;
    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 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  FieldTypeCode(FieldNum: Integer): Integer;
    function  FieldDataType(FieldNum: Integer): TFieldType; override;
    function  FieldIsNull(FieldNum: Integer): Boolean; override;
    function  Field(FieldNum: Integer): string; override;
    function  FieldBuffer(FieldNum: Integer): PChar; override;

    property Handle: SQLHSTMT read FHandle;
  end;

  { Class for interbase large object }
  TDirDb2SqlBlob = class(TDirBlob)
  private
    FPosition: LongInt;
    FError: string;
    FStatementHandle: SQLHSTMT;
    FBlobType: SmallInt;
    FSize: LongInt;
  protected
    function GetErrorMsg: ShortString; override;
    function GetPosition: LongInt; override;
  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 StatementHandle: SQLHSTMT read FStatementHandle;
  end;

{ Convert Db2 field types to delphi field types }
function Db2SqlToDelphiType(Value: string; Size, Prec: Integer;
  var BlobType: TBlobType): TFieldType;

{ Monitor list }
var MonitorList: TZMonitorList;

implementation

uses ZExtra, ZDBaseConst, ZSqlExtra;

{**************** TDirDb2SqlConnect implementation ************}

{ Connect to existed database }
procedure TDirDb2SqlConnect.Connect;
begin
  inherited Connect;
  if hDll = 0 then
  begin
    Db2SqlLoadLib;
  end;
  { Connect database }
  FHandle := 0;
  if SqlAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, @FHandle) = SQL_SUCCESS then
  begin
    SetStatus(csOk);
    SetActive(True);
  end;
end;

{ Disconnect from database }
procedure TDirDb2SqlConnect.Disconnect;
begin
  if Active then
  begin
    SqlFreeHandle(SQL_HANDLE_ENV, FHandle);
    FHandle := 0;
    SetActive(False);
  end;
end;

{************* TDirDb2SqlTransact implementation *************}

{ Class constructor }
constructor TDirDb2SqlTransact.Create(AConnect: TDirDb2SqlConnect);
begin
  inherited Create;
  FHandle := 0;
  Connect := AConnect;
end;

{ Get sql-server error message }
function TDirDb2SqlTransact.GetErrorMsg: ShortString;
begin
  if Status <> csOk then
    Result := FError
  else
    Result := '';
end;

{ Process error status }
function TDirDb2SqlTransact.CheckError(HandleType: Integer; Handle: SQLHANDLE;
  Status: Integer; var Message: string): Boolean;
var
  SqlState: array[0..255] of Char;
  SqlCode: Integer;
  ErrorBuf: array[0..1024] of Char;
  I, ErrorBufLen: SmallInt;
begin
  Result := False;
  Message := '';
  case Status of
    SQL_SUCCESS:
      Result := True;
    SQL_SUCCESS_WITH_INFO:
      begin
        SQLGetDiagRec(HandleType, Handle, 1, SqlState, @SqlCode,
          ErrorBuf, 255, @ErrorBufLen);
        Result := True;
        Message := MemPas(ErrorBuf, ErrorBufLen);
      end;
    SQL_NEED_DATA:
      Message := 'SQL_NEED_DATA';
    SQL_NO_DATA:
      begin
        Result := True;
        Message := 'SQL_NO_DATA';
      end;
    SQL_ERROR:
      begin
        I := 1;
        while (SQLGetDiagRec(HandleType, Handle, I, SqlState, @SqlCode,
          ErrorBuf, 1024, @ErrorBufLen) = SQL_SUCCESS) do
        begin
          if Message <> '' then Message := Message + #13;
          Message := Message + MemPas(ErrorBuf, ErrorBufLen);
          Inc(I);
        end;
      end;
    SQL_INVALID_HANDLE:
      Message := 'SQL_INVALID_HANDLE';
    SQL_STILL_EXECUTING:
      Message := 'SQL_STILL_EXECUTING';
  end;
end;

{ Connect transaction }
procedure TDirDb2SqlTransact.Open;
label ErrorProc;
var
  Status: Integer;
  Db2Connect: TDirDb2SqlConnect;
begin
  inherited Open;
  SetStatus(csFail);
  if not Assigned(Connect) or not Connect.Active then
    Exit;
  Db2Connect := TDirDb2SqlConnect(Connect);

  FHandle := 0;
  Status := SqlAllocHandle(SQL_HANDLE_DBC, DB2Connect.Handle, @FHandle);
  if not CheckError(SQL_HANDLE_DBC, FHandle, Status, FError) then
    goto ErrorProc;

  Status := SqlConnect(FHandle, PChar(string(Connect.Database)), SQL_NTS,
    PChar(string(Connect.Login)), SQL_NTS, PChar(string(Connect.Passwd)), SQL_NTS);
  if not CheckError(SQL_HANDLE_DBC, FHandle, Status, FError) then
    goto ErrorProc;

  MonitorList.InvokeEvent(Format('CONNECT %s',[Connect.Database]), 'OK.', False);

  StartTransaction;
  SetActive(inherited Status = csOk);
  Exit;

  { Process error status }
ErrorProc:
  SqlFreeHandle(SQL_HANDLE_DBC, FHandle);
  FHandle := 0;
  MonitorList.InvokeEvent(Format('CONNECT %s',[Connect.Database]), Error, True);
end;

{ Disconnect transaction }
procedure TDirDb2SqlTransact.Close;
var
  Status: Integer;
begin
  EndTransaction;

  Status := SqlDisconnect(FHandle);
  CheckError(SQL_HANDLE_DBC, FHandle, Status, FError);

  SqlFreeHandle(SQL_HANDLE_DBC, FHandle);
  FHandle := 0;

  SetActive(False);
end;

{ Start transaction }
procedure TDirDB2SqlTransact.StartTransaction;
var
  Status: Integer;
begin
  { Set startup values }
  SetStatus(csFail);
  if FHandle <> 0 then
  begin
    if not TransactSafe then
      Status := SqlSetConnectAttr(FHandle, SQL_ATTR_AUTOCOMMIT,
        Pointer(SQL_AUTOCOMMIT_ON), SQL_NTS)
    else begin
      Status := SqlSetConnectAttr(FHandle, SQL_ATTR_AUTOCOMMIT,
        Pointer(SQL_AUTOCOMMIT_OFF), SQL_NTS);
      case TransIsolation of
        dtReadUncommited:
          Status := SqlSetConnectAttr(FHandle, SQL_ATTR_TXN_ISOLATION,
            Pointer(SQL_TXN_READ_UNCOMMITTED), SQL_NTS);
        dtReadCommited:
          Status := SqlSetConnectAttr(FHandle, SQL_ATTR_TXN_ISOLATION,
            Pointer(SQL_TXN_READ_COMMITTED), SQL_NTS);
        dtRepeatableRead:
          Status := SqlSetConnectAttr(FHandle, SQL_ATTR_TXN_ISOLATION,
            Pointer(SQL_TXN_REPEATABLE_READ), SQL_NTS);
        dtSerializable:
          Status := SqlSetConnectAttr(FHandle, SQL_ATTR_TXN_ISOLATION,
            Pointer(SQL_TXN_SERIALIZABLE), SQL_NTS);
      end;
    end;

    if CheckError(SQL_HANDLE_DBC, FHandle, Status, FError) then
      SetStatus(csOk);
    MonitorList.InvokeEvent('BEGIN TRANSACTION', Error, Error <> '');
  end;
end;

{ End transaction }
procedure TDirDb2SqlTransact.EndTransaction;
var
  Status: Integer;
begin
  { Set startup values }
  SetStatus(csFail);
  if FHandle <> 0 then
  begin
    Status := SQLEndTran(SQL_HANDLE_DBC, FHandle, SQL_ROLLBACK);
    if CheckError(SQL_HANDLE_DBC, FHandle, Status, FError) then
      SetStatus(csOk);
    MonitorList.InvokeEvent('END TRANSACTION', Error, Error <> '');
  end;
end;

{ Commit transaction }
procedure TDirDb2SqlTransact.Commit;
var
  Status: Integer;
begin
  SetStatus(csFail);
  if Active then
  begin
    Status := SQLEndTran(SQL_HANDLE_DBC, FHandle, SQL_COMMIT);
    if CheckError(SQL_HANDLE_DBC, FHandle, Status, FError) then
      SetStatus(csOk);
    MonitorList.InvokeEvent('COMMIT', Error, Error <> '');
  end;
end;

{ Rollback transaction }
procedure TDirDb2SqlTransact.Rollback;
var
  Status: Integer;
begin
  SetStatus(csFail);
  if Active then
  begin
    Status := SQLEndTran(SQL_HANDLE_DBC, FHandle, SQL_ROLLBACK);
    if CheckError(SQL_HANDLE_DBC, FHandle, Status, FError) then
      SetStatus(csOk);
    MonitorList.InvokeEvent('ROLLBACK', Error, Error <> '');
  end;
end;

{************* TDirDb2SqlQuery implementation ************}

{ Count length of SqlVars variable }
function SqlVarsLength(Count: Integer): Integer;
begin
  Result := SizeOf(TSqlVars) + Count * SizeOf(TSqlVar);
end;

{ Class constructor }
constructor TDirDb2SqlQuery.Create(AConnect: TDirDb2SqlConnect;
  ATransact: TDirDb2SqlTransact);
begin
  inherited Create;
  Connect := AConnect;
  Transact := ATransact;

  GetMem(FOutSqlVars, SqlVarsLength(MAX_SQLVAR));