OraClasses.pas - Oracle Data Access Components Copyright …

/EndTask/2008.04.16 ?????/Oracle Data Access Components(ODAC) v6/Source/OraClasses.pas

http://xinhaining-dianjianyiqi-tongxunchengxu.googlecode.com/ · Pascal · 2090 lines · 1557 code · 330 blank · 203 comment · 78 complexity · 9d5a9360d91c8ba693baba823cef1d02 MD5 · raw file
Large files are truncated click here to view the full file

//////////////////////////////////////////////////

//  Oracle Data Access Components

//  Copyright  1998-2006 Core Lab. All right reserved.

//  Oracle Classes

//  Created:            01.03.98

//  Last modified:      16.03.04

//////////////////////////////////////////////////



{$IFNDEF CLR}

{$I Odac.inc}

unit OraClasses;

{$ENDIF}

{$J+}

{$DEFINE _LOCAL_ERROR_HANDLE}  // LOCAL_ERROR_HANDLE

{$IFDEF VER6P}

{$WARN SYMBOL_PLATFORM OFF}

{$ENDIF}



interface

uses

{$IFDEF MSWINDOWS}

  Windows, Messages,

{$ENDIF}

{$IFDEF CLR}

  Variants, WinUtils,

{$ELSE}

  CLRClasses,

{$ENDIF}

{$IFDEF LITE}

  FMTBcd,

{$ENDIF}

  SysUtils, Classes, SyncObjs, MemData, OraCall, OraError, CRAccess, MemUtils;



const

  dtRowId         = 100;

  dtCursor        = 101;

  dtOraBlob       = 102;

  dtOraClob       = 103;

  dtBFILE         = 104;

  dtCFILE         = 105;

  dtLabel         = 106;  // MLSLABEL

  dtFixedChar     = 107;

  dtUndefined     = 108;

  dtTimeStamp     = 109;

  dtTimeStampTZ   = 110;

  dtTimeStampLTZ  = 111;

  dtIntervalYM    = 112;

  dtIntervalDS    = 113;

  dtURowId        = 114;

  dtNumber        = 115;

  dtXML           = 116;

  dtFixedWideChar = 117;

  dtBFloat        = 118;

  dtBDouble       = 119;

  dtNString       = 120;

  dtNWideString   = 121;

  dtNClob         = 122;



// obsolete

  dtBLOBLocator = dtOraBlob;

  dtCLOBLocator = dtOraClob;



// Props

  prNonBlocking       = 50; // bool

  prThreadSafety      = 51; // bool

  prAutoClose         = 55; // bool

  prErrorOffset       = 57; // word

  prMaxStringSize     = 58; // word

  prFieldsAsString    = 59; // bool

  prDateFormat        = 60; // string

  prDeferredLobRead   = 61; // bool

  prConnectMode       = 62; // enum

  prCharLength        = 63; // word

  prCacheLobs         = 64; // bool

  prEnableIntegers    = 65; // bool

  prInternalName      = 66; // string

  prScrollableCursor  = 67; // bool

  prStoreRowId        = 68; // bool

  prCharset           = 69; // word

  prDateLanguage      = 70; // string

  prTimeStampFormat   = 71; // string

  prTimeStampTZFormat = 72; // string

  prRawAsString       = 73; // bool

  prNumberAsString    = 74; // bool

  prNumericCharacters = 75; // string

  prEnableNumbers     = 76; // bool

  prUseUnicode        = 77; // bool

  prIntegerPrecision  = 78; // word;

  prFloatPrecision    = 79; // word;

  prTemporaryLobUpdate= 82; // bool

  prDisconnectMode    = 84; // bool

  prInactiveTimeout   = 85; // integer

  prResumeTimeout     = 86; // integer

  prGlobalCoordinator = 87; // integer

  prTransactionName   = 88; // string

  prIsolationLevel    = 89; // integer

  prDefaultCloseAction= 90; // integer

  prConnectionTimeOut = 91; // integer

  prHasObjectFields   = 92; // bool

  prStatementCache    = 93; // bool

  prStatementCacheSize= 94; // integer

  prEnabled           = 95; // bool

  prTimeout           = 96; // integer

  prPersistent        = 97; // bool

  prOperations        = 98; // set



  RowIdSize = 18;



  MaxBlobSize: longint = 2147483647;



  MaxTransactionIdLength = 64; // Maximum length for TransactionId and BranchQualifier



type

  TOraCursor = class;

  TOraLob = class;

  TOraFile = class;

  TOraTimeStamp = class;

  TOraInterval = class;

  TOraNumber = class;

  TOraParamDesc = class;

  TOCICommand = class;

{$IFNDEF LITE}

  TOCITransaction = class;

{$ENDIF}



{ OraAccess level }



  TTransactionMode = (tmReadOnly, tmReadWrite, tmReadCommitted, tmSerializable);

  TErrorProc = procedure (E: EOraError; var Fail: boolean) of object;

  TConnectMode = (cmNormal, cmSysOper, cmSysDBA);



{ TOraParamDesc }



  TOraParamDesc = class (TParamDesc)

  private

    FValue: IntPtr;

    FActualLengthPtr: IntPtr;

    FDefIndicator: IntPtr;

    FIndicator: IntPtr;

    FTable: boolean;

    FLength: integer;  // Table Length

    FHandle: IntPtr;

    FBindBufferSize: integer;

    FBlobPiece: integer;  // number of piece

    FQuotedName: boolean;

    FLen: integer;

    FTableIndicator: boolean;

    FNational : boolean;

    FHasDefault: boolean;



    function GetActualLength: integer;

    procedure SetActualLength(Value: integer);

    property ActualLength: integer read GetActualLength write SetActualLength;



  protected

    procedure AllocBuffer;

    procedure FreeBuffer;



    procedure CheckRange(Index: integer);



    property Name;

    property DataType;

    property ParamType;

    property Size;



    procedure ClearBindData;



  public

    constructor Create; override;

    destructor Destroy; override;



    procedure SetDataType(Value: word); override;

    procedure SetSize(Value: integer); override;

    procedure SetTable(Value: boolean);

    procedure SetLength(Value: integer);

    procedure SetNational(Value: boolean);

    procedure SetHasDefault(Value: boolean);



  // TEMP for describe

    function GetSize: integer;

    function GetTable: boolean;

    function GetLength: integer;

    function GetNational: boolean;

    function GetHasDefault: boolean;



    function GetIndicator(Index: integer): smallint;

    procedure SetIndicator(Index: integer; Value: smallint);



    function ValuePtr: IntPtr;

    procedure SetValuePtr(Buf: IntPtr);

    function IndicatorPtr: IntPtr;

    procedure SyncIndicator;



    function GetItemAsDateTime(Index: integer): TDateTime;

    procedure SetItemAsDateTime(Index: integer; Value: TDateTime);

    function GetItemAsFloat(Index: integer): double;

    procedure SetItemAsFloat(Index: integer; Value: double);

    function GetItemAsInteger(Index: integer): integer;

    procedure SetItemAsInteger(Index: integer; Value: integer);

    function GetItemAsLargeInt(Index: integer): Int64;

    procedure SetItemAsLargeInt(Index: integer; Value: Int64);

    function GetItemAsString(Index: integer): string;

    procedure SetItemAsString(Index: integer; Value: string);

    function GetItemAsWideString(Index: integer): WideString;

    procedure SetItemAsWideString(Index: integer; Value: WideString);

    function GetItemAsBoolean(Index: integer): boolean;

    procedure SetItemAsBoolean(Index: integer; Value: boolean);

    procedure SetItemAsObject(Index: integer; Value: TSharedObject);

    function GetItemAsObject(Index: integer): TSharedObject;



    function GetItemAsVariant(Index: integer): variant;

    procedure SetItemAsVariant(Index: integer; const Value: variant);



    function GetValue: variant; override;

    procedure SetValue(const Value: variant); override;



    function GetAsBlobRef: TBlob;

    function GetAsCursor: TOraCursor;

    function GetAsOraBlob: TOraLob;

    function GetAsBFile: TOraFile;

    function GetAsTimeStamp: TOraTimeStamp;

    function GetAsInterval: TOraInterval;

    function GetAsNumber: TOraNumber;



    function GetObject: TSharedObject; override;

    procedure SetObject(Value: TSharedObject); override;



    function GetNull: boolean; override;

    procedure SetNull(const Value: boolean); override;

    function GetItemNull(Index: integer): boolean;

    procedure SetItemNull(Index: integer; Value: boolean);

  end;



