zdirorasql.pas

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

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

unit ZDirOraSql;

interface

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

{$INCLUDE ..\Zeos.inc}

type
  { Declare the SQL Object }
  TSqlVar = record
    Handle:    POCIHandle;
    Define:    POCIHandle;
    Data:      PChar;
    DataType:  ub2;
    DataSize:  ub2;
    ColType:   TFieldType;
    TypeCode:  ub2;
    Indicator: sb2;
  end;
  PSqlVar = ^TSqlVar;

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

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

    property Handle: POCIEnv read FHandle write FHandle;
  end;

  { Transaction types }
  TZOraSqlTransIsolation = (otDefault, otReadOnly, otReadWrite, otSerializable);

  { Direct Oracle transaction }
  TDirOraSqlTransact = class (TDirTransact)
  private
    FHandle: POCISvcCtx;
    FError: string;
    FErrorHandle: POCIError;
    FServerHandle: POCIServer;
    FSessionHandle: POCISession;
    FTransHandle: POCITrans;
    FTransIsolation: TZOraSqlTransIsolation;
  protected
    function GetErrorMsg: ShortString; override;
  public
    constructor Create(AConnect: TDirOraSqlConnect);

    function CheckError(Handle: POCIError; 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: POCISvcCtx read FHandle write FHandle;
    property ErrorHandle: POCIError read FErrorHandle write FErrorHandle;
    property TransIsolation: TZOraSqlTransIsolation read FTransIsolation
      write FTransIsolation;
  end;

{ Maximum sqlvar buffer }
const MAX_SQLVAR = 50;

type
  { Direct Interbase Query }
  TDirOraSqlQuery = class(TDirQuery)
  private
    FHandle: POCIStmt;
    FErrorHandle: POCIError;
    FOutSqlVars: PSqlVars;
    FInSqlVars: PSqlVars;
    FError: string;
  protected
    function GetErrorMsg: ShortString; override;
  public
    constructor Create(AConnect: TDirOraSqlConnect; ATransact: TDirOraSqlTransact);
    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  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: POCIStmt read FHandle;
  end;

  { Abstract class for database binary large object }
  TDirOraSqlBlob = class(TDirBlob)
  private
    FPosition: LongInt;
    FError: string;
  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;
  end;

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

{ Convert oracle internal date to date time }
function OraDateToDateTime(Value: PChar): TDateTime;

{ Monitor list }
var MonitorList: TZMonitorList;

implementation

uses ZExtra, ZDBaseConst, Math, ZSqlExtra;

{**************** TDirOraSqlConnect implementation ************}

{ Connect to existed database }
procedure TDirOraSqlConnect.Connect;
begin
  inherited Connect;
  if hDll = 0 then
  begin
    OraSqlLoadLib;
    OCIInitialize(OCI_THREADED, nil, nil, nil, nil);
  end;
{ Connect database }
  FHandle := nil;
  OCIEnvInit(FHandle, OCI_DEFAULT, 0, nil);
  SetStatus(csOk);
  SetActive(True);
end;

{ Disconnect from database }
procedure TDirOraSqlConnect.Disconnect;
begin
  if Active then
  begin
    OCIHandleFree(FHandle, OCI_HTYPE_ENV);
    FHandle := nil;
    SetActive(False);
  end;
end;

{************* TDirOraSqlTransact implementation *************}

{ Class constructor }
constructor TDirOraSqlTransact.Create(AConnect: TDirOraSqlConnect);
begin
  inherited Create;
  FHandle := nil;
  Connect := AConnect;
end;

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

{ Process error status }
function TDirOraSqlTransact.CheckError(Handle: POCIError; Status: Integer;
  var Message: string): Boolean;
var
  ErrorBuf: array[0..255] of Char;
  ErrorCode: SB4;
begin
  Result := False;
  Message := '';
  case Status of
    OCI_SUCCESS:
      Result := True;
    OCI_SUCCESS_WITH_INFO:
      Message := 'OCI_SUCCESS_WITH_INFO';
    OCI_NEED_DATA:
      Message := 'OCI_NEED_DATA';
    OCI_NO_DATA:
      Message := 'OCI_NO_DATA';
    OCI_ERROR:
      begin
        OCIErrorGet(Handle, 1, nil, ErrorCode, ErrorBuf, 255, OCI_HTYPE_ERROR);
        Message := StrPas(ErrorBuf);
      end;
    OCI_INVALID_HANDLE:
      Message := 'OCI_INVALID_HANDLE';
    OCI_STILL_EXECUTING:
      Message := 'OCI_STILL_EXECUTING';
    OCI_CONTINUE:
      Message := 'OCI_CONTINUE';
  end;
end;

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

  FErrorHandle := nil;
  OCIHandleAlloc(OraConnect.Handle, FErrorHandle, OCI_HTYPE_ERROR, 0, nil);
  FServerHandle := nil;
  OCIHandleAlloc(OraConnect.Handle, FServerHandle, OCI_HTYPE_SERVER, 0, nil);
  FHandle := nil;
  OCIHandleAlloc(OraConnect.Handle, FHandle, OCI_HTYPE_SVCCTX, 0, nil);

  Status := OCIServerAttach(FServerHandle, FErrorHandle,
    PChar(string(Connect.Database)), Length(Connect.Database), 0);
  if not CheckError(FErrorHandle, Status, FError) then
    goto ErrorProc;

  OCIAttrSet(FHandle, OCI_HTYPE_SVCCTX, FServerHandle, 0, OCI_ATTR_SERVER,
    FErrorHandle);
  OCIHandleAlloc(OraConnect.Handle, FSessionHandle, OCI_HTYPE_SESSION, 0, nil);
  OCIAttrSet(FSessionHandle, OCI_HTYPE_SESSION, PChar(string(Connect.Login)),
    Length(Connect.Login), OCI_ATTR_USERNAME, FErrorHandle);
  OCIAttrSet(FSessionHandle, OCI_HTYPE_SESSION, PChar(string(Connect.Passwd)),
    Length(Connect.Passwd), OCI_ATTR_PASSWORD, FErrorHandle);
  Status := OCISessionBegin(FHandle, FErrorHandle, FSessionHandle,
    OCI_CRED_RDBMS, OCI_DEFAULT);
  if not CheckError(FErrorHandle, Status, FError) then
    goto ErrorProc;
  OCIAttrSet(FHandle, OCI_HTYPE_SVCCTX, FSessionHandle, 0,
    OCI_ATTR_SESSION, FErrorHandle);
  MonitorList.InvokeEvent(Format('CONNECT %s',[Connect.Database]), 'OK.', False);

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

  { Process error status }
ErrorProc:
  OCIHandleFree(FHandle, OCI_HTYPE_SVCCTX);
  FHandle := nil;
  OCIHandleFree(FErrorHandle, OCI_HTYPE_ERROR);
  FErrorHandle := nil;
  OCIHandleFree(FServerHandle, OCI_HTYPE_SERVER);
  FServerHandle := nil;
  MonitorList.InvokeEvent(Format('CONNECT %s',[Connect.Database]), Error, True);
end;

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

  Status := OCISessionEnd(FHandle, FErrorHandle, FSessionHandle, OCI_DEFAULT);
  CheckError(FErrorHandle, Status, FError);

  Status := OCIServerDetach(FServerHandle, FErrorHandle, OCI_DEFAULT);
  CheckError(FErrorHandle, Status, FError);

  OCIHandleFree(FSessionHandle, OCI_HTYPE_SESSION);
  FSessionHandle := nil;
  OCIHandleFree(FHandle, OCI_HTYPE_SVCCTX);
  FHandle := nil;
  OCIHandleFree(FServerHandle, OCI_HTYPE_SERVER);
  FServerHandle := nil;
  OCIHandleFree(FErrorHandle, OCI_HTYPE_ERROR);
  FErrorHandle := nil;

  SetActive(False);
end;

{ Start transaction }
procedure TDirOraSqlTransact.StartTransaction;
const
  TransIsolationConst: array[TZOraSqlTransIsolation] of Integer = (OCI_DEFAULT,
    OCI_TRANS_READONLY, OCI_TRANS_READWRITE, OCI_TRANS_SERIALIZABLE);
var
  Status: Integer;
  Isolation: Integer;
begin
  { Set startup values }
  SetStatus(csFail);
  if FHandle <> nil then
  begin
    FTransHandle := nil;
    OCIHandleAlloc(TDirOraSqlConnect(Connect).Handle, FTransHandle,
      OCI_HTYPE_TRANS, 0, nil);
    OCIAttrSet(FHandle, OCI_HTYPE_SVCCTX, FTransHandle, 0,
      OCI_ATTR_TRANS, FErrorHandle);

    Isolation := TransIsolationConst[TransIsolation];
    Status := OCITransStart(FHandle, FErrorHandle, 0, Isolation);
    if CheckError(FErrorHandle, Status, FError) then
      SetStatus(csOk);
    MonitorList.InvokeEvent('BEGIN TRANSACTION', Error, Error <> '');
  end;
end;

{ End transaction }
procedure TDirOraSqlTransact.EndTransaction;
var
  Status: Integer;
begin
  { Set startup values }
  SetStatus(csFail);
  if FHandle <> nil then
  begin
    Status := OCITransRollback(FHandle, FErrorHandle, OCI_DEFAULT);
    if CheckError(FErrorHandle, Status, FError) then
      SetStatus(csOk);
    OCIHandleFree(FTransHandle, OCI_HTYPE_TRANS);
    FTransHandle := nil; 
    MonitorList.InvokeEvent('END TRANSACTION', Error, Error <> '');
  end;
end;

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

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

{************* TDirOraSqlQuery implementation ************}

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

{ Class constructor }
constructor TDirOraSqlQuery.Create(AConnect: TDirOraSqlConnect;
  ATransact: TDirOraSqlTransact);
begin
  inherited Create;
  Connect := AConnect;
  Transact := ATransact;
  GetMem(FOutSqlVars, SqlVarsLength(MAX_SQLVAR));
  FillChar(FOutSqlVars^, SqlVarsLength(MAX_SQLVAR), 0);
  FOutSqlVars.AllocNum := MAX_SQLVAR;

  GetMem(FInSqlVars, SqlVarsLength(MAX_SQLVAR));
  FillChar(FInSqlVars^, SqlVarsLength(MAX_SQLVAR), 0);
  FInSqlVars.AllocNum := MAX_SQLVAR;
end;

{ Class destructor }
destructor TDirOraSqlQuery.Destroy;
begin
  inherited Destroy;
  FreeMem(FInSqlVars);
  FreeMem(FOutSqlVars);
end;