{ TOCIConnection }



  TRunMethod = procedure of object;

  TEndMethod = procedure(E: Exception) of object;



  TMethodDesc = class

  public

    RunMethod     : TRunMethod;

    EndMethod     : TEndMethod;

  {$IFDEF MSWINDOWS}

    hWindow   :HWND;

  {$ENDIF}

  end;



{$IFDEF LINUX}

  THandle = integer;

{$ENDIF}



  TNlsParamType = (nlsDateLanguage, nlsDateFormat, nlsNumericCharacters, nlsTimeStampFormat,

    nlsTimeStampTZFormat);



  TNlsSessionParam = record

    Name: string;

    Value: string;

    IsUserDefined: boolean;

  end;



  TFailoverCallback = procedure (FailoverState: cardinal; FailoverType: cardinal;

    var Retry: boolean) of object;



  TConnectionType = (ctDefault, ctOCIPooled{$IFDEF MSWINDOWS}{$IFNDEF LITE}, ctMTSPooled{$ENDIF}{$ENDIF});



  TOCIConnection = class (TCRConnection)

  private

    FThreadSafety: boolean;

    FMaxStringSize: word;

    FOCICallStyle: TOCICallStyle;

    FOCICallStyleCommand: TOCICallStyle;

    FNativeHandle: boolean;

    FLastError: integer;

    FConnectMode: TConnectMode;

    FEnableIntegers: boolean;

    FEnableNumbers: boolean;

    FInternalName: string;

    FCommand: TOCICommand;

    FOracleVersionSt: string;

    FOracleVersion: word;

    FProxyConnection : TOCIConnection;

    FDisconnectMode: boolean;

    FConnectionTimeout: integer;

  {$IFNDEF LITE}  

    FTransaction: TOCITransaction;

  {$ENDIF}  

    FOCIPoolName: string;

    FStatementCache: boolean;

    FStatementCacheSize: integer;



  { Charset parameters }

    FCharset: string;

    FCharsetId: word;

    FCharLength: word;

    FQueryCharLength: boolean;

    FUseUnicode: boolean;



  { NLS session parameters }

    FNlsParams: array[TNlsParamType] of TNlsSessionParam;



  { OCI73 }

    LDA: PLDA;

    HDA: PHDA;

  { OCI80 }

    hSvcCtx  : pOCISvcCtx;

    hServer  : pOCIServer;

    hSession : pOCISession;

    hOCIError : pOCIError;  // local error handle

    hOCIEnv   : pOCIEnv;

    hOCIAuthInfo : pOCIAuthInfo;

    //hTrans   : pOCITrans;



    FConnectionType: TConnectionType;



  {$IFDEF MSWINDOWS}

    hBusy: THandle;

    hWindow   :HWND;

  {$ENDIF}



    procedure CheckCommand;

    procedure GetSessionParameters;

    procedure SetNlsParameter(const Name, Value: string);

    function GetMaxStringSize: word;



  protected

    FOnFailover: TFailoverCallback;

    FInTransaction: boolean;



    procedure DoError(E: Exception; var Fail: boolean); override;

    procedure SetStatementCacheSize(Size: integer);

    

    property AutoCommit;

  public

    constructor Create; override;

    destructor Destroy; override;



    procedure CheckOCI;

    procedure CheckOCI73;

    procedure CheckOCI80;



    procedure Check(Status: sword);

    procedure OraError(FOCICallStyle: TOCICallStyle; var ErrorCode: sword; UseCallback: boolean; Component: TObject);



    procedure SetConnectionType(ConnectionType: TConnectionType);

    procedure Connect(const ConnectString: string); override;

    procedure Disconnect; override;

    function GetOracleVersionSt: string;

    function GetOracleVersion: word;



  { Transaction control }

    procedure StartTransaction; override; // (Mode: TTransactionMode);

    procedure Commit; override;

    procedure Rollback; override;



    procedure BreakExec;



  { Multi Thread }

    procedure Busy;

    procedure BusyWait;

    procedure Release;

    function RunThread(RunMethod: TRunMethod; EndMethod: TEndMethod): TThread;

    function StopThread(var hThread: TThread{$IFDEF MSWINDOWS}; APeekMessage: boolean = False{$ENDIF}): boolean;

  {$IFDEF MSWINDOWS}

    procedure AllocWnd;

  {$ENDIF}



  { OCI73 }

    function GetLDA: PLDA;

    procedure SetLDA(Value: PLDA);



  { OCI80 }

    function GetSvcCtx: pOCISvcCtx;

    procedure SetSvcCtx(Value: pOCISvcCtx);

  {$IFDEF MSWINDOWS}  

  {$IFNDEF LITE}

    procedure GetMTSSvcCtx(var OCISvcCtx: pOCISvcCtx);

  {$ENDIF}

  {$ENDIF}



    procedure ChangePassword(NewPassword: string);



    procedure AssignConnect(Source: TOCIConnection);



    procedure SetNonBlocking(Value: boolean); // nonblocking connection

    function GetOCICallStyle: TOCICallStyle;

    procedure SetOCICallStyle(Value: TOCICallStyle);

    function GetOCICallStyleCommand: TOCICallStyle;

    function GetLastError: integer;

    procedure SetLastError(Value: integer);

    procedure GetTableFields(TableName: string; Fields: TStringList);



    function SetProp(Prop: integer; const Value: variant): boolean; override;

    function GetProp(Prop: integer; var Value: variant): boolean; override;



    function CheckIsValid: boolean; override;



  {$IFNDEF LITE}

    procedure ReturnToPool; override;

  {$ENDIF}



    property OnFailover: TFailoverCallback read FOnFailover write FOnFailover;

    property InTransaction: boolean read FInTransaction;



    property ProxyConnection : TOCIConnection read FProxyConnection write FProxyConnection;



    procedure SetClientIdentifier(const Value: string);

  {$IFNDEF LITE}

    property Transaction: TOCITransaction read FTransaction;

  {$ENDIF}  

  end;



{ TCursor }



  TOraCursor = class (TSharedObject)

  private

    FCDA: PCDA;

    phOCIStmt: ppOCIStmt;



    hOCIError: pOCIError;  // local error handle

    hOCIEnv: pOCIEnv;

    FState: TCursorState;

    FOCICallStyle: TOCICallStyle;

    FScrollable: boolean;

    FStatementCache: boolean;

    FPrefetchRows: integer;





    procedure DisablePrefetching;

    function GetCDA: PCDA;

    function GethOCIStmt: pOCIStmt;

    procedure SethOCIStmt(Value: pOCIStmt);

    function GetOCIStmt: pOCIStmt;

    function GetOCIStmtPtr: ppOCIStmt;

    procedure SetOCICallStyle(Value: TOCICallStyle);

    procedure SetPrefetchRows(Value: integer);



    property hOCIStmt: pOCIStmt read GethOCIStmt write SethOCIStmt;



  protected

    procedure CheckOCI;

    procedure CheckOCI73;

    procedure CheckOCI80;

    procedure InternalFreeCursor;



  public

    constructor Create;

    destructor Destroy; override;



    procedure AllocCursor(StatementCache: boolean = False);

    procedure FreeCursor;



    function CanFetch: boolean;



    property CDA: PCDA read GetCDA;

    property OCIStmt: pOCIStmt read GetOCIStmt;

    property OCIStmtPtr: ppOCIStmt read GetOCIStmtPtr;

    property State: TCursorState read FState write FState;

    property OCICallStyle: TOCICallStyle read FOCICallStyle write SetOCICallStyle;

    property PrefetchRows: integer read FPrefetchRows write SetPrefetchRows;

  end;



{$IFDEF MSWINDOWS}

{ TOCIChangeNotification }



  TChangeNotifyEventType = (cneNone, cneStartup, cneShutdown, cneShutdownAny,

    cneDropDB, cneDereg, cneObjChange);



  TCustomNotifyChanges = class

  private

    function GetCount: integer;

  protected

    FItems: array of TObject;

    function CreateItem(ChangeDescriptor: IntPtr): TObject; virtual; abstract;

  public

    constructor Create(OCIColl: pOCIColl);

    destructor Destroy; override;

    property Count: integer read GetCount;

  end;



  TNotifyRowChange = class

  private

    FRowId: string;

    FOperations: TChangeNotifyOperations;

  public

    constructor Create(ChangeDescriptor: IntPtr);

    property RowId: string read FRowId;

    property Operations: TChangeNotifyOperations read FOperations;

  end;



  TNotifyRowChanges = class(TCustomNotifyChanges)

  private

    function GetChanges(Index: integer): TNotifyRowChange;

  protected

    function CreateItem(ChangeDescriptor: IntPtr): TObject; override;

  public

    property Changes[Index: integer]: TNotifyRowChange read GetChanges; default;

  end;



  TNotifyTableChange = class

  private

    FTableName: string;

    FOperations: TChangeNotifyOperations;

    FRowChanges: TNotifyRowChanges;

  public

    constructor Create(ChangeDescriptor: IntPtr);

    destructor Destroy; override;

    property TableName: string read FTableName;

    property Operations: TChangeNotifyOperations read FOperations;

    property RowChanges: TNotifyRowChanges read FRowChanges;

  end;



  TNotifyTableChanges = class(TCustomNotifyChanges)

  private

    function GetChanges(Index: integer): TNotifyTableChange;

  protected

    function CreateItem(ChangeDescriptor: IntPtr): TObject; override;

  public

    property Changes[Index: integer]: TNotifyTableChange read GetChanges; default;

  end;



  TNotifyChange = class

  private

    FNotifyType: TChangeNotifyEventType;

    FTableChanges: TNotifyTableChanges;

  public

    constructor Create(ChangeDescriptor: IntPtr);

    destructor Destroy; override;

    property NotifyType: TChangeNotifyEventType read FNotifyType;

    property TableChanges: TNotifyTableChanges read FTableChanges;

  end;



  TChangeNotifyCallback = procedure(NotifyType: TChangeNotifyEventType;

    TableChanges: TNotifyTableChanges) of object;



  TOCIChangeNotification = class

  private

    FGCHandle: IntPtr;

    FEnabled: boolean;

    FPersistent: boolean;

    FTimeOut: integer;

    FOperations: TChangeNotifyDMLOperations;

    FOnChange: TChangeNotifyCallback;

    hOCISubscription: pOCISubscription;

    hWindow: HWND;



    function GetGCHandle: IntPtr;

    procedure AllocWnd;

    procedure SetEnabled(Value: boolean);

    function CallbackChangeNotify(pCtx: IntPtr; pSubscrHp: pOCISubscription;

      pPayload: IntPtr; iPayloadLen: ub4; pDescriptor: IntPtr; iMode: ub4): sword;



  protected

    property GCHandle: IntPtr read GetGCHandle;



  public

    constructor Create;

    destructor Destroy; override;



    function SetProp(Prop: integer; const Value: variant): boolean;

    function GetProp(Prop: integer; var Value: variant): boolean;



    function GetSubscriptionHandle(Connection: TOCIConnection): pOCISubscription;

    procedure Register(Connection: TOCIConnection);

    procedure Unregister(Connection: TOCIConnection);

    function IsActive: boolean;



    property OnChange: TChangeNotifyCallback read FOnChange write FOnChange;

  end;

{$ENDIF}



{ TOCICommand }



  TOCICommand = class (TCRCommand)

  private

    FCursor: TOraCursor;

    FCursorRef: TOraCursor;

    FOCICallStyle: TOCICallStyle;

    FScanParams: boolean;

    FNonBlocking: boolean;

    FSQLType: word;

    FRowsProcessed: integer;

    FFetchedRows: integer;

    FErrorOffset: word;

    FIterCount: integer;

    FFieldsAsString: boolean;

    FCacheLobs: boolean;

    FStoreRowId: boolean;

    FRowId: string;

    FRawAsString: boolean;

    FNumberAsString: boolean;

    FIntegerPrecision: Integer;

    FLargeIntPrecision: Integer;

    FFloatPrecision: Integer;

    FForceUnprepare: boolean;

    FGCHandle: IntPtr;

    FDisableParamScan: boolean; // prevents updating of ParamDescs in SetSQL (used in CreateProcCall)

    FTemporaryLobUpdate: boolean;

    FStatementCache: boolean;

  {$IFDEF MSWINDOWS}

    FChangeNotification: TOCIChangeNotification;

  {$ENDIF}



  { OCI8 }

    hOCIError: pOCIError;  // local error handle



  {$IFDEF MSWINDOWS}

    hBusy: THandle;

  {$ENDIF}

  {$IFDEF MSWINDOWS}

    hExecThread: TThread;

  {$ENDIF}

  {$IFDEF WIN32}

    hExecuted: TEvent;

  {$ENDIF}



    function GetGCHandle: IntPtr;

    function RemoveCRSymbols(SQLText: string; var ErrorOffset: integer): string;



  protected

    FConnection: TOCIConnection;



    procedure DoExecute;

    procedure EndExecute(E: Exception);



    //neaded for trial call

    procedure CheckOCI;

    procedure CheckOCI73;

    procedure CheckOCI80;



    procedure CheckActive;

    procedure CheckInactive;

    procedure CheckSession;



    procedure Check(Status: sword);



  { OCI73 }

    function GetOraType7(DataType: integer; SubDataType: integer{ = 0}): integer;

    function GetFieldDesc7(FieldNo: integer; var Field: TFieldDesc; LongString: boolean; FlatBuffer: boolean): boolean;

    function InternalFetch7(Rows: word): word;

    function InternalFetchPiece7: integer;

    procedure InitProcParams7(Name: string; Overload: integer);



  { OCI80 }

    function GetOraType8(DataType: integer; SubDataType: integer): integer;

    function GetFieldDesc8(FieldNo: integer; var Field: TFieldDesc; LongString: boolean; FlatBuffer: boolean): boolean;

    function InternalFetch8(Rows: word; Orientation: integer; Offset: integer): word;

    function InternalExecuteFetch8(Rows: word): word;    

    function InternalFetchPiece8(Orientation: integer; Offset: integer): integer;

    procedure InitProcParams8(Name: string; Overload: integer);



    function CallbackInBind(Bind: pOCIBind; Iter: ub4; Index: ub4; var Buf: IntPtr;

      var BufLen: ub4; var PieceStatus: ub1; var Ind: IntPtr): sb4;

    function CallbackOutBind(Bind: pOCIBind; Iter: ub4; Index: ub4; var Buf: IntPtr;

      var BufLen: pub4; var PieceStatus: ub1; var Ind: IntPtr): sb4;



    procedure SetArrayLength(Value: integer);

    function GetActive: boolean;



    property Params;

    property Executing;

    property GCHandle: IntPtr read GetGCHandle;



  public

    constructor Create; override;

    destructor Destroy; override;



    function GetOraType(DataType: integer; SubDataType: integer): integer;



    procedure InternalOpen;

    procedure InternalParse;

    procedure InternalPrepare;



    procedure BindParam(Param: TOraParamDesc);

    function InternalExecute(Mode: integer; Rows: Integer = 0): sword;

    procedure Exec;

    function GetFieldDesc(FieldNo: integer; var Field: TFieldDesc; LongString: boolean; FlatBuffer: boolean): boolean;

    procedure DefineData(Field: TFieldDesc; Buf: IntPtr; Ind: psb2);

    procedure DefineArrayData(Field: TFieldDesc; Buf: IntPtr; Ind: psb2; BufSkip: integer;

      IndSkip: integer);

    procedure DefinePieceData(Field: TFieldDesc; Buf: IntPtr; Ind: psb2);

    procedure DefineDynamic(Field: TFieldDesc; Owner: IntPtr; Proc: IntPtr; CharsetId: Integer);



    function InternalFetch(Rows: word; Orientation: integer = OCI_FETCH_NEXT; Offset: integer = 0): word;

    function InternalFetchPiece(Orientation: integer = OCI_FETCH_NEXT; Offset: integer = 0): integer;

    procedure InternalCancel;

    procedure InternalClose;

    procedure Finish;



    procedure GetPI(var Handle: pOCIHandle; var Piece: byte; var Buf: IntPtr;

      var Iteration: cardinal; var Index: cardinal; var Mode: TParamDirection);

    procedure SetPI(Handle: pOCIHandle; HType: cardinal; Piece: byte; Buf: IntPtr;

      var BufLen: cardinal; Ind: psb2);



    function NativeCursor: boolean;

    function RowsReturn: boolean;

    procedure CheckRowsReturn;



  { Params }

    function AddParam: TParamDesc; override;

    procedure ScanParams;

    procedure BindParams;

    procedure InitProcParams(Name: string; Overload: integer);

    //procedure DisconnectParams;

    function GetParam(Index: integer): TOraParamDesc;



    procedure BreakExec;

    procedure HardBreak;



    procedure Busy;

    procedure Release;



    function CreateProcCall(Name: PChar; Overload: integer;

      NeedDescribe: boolean = True; PassByName: boolean = False): string;



    procedure Prepare; override;

    procedure Unprepare; override;

    function GetPrepared: boolean; override;



    procedure Execute(Iters: integer = 1); override;



    procedure SetConnection(Value: TCRConnection); override;

    procedure SetSQL(const Value: string); override;

    function GetCursor: TOraCursor;

    procedure SetCursor(Value: TOraCursor);

    procedure SetOCICallStyle(Value: TOCICallStyle);

    function GetCursorState: TCursorState; override;

    procedure SetCursorState(Value: TCursorState); override;

    function GetSQLType: integer;

    procedure SetSQLType(Value: integer);

    function GetRowId: string;



    function SetProp(Prop: integer; const Value: variant): boolean; override;

    function GetProp(Prop: integer; var Value: variant): boolean; override;



  {$IFDEF MSWINDOWS}

    property ChangeNotification: TOCIChangeNotification read FChangeNotification write FChangeNotification;

  {$ENDIF}

  end;



{ TOCITableInfo }



{$IFNDEF LITE}

  TOCITableInfo = class(TCRTableInfo)

  public

    class function NormalizeName(Value: string; const QuoteNames: boolean): string; overload; override;

    class function NormalizeName(Value: string; const LeftQ: char; const RightQ: char; const QuoteNames: boolean = False): string; overload; override;

    class function NormalizeName(Value: string; const LeftQ: char; const RightQ: char; const QuoteNames, UnQuoteNames: boolean): string; overload;

    class function NormalizeName(Value: string; const QuoteNames, UnQuoteNames: boolean): string; overload;

  {$IFDEF VER8}

    class function LeftQuote: Char; override;

    class function RightQuote: Char; override;



    class function IsQuoted(const Value: string): boolean; override;

    class function QuotesNeeded(Value: string): boolean; override;

  {$ENDIF}

  end;

{$ENDIF}



{ TOCIRecordSet }



  TModifyAction = procedure of object;



  TOCIRecordSet = class (TCRRecordSet)

  private

    FAutoClose: boolean;

    FDeferredLobRead: boolean;

    hExecFetchThread: TThread;

    hFetchAllThread: TThread;

    FFetchCursor: TOraCursor;

    FFetchBlock: IntPtr;

    FFetchBlockItemSize: integer;

    FPieceFetch: boolean;

    FFetchItems: IntPtr;  // for callback fetch

    // for backward fetch

    FFetchAbsolute: boolean;

    FFetchStart: integer;

    FFetchEnd: integer;

    FNoData: boolean;

    FGCHandle: IntPtr;

    FHasLargeIntFields: boolean;



  {$IFDEF MSWINDOWS}

    hEvent: TEvent;

  {$ENDIF}

    FStopFetch : boolean;

    FFetching : boolean;



    FHasObjectFields: boolean;

    FTempFilterText: string;



    //PreCached FConection properties

    FDisconnectedMode: boolean;

    FUseUnicode: boolean;

    FCharLength: integer;



    procedure InitFetchCursor;



    function FetchArray(FetchBack: boolean = False): boolean;

    function FetchPiece(FetchBack: boolean = False): boolean;



    procedure AllocFetchBlock;

    procedure FreeFetchBlock;



    function GetNonBlocking: boolean;

    function GetGCHandle: IntPtr;

    function GetDisconnectedMode: boolean;

    function GetUseUnicode: boolean;

    function GetCharLength: integer;



    function IsConvertedFieldType(DataType: word): boolean;

  protected

    FCommand: TOCICommand;

    FConnection: TOCIConnection;  // for perf



    procedure CreateCommand; override;

    procedure SetCommand(Value: TCRCommand); override;



  { Open/Close }

    procedure InternalPrepare; override;

    procedure InternalUnPrepare; override;

    procedure InternalOpen; override;

    procedure InternalClose; override;

    procedure InternalInitFields; override;



    procedure ExecFetch; override;



    function GetIndicatorSize: word; override;



    function GetEOF: boolean; override;



  { Filter/Find/Locate/Sorting }

  {$IFNDEF CLR}

    function InternalAnsiStrComp(const Value1, Value2: IntPtr;

      const Options: TLocateExOptions): integer; override;

  {$ENDIF}

    function InternalAnsiCompareText(const Value1, Value2: string;

      const Options: TLocateExOptions): integer; override;

    function InternalWStrLComp(const Value1, Value2: WideString;

      const Options: TLocateExOptions): integer; override;

    function InternalWStrComp(const Value1, Value2: WideString;

      const Options: TLocateExOptions): integer; override;



    procedure SetFilterText(Value: string); override;

          

  { Fetch }

    function Fetch(FetchBack: boolean = False): boolean; override;

    function CanFetchBack: boolean; override;



  { Items }

    procedure FreeAllItems;



  { Edit }

    procedure DoExecFetch;

    procedure EndExecFetch(E: Exception);

    procedure DoFetchAll;

    procedure DoFetchAllPulse;

    procedure EndFetchAll(E: Exception);



    function CallbackDefine(Define: pOCIDefine; Iter: cardinal; var Buf: IntPtr;

      var BufLen: pub4; var PieceStatus: ub1; var Ind: IntPtr): sb4;

  {$IFNDEF LITE}

  { TablesInfo }

    class function GetTableInfoClass: TTableInfoClass; override;

  {$ENDIF}



    property GCHandle: IntPtr read GetGCHandle;

    //PreCached FConection properties

    property DisconnectedMode: boolean read GetDisconnectedMode;

    property UseUnicode: boolean read GetUseUnicode;

    property CharLength: integer read GetCharLength;



  public

    constructor Create; override;

    destructor Destroy; override;



  { Open/Close }

    function IsFullReopen: boolean; override;

    procedure Reopen; override;

    procedure SetCommandType;

    procedure ExecCommand; override; // Execute command

    procedure BreakExec;

    procedure Disconnect; override;    



  { Fetch }

    procedure FetchAll; override;



    function RowsReturn: boolean; override;

  { Fields }

    procedure SetNull(FieldNo: word; RecBuf: IntPtr; Value: boolean); override;

    function GetNull(FieldNo: word; RecBuf: IntPtr): boolean; override;



    procedure GetDateFromBuf(Buf: IntPtr; Offset: integer; Date: IntPtr; Format: TDateFormat); override;

    procedure PutDateToBuf(Buf: IntPtr; Offset: integer; Date: IntPtr; Format: TDateFormat); override;



    function IsBlobFieldType(DataType: word): boolean; override;

    function IsComplexFieldType(DataType: word): boolean; override;



    procedure GetFieldData(Field: TFieldDesc; RecBuf: IntPtr; Dest: IntPtr); override;

    procedure GetFieldAsVariant(FieldNo: word; RecBuf: IntPtr; var Value: variant); override;

    procedure PutFieldAsVariant(FieldNo: word; RecBuf: IntPtr; const Value: variant); override;



  { Records }

    procedure CreateComplexFields(RecBuf: IntPtr; WithBlob: boolean); override;

    procedure FreeComplexFields(RecBuf: IntPtr; WithBlob: boolean); override;

    procedure CopyComplexFields(Source: IntPtr; Dest: IntPtr; WithBlob: boolean); override;



    function CompareFieldValue(ValuePtr: IntPtr; const ValueType: integer; FieldDesc: TFieldDesc; RecBuf: IntPtr; const Options: TLocateExOptions): integer; override;

    function CompareFields(RecBuf1: IntPtr; RecBuf2: IntPtr; FieldDesc: TFieldDesc; Options: TLocateExOptions = []): integer; override;

    procedure SortItems; override;

    procedure FilterUpdated; override;



  { Navigation }

    procedure SetToBegin; override;

    procedure SetToEnd; override;



  { BookMarks }

    procedure GetBookmark(Bookmark: PRecBookmark); override;

    procedure SetToBookmark(Bookmark: PRecBookmark); override;

    function GetBlockFetchPos(Block: PBlockHeader): integer;

    function GetItemFetchPos(Item: PItemHeader): integer;



  { Blobs }

    procedure SetConnection(Value: TCRConnection); override;



    function SetProp(Prop: integer; const Value: variant): boolean; override;

    function GetProp(Prop: integer; var Value: variant): boolean; override;

  end;



{ TOraLob }



  TLobType = (ltBlob, ltClob, ltNClob);



  TOraLob = class (TCompressedBlob)

  private

    phLobLocator: ppOCILobLocator;

    FSvcCtx: pOCISvcCtx;

    hOCIEnv: pOCIEnv;

    FNativeHandle: boolean;

    FCached: boolean;

    FCharsetForm: integer;

    FLobType: TLobType;

    FCharLength: byte;



    function GetOCILobLocator: pOCILobLocator;

    function GethOCILobLocator: pOCIStmt;

    procedure SethOCILobLocator(Value: pOCIStmt);

    procedure SetOCILobLocator(Value: pOCILobLocator);

    function GetOCILobLocatorPtr: ppOCILobLocator;

    procedure SetCached(const Value: boolean);

    procedure SetOCISvcCtx(const Value: pOCISvcCtx);



    property hLobLocator: pOCILobLocator read GethOCILobLocator write SethOCILobLocator;



  protected

    FNeedReadLob: boolean;



    procedure CheckValue; override;

    function GetSize: cardinal; override;

    procedure CheckAlloc;

    procedure CheckSession;

    procedure CheckInit;

    procedure CheckCharSetForm;

    function CharSize: Byte; virtual;



  public

    constructor Create(ASvcCtx: pOCISvcCtx);

    destructor Destroy; override;



    procedure AllocLob; virtual;

    procedure FreeLob; virtual;



    procedure Init;

    procedure CreateTemporary(LobType: TLobType);

    procedure FreeTemporary;

    function IsTemporary: LongBool;

    function IsInit: boolean;



    function LengthLob: longint;



    procedure EnableBuffering;

    procedure DisableBuffering;



    procedure ReadLob;

    procedure WriteLob;



    function Read(Position, Count: cardinal; Dest: IntPtr): cardinal; override;

    procedure Write(Position, Count: cardinal; Source: IntPtr); override;

    procedure Clear; override;

    procedure Truncate(NewSize: cardinal); override;



    procedure LoadFromStream(Stream: TStream); override;

    procedure SaveToStream(Stream: TStream); override;



    property OCILobLocator: pOCILobLocator read GetOCILobLocator write SetOCILobLocator;

    property OCILobLocatorPtr: ppOCILobLocator read GetOCILobLocatorPtr;

    property OCISvcCtx: pOCISvcCtx read FSvcCtx write SetOCISvcCtx;

    property Cached: boolean read FCached write SetCached;

    property LobType: TLobType read FLobType write FLobType;

  end;



{ TOraFile }



  TOraFile = class (TOraLob)

  private

    FNeedRollback: boolean;

    FRollbackFileDir: string;

    FRollbackFileName: string;



    function GetFileDir: string;

    procedure SetFileDir(Value: string);

    function GetFileName: string;

    procedure SetFileName(Value: string);



  protected

    CanRollback: boolean;



    procedure CheckValue; override;

    function CharSize: Byte; override;



    procedure SaveToRollback; override;

  public

    destructor Destroy; override;



    procedure AllocLob; override;

    procedure FreeLob; override;



    procedure Open;

    procedure Close;

    procedure EnableRollback;



    procedure Commit; override;

    procedure Cancel; override;



    procedure Refresh;



    function IsOpen: boolean;



    function Exists: boolean;



    property FileDir: string read GetFileDir write SetFileDir;

    property FileName: string read GetFileName write SetFileName;

  end;



{ TOraTimeStamp }



  TOraTimeStamp = class (TSharedObject)

  private

    phOCIDateTime: ppOCIDateTime;

    FDescriptorType: cardinal;

    FPrecision: byte;

    FFormat: string;

    FNativeHandle: boolean;

    FIndicator: IntPtr;



    function GetAsString: string;

    procedure SetAsString(const Value: string);

    function GetAsDateTime: TDateTime;

    procedure SetAsDateTime(Value: TDateTime);

    function GetTimeZone: string;

    function GethOCIDateTime: pOCIDateTime;

    procedure SethOCIDateTime(Value: pOCIDateTime);

    function GetOCIDateTime: pOCIDateTime;

    procedure SetOCIDateTime(const Value: pOCIDateTime);

    procedure SetDescriptorType(const Value: cardinal);

    function GetOCIDateTimePtr: ppOCIDateTime;



    procedure CheckValid;



    procedure SetFormat(const AFormat: string);



    property hOCIDateTime: pOCIDateTime read GethOCIDateTime write SethOCIDateTime;



  public

    constructor Create(DataType: word);

    destructor Destroy; override;



    procedure AllocDateTime;

    procedure FreeDateTime;



    procedure AssignTo(Dest: TOraTimeStamp);

    function Compare(Dest: TOraTimeStamp): integer;



    function GetIsNull: boolean;

    procedure SetIsNull(Value: boolean);



    procedure Construct(Year: smallint; Month, Day, Hour, Min, Sec: byte;

      FSec: cardinal; TimeZone: string);



    procedure GetDate(var Year: smallint; var Month, Day: byte);

    procedure SetDate(Year: smallint; Month, Day: byte);



    procedure GetTime(var Hour, Min, Sec: byte; var FSec: cardinal);

    procedure SetTime(Hour, Min, Sec: byte; FSec: cardinal);



    procedure GetTimeZoneOffset(var Hour, Min: shortint);

    procedure SetTimeZoneOffset(TZHour, TZMin: shortint);



    property DescriptorType: cardinal read FDescriptorType write SetDescriptorType;

    property OCIDateTime: pOCIDateTime read GetOCIDateTime write SetOCIDateTime;

    property OCIDateTimePtr: ppOCIDateTime read GetOCIDateTimePtr;

    property Format: string read FFormat write SetFormat;

    property Precision: byte read FPrecision write FPrecision;

    property TimeZone: string read GetTimeZone;

    property AsString: string read GetAsString write SetAsString;

    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;

    property IsNull: boolean read GetIsNull write SetIsNull;

  end;



  TOraInterval = class (TSharedObject)

  private

    phOCIInterval: ppOCIInterval;

    FDescriptorType: cardinal;

    FNativeHandle: boolean;

    FFracPrecision: byte;

    FLeadPrecision: byte;

    FIndicator: IntPtr;



    procedure Init;

    procedure CheckValid;

    function GetAsString: string;

    function GethOCIInterval: pOCIInterval;

    procedure SethOCIInterval(Value: pOCIInterval);

    function GetOCIInterval: pOCIInterval;

    function GetOCIIntervalPtr: ppOCIInterval;

    procedure SetAsString(const Value: string);

    procedure SetDescriptorType(const Value: cardinal);

    procedure SetOCIInterval(const Value: pOCIInterval);



    property hOCIInterval: pOCIInterval read GethOCIInterval write SethOCIInterval;

  public

    constructor Create(DataType: word);

    destructor Destroy; override;



    procedure AllocInterval;

    procedure FreeInterval;



    procedure AssignTo(Dest: TOraInterval);

    function Compare(Dest: TOraInterval): integer;



    function GetIsNull: boolean;

    procedure SetIsNull(Value: boolean);



    procedure GetYearMonth(var Year, Month: integer);

    procedure SetYearMonth(Year, Month: integer);



    procedure GetDaySecond(var Day, Hour, Min, Sec, FSec: integer);

    procedure SetDaySecond(Day, Hour, Min, Sec, FSec: integer);



    property DescriptorType: cardinal read FDescriptorType write SetDescriptorType;

    property OCIInterval: pOCIInterval read GetOCIInterval write SetOCIInterval;

    property OCIIntervalPtr: ppOCIInterval read GetOCIIntervalPtr;

    property LeadPrecision: byte read FLeadPrecision write FLeadPrecision;

    property FracPrecision: byte read FFracPrecision write FFracPrecision;

    property AsString: string read GetAsString write SetAsString;

    property IsNull: boolean read GetIsNull write SetIsNull;

  end;



  TOraNumber = class (TSharedObject)

  private

    phOCINumber: pOCINumber;

    FIndicator: IntPtr;

    FNativeHandle: boolean;



    function GetOCINumberPtr: pOCINumber;

    procedure SetOCINumberPtr(Value: pOCINumber);

    function GetOCINumber: OCINumber;

    procedure SetOCINumber(Value: OCINumber);

    function GetAsString: string;

    procedure SetAsString(const Value: string);

    function GetAsInteger: integer;

    procedure SetAsInteger(const Value: integer);

    function GetAsLargeInt: int64;

    procedure SetAsLargeInt(const Value: int64);

    function GetAsFloat: double;

    procedure SetAsFloat(const Value: double);

    function GetIsNull: boolean;

    procedure SetIsNull(Value: boolean);

{$IFDEF LITE}

    function GetAsBCD: TBCD;

    procedure SetAsBCD(const Value: TBCD);

{$ENDIF}



  public

    constructor Create;

    destructor Destroy; override;

    procedure AssignTo(Dest: TOraNumber);

    function Compare(Dest: TOraNumber): integer;



    property OCINumber: OCINumber read GetOCINumber write SetOCINumber;

    property OCINumberPtr: pOCINumber read GetOCINumberPtr write SetOCINumberPtr;

    property AsString: string read GetAsString write SetAsString;

    property AsInteger: integer read GetAsInteger write SetAsInteger;

    property AsLargeInt: Int64 read GetAsLargeInt write SetAsLargeInt;

    property AsFloat: double read GetAsFloat write SetAsFloat;

    property IsNull: boolean read GetIsNull write SetIsNull;

{$IFDEF LITE}

    property AsBCD: TBCD read GetAsBCD write SetAsBCD;

{$ENDIF}

  end;



{$IFNDEF LITE}

{ TOCITransaction }



  TGlobalCoordinator = (gcInternal{$IFDEF MSWINDOWS}, gcMTS{$ENDIF});

  TOraIsolationLevel = (ilReadCommitted, ilSerializable, ilReadOnly);

  TOraTransactionAction = (taCommit, taRollback);



  TOraTransactionState = (tsInactive, tsActive, tsPrepared, tsFinished);



  TTransactionLink = class

    Connection: TOCIConnection;

    BranchQualifier: TBytes;

    State: TOraTransactionState;

    OCITrans: pOCITrans;

  {$IFDEF MSWINDOWS}

    MTSSvcCtx: pOCISvcCtx;

  {$ENDIF}

  end;



  TTransactionLinks = class (TDAList)

  private

    function GetItems(Index: integer): TTransactionLink;

  public

    procedure Clear; override;

    function IndexOfConnection(Connection: TOCIConnection): integer;

    function AddConnection(Connection: TOCIConnection; BranchQualifier: TBytes): boolean;

    function RemoveConnection(Connection: TOCIConnection): boolean;

    property Items[Index: Integer]: TTransactionLink read GetItems; default;

  end;



  TOCITransaction = class

  private

    FOnError: TErrorProc;

    FTransactionLinks: TTransactionLinks;



    FActive: boolean;



    FInactiveTimeOut: integer;

    FResumeTimeOut: integer;

    FTransactionName: string;

    FXID: IntPtr;

    FTransactionId: TBytes;



    FGlobalCoordinator: TGlobalCoordinator;

    FIsolationLevel: TOraIsolationLevel;

    FDefaultCloseAction: TOraTransactionAction;



  {$IFDEF MSWINDOWS}

    FMTSGC: ICRTransactionDispenserSC;

    FMTSTrans: ICRTransactionSC;

  {$ENDIF}



    procedure WriteTransactionId;

    procedure WriteBranchQualifier(TransactionLink: TTransactionLink);



    procedure FreeTransaction;



  {$IFDEF MSWINDOWS}

    procedure StartMTSTransaction;

    procedure CompleteMTSTransaction(Commit: boolean);

  {$ENDIF}

  public

    constructor Create;

    destructor Destroy; override;

    procedure CloseTransaction;



    procedure Check(Status: sword);

    procedure OraError(var ErrorCode: sword; UseCallback: boolean);

  {$IFDEF MSWINDOWS}

    procedure MTSCheck(status: sword);

    procedure MTSError(var ErrorCode: sword; UseCallback: boolean);

  {$ENDIF}



    procedure CheckState(State: boolean);

    procedure SetTransactionId(TransactionId: TBytes);

    function AddConnection(Connection: TOCIConnection; BranchQualifier: TBytes): boolean;

    function RemoveConnection(Connection: TOCIConnection): boolean;



    function SetProp(Prop: integer; const Value: variant): boolean;

    function GetProp(Prop: integer; var Value: variant): boolean;



    procedure StartTransaction(Resume: boolean);

    procedure Commit;

    procedure Rollback;

    procedure Detach;

    procedure Resume;



    property Active: boolean read FActive;

    property OnError: TErrorProc read FOnError write FOnError;

  end;

{$ENDIF}



  TOraClassesUtils = class

  public

    class procedure InternalUnPrepare(Obj: TOCIRecordSet);

  end;



const

  IntegerPrecision: integer = 9;

  LargeIntPrecision: integer = 0;

  FloatPrecision: integer   = 15;



var

  UseOCI7ProcDesc: boolean;

  TimeFormat: string;



  function OraDateToDateTime(Buf: IntPtr): TDateTime;

  function OraDateToMSecs(Buf: IntPtr): double;

  procedure DateTimeToOraDate(DateTime: TDateTime; Buf: IntPtr);

  procedure MSecsToOraDate(MSecs: double; Buf: IntPtr);



  procedure OCIInit;

  procedure OCIFinish;



  procedure GetTimeFormat;



  function QuotedOCIName(Name: string): string;

  function QuotedSQLName(Name: string): string;



{$IFNDEF LITE}

  function GetTablesInfo(SQL: string; TablesInfo: TCRTablesInfo): integer;  

{$ENDIF}



implementation

uses

  {$IFDEF PROF}OraProf, {$ENDIF}

{$IFDEF CLR}

  System.Runtime.InteropServices, System.Text, System.Threading,

{$ELSE}

  {$IFDEF VER6P}Variants,{$ENDIF}

{$ENDIF}

{$IFDEF MSWINDOWS}

{$IFNDEF LITE}

  ComObj,

{$ENDIF}

{$ENDIF}

  DAConsts, OraConsts, OraObjects, CRParser, OraParser, Math;



const

  WM_ENDTHREAD      = $400;

  WM_EXCEPTTHREAD   = $401;

  WM_ENDEXECUTE     = $402;  // WAR

  WM_AFTERFETCH     = $404;

  WM_CHANGENOTIFY   = $405;



type

  TArr = array [0..100] of byte;  // DEBUG TEMP

  PArr = ^TArr;

  TArrC = array [0..100] of char;  // DEBUG TEMP

  PArrC = ^TArrC;



{$IFNDEF LINUX}

type

  TExecThread =  class(TThread)

  protected

    FMethodDesc: TMethodDesc;

    FException: Exception;

  public

    constructor Create(MethodDesc: TMethodDesc; CreateSuspended: Boolean);

    destructor Destroy; override;

    procedure Execute; override;

  end;

{$ENDIF}



var

{$IFDEF LINUX}

  hLockConnect: TCriticalSection;

{$ENDIF}



  OCICallbackDefinePtr: IntPtr;

  OCICallbackInBindPtr: IntPtr;

  OCICallbackOutBindPtr: IntPtr;

  OCICallbackFailoverPtr: IntPtr;

{$IFDEF MSWINDOWS}

  OCICallbackChangeNotifyPtr: IntPtr;

{$ENDIF}



{$IFDEF CLR}

  HOCICallbackDefine: GCHandle;

  HOCICallbackInBind: GCHandle;

  HOCICallbackOutBind: GCHandle;

  HOCICallbackFailover: GCHandle;

  HOCICallbackChangeNotify: GCHandle;

  HWndProc: GCHandle;

{$ENDIF}



procedure OCIInit;

begin

  OraCall.InitOCI;

end;



procedure OCIFinish;

begin

  FinishOCI;

end;



function Shift(Value: cardinal): cardinal;

begin

  Result := Value;

  if Result <> 0 then

    if (Result and $FF) = 0 then  // while do

      Result := Result shr 8;

end;



function Reverse2(Value: word): TBytes;

begin

  SetLength(Result, 2);

  Result[0] := byte(Value shr 8);

  Result[1] := byte(Value);

end;



function Reverse4(Value: cardinal): TBytes;

begin

  SetLength(Result, 4);

  Result[0] := byte(Value shr 24);

  Result[1] := byte(Value shr 16);

  Result[2] := byte(Value shr 8);

  Result[3] := byte(Value);

end;



// Converts Count bytes from memory pointed by Bytes to 64 base string. Starting

// digit (6-bit chunk) may be shifted by -4, -2, 0 or 2 bits. Missing bits

// assumed to be zero.

// Bytes are converted in the following way (example for Shift = 0):

// 0 byte   1 byte   hi    lo

// 00000100|00000000|01000001|01000011|...

// ------++ ++++---- --++++++ ------++ +++

//  B(1)   A(0)   B(1)  B(1)   Q(16)

function BytesTo64BaseString(Bytes: TBytes; Count: integer; Shift: integer): string;

const

  Map = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

var

  i, RestBits: cardinal;

  CurByte, Digit, NextDigit: byte;

begin

  Result :='';

  RestBits := 2 - Shift;

  NextDigit := $FF;



  for i := 0 to Count - 1 do begin

    CurByte := Bytes[i];



    Digit := CurByte shr RestBits;

    if NextDigit <> $FF then

      Digit := Digit or NextDigit;



    Result := Result + Map[Digit + 1];



    NextDigit := (CurByte and ($FF shr (8 - RestBits))) shl (6 - RestBits);



    if RestBits = 6 then begin

      Result := Result + Map[NextDigit + 1];

      NextDigit := $FF;

      RestBits := 2;

    end

    else

      RestBits := RestBits + 2;

  end;



  if NextDigit <> $FF then

    Result := Result + Map[NextDigit + 1];

end;



function RowId7ToString(RowId: PRowId7): string;

var

  Buf: TBytes;

begin

  Buf := nil;

  if (RowId.rd.rcs4 = 0) then begin // obj num

  // restricted (Oracle 7)

    Result :=

      IntToHex(Shift(RowId.rcs7), 8) + '.' +

      IntToHex(Shift(RowId.rcs8), 4) + '.' +  // use 2 byte

      IntToHex(RowId.rd.rcs5, 4)

  end

  else begin

  // extended (Oracle 8 and higher)

    Buf := Reverse4(RowId.rd.rcs4);

    Result := BytesTo64BaseString(Buf, 4, -4);



    Buf := Reverse2(RowId.rd.rcs5);

    Result := Result + BytesTo64BaseString(Buf, 2, -2);



    Buf := Reverse4(Shift(RowId.rcs7));

    Result := Result + BytesTo64BaseString(Buf, 4, -4);



    Buf := Reverse2(Shift(RowId.rcs8)); // use 3 byte

    Result := Result + BytesTo64BaseString(Buf, 2, -2);

  end;

end;



function RowId8ToString(RowId: PRowId8): string;

var

  Buf: TBytes;

begin

  Buf := nil;

  if (RowId.ridobjnum = 0) then

  // restricted (Oracle 7)

    Result :=

      IntToHex(Shift(RowId.ridblocknum), 8) + '.' +

      IntToHex(Shift(RowId.ridslotnum), 4) + '.' +

      IntToHex(RowId.ridfilenum, 4)

  else begin

  // extended (Oracle 8 and higher)

    Buf := Reverse4(RowId.ridobjnum);

    Result := BytesTo64BaseString(Buf, 4, -4);



    Buf := Reverse2(RowId.ridfilenum);

    Result := Result + BytesTo64BaseString(Buf, 2, -2);



    Buf := Reverse4(RowId.ridblocknum);

    Result := Result + BytesTo64BaseString(Buf, 4, -4);



    Buf := Reverse2(RowId.ridslotnum);

    Result := Result + BytesTo64BaseString(Buf, 2, -2);

  end;

end;



function RowId81ToString(RowIdPtr: PRowId81): string;

var

  Bytes: TBytes;

begin

  if RowIdPtr.ridobjnum = 0 then begin

  // restricted (Oracle 7)

    Result :=

      IntToHex(BitConverter.ToInt32(Reverse4(RowIdPtr.ridblocknum), 0), 8) + '.' +

      IntToHex(BitConverter.ToInt16(Reverse2(RowIdPtr.ridslotnum), 0), 4) + '.' +

      IntToHex(BitConverter.ToInt16(Reverse2(RowIdPtr.ridfilenum), 0), 4)

  end

  else begin

  // extended (Oracle 8 and higher)

    SetLength(Bytes, 4);

    Marshal.Copy(IntPtr(Integer(IntPtr(RowIdPtr)) + 1{TRowId81.ridobjnum}), Bytes, 0, 4);

    Result := BytesTo64BaseString(Bytes, 4, -4);

    Marshal.Copy(IntPtr(Integer(IntPtr(RowIdPtr)) + 5{TRowId81.ridfilenum}), Bytes, 0, 2);

    Result := Result + BytesTo64BaseString(Bytes, 2, -2);

    Marshal.Copy(IntPtr(Integer(IntPtr(RowIdPtr)) + 7{TRowId81.ridblocknum}), Bytes, 0, 4);

    Result := Result + BytesTo64BaseString(Bytes, 4, -4);

    Marshal.Copy(IntPtr(Integer(IntPtr(RowIdPtr)) + 11{TRowId81.ridslotnum}), Bytes, 0, 2);

    Result := Result + BytesTo64BaseString(Bytes, 2, -2);

  end;

end;



function URowIdToString(RowIdPtr: PRowId81; Length: integer): string;

var

  Bytes: TBytes;

begin

  SetLength(Bytes, Length - 1);

  Marshal.Copy(IntPtr(Integer(IntPtr(RowIdPtr)) + 1), Bytes, 0, Length - 1);

  Result := '*' + BytesTo64BaseString(Bytes, Length - 1, 0);

end;



{ Data convertion }



function OraDateToDateTime(Buf: IntPtr): TDateTime;

var

  Time: TDateTime;

  OraDate: TBytes;

begin

  SetLength(OraDate, 7);

  Marshal.Copy(Buf, OraDate, 0, 7);

  Result := EncodeDate(Abs((OraDate[0] - 100) * 100 + OraDate[1] - 100),

    OraDate[2], OraDate[3]);

  Time := EncodeTime(OraDate[4] - 1, OraDate[5] - 1, OraDate[6] - 1, 0);

  if Result < 0 then

    Result := Result - Time

  else

    Result := Result + Time;

end;



function OraDateToMSecs(Buf: IntPtr): double;

begin

  Result := TimeStampToMSecs(DateTimeToTimeStamp(OraDateToDateTime(Buf)));//{$IFNDEF CLR}BitConverter.DoubleToInt64Bits{$ENDIF}

end;



procedure DateTimeToOraDate(DateTime: TDateTime; Buf: IntPtr);

var

  Year, Month, Day, Hour, Min, Sec, MSec: word;

  OraDate: TBytes;

begin

  SetLength(OraDate, 8);

  DecodeDate(DateTime, Year, Month, Day);

  DecodeTime(DateTime, Hour, Min, Sec, MSec);

  OraDate[0] := Year div 100 + 100;…