freepascal.compiler/fcl/db/odbc/fpodbc.pp

unit fpodbc;

{$mode objfpc}
{$h+}

interface

uses odbcsql,SysUtils,Classes;

Type
  TDSNTypes = (dtUser,dtSystem,dtBoth);
  TODBCParamType  = (ptUnknown,ptInput,ptInputOutput,ptResult,ptOutput,ptRetVal);
  TODBCParamTypes = Set of TODBCParamType;

  TODBCObject = Class(TComponent)
  Private
    FHandle : SQLHandle;
    FHandleType : SQLSmallint;
    Function GetHandle : SQLHandle;
    function GetHandleAllocated: Boolean;
    function GetExtendedErrorInfo: String;
  Protected
    Function CreateHandle : SQLHandle; Virtual;
    Function ParentHandle : SQLHandle; Virtual;
    Procedure FreeHandle;
    Function CheckODBC(Res : Integer;Msg : String) : Integer;
  Public
    Destructor Destroy; override;
    Property Handle : SQLHandle Read GetHandle;
    Property HandleAllocated : Boolean Read GetHandleAllocated;
  end;

  TODBCEnvironment = Class(TODBCObject)
  Private
    FODBCBehaviour : Integer;
    procedure SetODBCbehaviour(const Value: Integer);
    function GetNullTerminate: Boolean;
    procedure SetNullTerminate(const Value: Boolean);
  protected
    function CreateHandle: SQLHandle; override;
    Procedure SetIntAttribute(Const Attr,Value : Integer);
    Procedure SetStringAttribute(Const Attr: Integer; Value : String);
    Function GetIntAttribute(Const Attr : Integer) : Integer;
    Function GetStringAttribute(Const Attr : Integer) : String;
  Public
    Constructor Create(Aowner : TComponent);override;
    Function GetDriverNames(List : Tstrings) : Integer;
    Function GetDataSourceNames(List : Tstrings; Types : TDSNTypes;Descriptions : Boolean) : Integer;
    function GetDriverOptions(Driver: String; Options: TStrings): Integer;
    Property ODBCBehaviour : Integer Read FODBCBehaviour Write SetODBCbehaviour;
    Property NullTerminateStrings : Boolean Read GetNullTerminate Write SetNullTerminate;
  end;

  TConnectionBrowseEvent = Procedure (Sender : TObject;InParams,OutParams : Tstrings) of Object;

  TODBCConnection = Class(TODBCObject)
  Private
    FActive : Boolean;
    FDriverParams : TStrings;
    FDSN,
    FDriverName,
    FUserName,
    FPassword : String;
    FEnvironMent : TODBCEnvironment;
    FOnBrowseConnection : TConnectionBrowseEvent;
    FWindowHandle : integer;
    FDriverCOmpletion: SQLUSmallInt;
    function GetDriverName: String;
    function GetDriverParams: TStrings;
    procedure SetActive(const Value: Boolean);
    procedure SetDriverName(const Value: String);
    procedure SetDriverParams(const Value: TStrings);
    procedure SetDSN(const Value: String);
    function GetEnvironment: TODBCEnvironMent;
    procedure SetEnvironment(const Value: TODBCEnvironMent);
  Protected
    procedure ConnectToDriver;
    procedure ConnectToDSN;
    Procedure ConnectBrowsing;
    Function ParentHandle : SQLHandle; override;
    Procedure CheckActive;
    Procedure CheckInActive;
  Public
    Constructor Create(Aowner : TComponent);override;
    Destructor Destroy; override;
    Procedure Connect;
    Procedure Disconnect;
    Procedure GetTableNames(S : TStrings; SystemTables : Boolean);
    Procedure GetFieldNames(TableName : String; S : TStrings);
    Procedure GetPrimaryKeyFields(TableName : String; S : TStrings);
    procedure GetProcedureNames(S : TStrings);
    procedure GetProcedureParams(ProcName : String;ParamTypes : TODBCParamTypes; S : TStrings);
    Property DSN : String Read FDSN Write SetDSN;
    Property DriverName : String Read GetDriverName Write SetDriverName;
    Property DriverCompletion : SQLUSmallInt Read FDriverCOmpletion Write FDriverCompletion;
    Property DriverParams : TStrings Read GetDriverParams Write SetDriverParams;
    Property Active : Boolean Read FActive Write SetActive;
    Property Environment : TODBCEnvironMent Read GetEnvironment Write SetEnvironment;
    Property UserName : String Read FUserName Write FUserName;
    Property Password  : string Read FPassword Write FPassword;
    Property OnBrowseConnection : TConnectionBrowseEvent Read FonBrowseConnection Write FOnBrowseConnection;
    Property WindowHandle : integer Read FWindowHandle Write FWindowHandle;
  end;

  TODBCStatement = Class;

  TODBCFieldList = Class(TCollection)
  Private
    FStatement : TODBCStatement;
  Public
    Constructor Create(Statement : TODBCStatement);
  end;

  {
    TODBCStatement allocates 1 big data buffer. For each bound field
    two things are allocated in the buffer:
    - Size of fetched data as filled in by fetch.
    - data. (may be zero for blobs etc)
    The FBuffOffset contains the offset in the buffer of the size field.
    Data immediatly follows the size.
  }

  TODBCField = Class(TCollectionItem)
  Private
    FDecimalDigits,
    FPosition : SQLSmallInt;
    FName : String;
    FSize : SQLUInteger;       // Declared size, as returned by DescribeCol
    FNullable : Boolean;
    FDataType : SQLSmallInt;   // Declared type, as returned by DescribeCol
    FBuffOffSet : SQLInteger;  // Offset in data buffer.
    FBuffer : Pointer;         // Pointer to data.
    FBufSize : SQLInteger;     // Allocated buffer size.
    FBufType : SQLSmallInt;    // Allocated buffer type
    function GetAsString: String;
    function GetData : PChar;
    Function GetIsNull : Boolean;
    Function GetAsInteger : Integer;
    Function GetAsBoolean : Boolean;
    Function GetAsDouble : Double;
    Function GetAsDateTime : TDateTime;
  Public
    Property Position : SQLSmallint Read FPosition;
    Property Name : String read FName;
    Property DataType : SQLSmallInt read FDatatype;
    Property Size : SQLUinteger read FSize;
    property DecimalDigits : SQLSmallInt read FDecimalDigits;
    Property Nullable : Boolean Read FNullable;
    Property Data : Pchar Read GetData;
    Property BufType : SQLSmallInt Read FBufType;
    Property BufSize : SQLInteger Read FBufSize;
    Property IsNull : Boolean Read GetIsNull;
    Property AsString : String Read GetAsString;
    Property AsInteger : Integer Read GetAsInteger;
    Property AsBoolean : Boolean Read GetAsBoolean;
    Property AsDouble : Double Read GetAsDouble;
    Property AsDateTime : TDateTime Read GetAsDateTime;
  end;

  TODBCStatement = Class(TODBCObject)
  Private
    FBOF,FEOF : Boolean;
    FConnection: TODBCConnection;
    FFields : TODBCFieldList;
    FBuffer : Pointer;
  Protected
    Function ParentHandle : SQLHandle; override;
    procedure SetConnection(const Value: TODBCConnection);
    procedure AllocBuffers;
  Public
    Constructor Create(Aowner : TComponent);override;
    Destructor Destroy; override;
    Procedure BindFields(RestrictList : TStrings);virtual;
    Procedure ClearFields;virtual;
    Function Fetch : Boolean;
    Property Connection : TODBCConnection Read FConnection Write SetConnection;
    Property BOF : Boolean read FBOF;
    Property EOF : Boolean read FEOF;
    Property Fields : TODBCFieldList Read FFields;
  end;

  TODBCTableList = Class(TODBCStatement)
  Public
    Procedure GetTableNames(S : TStrings; SystemTables : Boolean);
  end;

  TODBCFieldNamesList = Class(TODBCStatement)
  Public
    Procedure GetFieldNames(TableName : String;S : TStrings);
  end;

  TODBCPrimaryKeyFieldsList = Class(TODBCStatement)
  Public
    Procedure GetPrimaryKeyFields(TableName : String;S : TStrings);
  end;

  TODBCProcedureList = Class(TODBCStatement)
  Public
    Procedure GetProcedureList(S : TStrings);
  end;

  TODBCProcedureParams = Class(TODBCStatement)
    Procedure GetProcedureParams(ProcName: String; ParamTypes: TODBCParamTypes; S: TStrings);
  end;

  TStatementState = (ssInactive,ssPrepared,ssBound,ssOpen);

  TODBCSQLStatement = Class(TODBCStatement)
  Private
    FSQL : TStrings;
    FState : TStatementState;
    function GetActive: Boolean;
    procedure SetActive(const Value: Boolean);
  Protected
    procedure FreeStatement(Option: SQLUSMALLINT);
    procedure ExecuteDirect;
    procedure ExecutePrepared;
    Procedure SetSQL(const Value: TStrings);
  Public
    Constructor Create(Aowner : TComponent);override;
    Destructor Destroy; override;
    procedure Prepare;
    procedure Unprepare;
    Procedure BindFields(RestrictList : TStrings);override;
    procedure ExecSQL;
    Procedure Open;
    Procedure Close;
    procedure GetFieldList(List: TStrings);
    Property Active : Boolean Read GetActive Write SetActive;
    Property SQL : TStrings Read FSQL Write SetSQL;
  end;

  EODBCError = Class(Exception);

Const
  ODBCParamTypeNames : Array [TODBCParamType] of string
                     = ('Unknown','Input','Input/Output','Result','Output','RetVal');

Function DefaultEnvironment : TODBCEnvironment;

implementation

{ TODBCObject }

resourcestring
  SErrUnexpected = 'Unexpected ODBC error:';
  SErrEnvironmentHandle = 'Cannot allocate environment handle:';
  SErrInvalidBehaviour = 'Invalid value for ODBC behaviour: %d';
  SErrNotConnected = 'Operation invalid when not connected.';
  SErrConnected = 'Operation invalid when connected.';
  SNeedDSNOrDriver = 'Cannot connect with empty DSN and driver names.';
  SErrGettingDataSources = 'Error getting datasources:';
  SErrGettingDriverNames = 'Error getting driver names:';
  SErrGettingDriverOptions = 'Error getting driver options:';
  SErrSettingEnvAttribute = 'Error setting environment attribute:';
  SErrGettingEnvAttribute = 'Error Getting environment attribute:';
  SErrBrowseConnecting = 'Error connecting to datasource via browse:';
  SErrDSNConnect = 'Error connecting to DSN:';
  SErrDriverConnect = 'Error connecting to driver:';
  SErrDisconnecting = 'Error disconnecting:';
  SErrNoConnectionForStatement = 'Missing connection for statement.';
  SErrNoSQLStatement = 'Missing SQL statement.';
  SErrPreparing = 'Error preparing statement:';
  SErrGettingTableNames = 'Error getting table names:';
  SErrFetchingData = 'Error fetching data:';
  SErrFieldNames = 'Error getting field names:';
  SErrPrimaryKeys = 'Error getting primary key names:';
  SErrProcedureNames = 'Error getting procedure names:';
  SErrExecuting = 'Error while executing statement:';
  SErrExecutingPrepared = 'Error while executing prepared statement:';
  SErrNotPrepared = 'Statement is not prepared';
  SErrNotInactive = 'Statement is already prepared or executed.';
  SErrStatementActive = 'A statement is still active';
  SErrColumnCount = 'Error retrieving cilumn count:';
  SErrColDescription = 'Error retrieving column description';
  SErrInvalidConversion = 'invalid type conversion';
  SErrBindCol = 'Error binding column';
Const
  ODBCSuccess = [SQL_SUCCESS,SQL_SUCCESS_WITH_INFO];

Procedure ODBCError (Msg : String);

begin
  Raise EODBCError.Create(Msg);
end;

Procedure ODBCErrorFmt (Fmt : String;Args : Array of const);

begin
  Raise EODBCError.CreateFmt(Fmt,Args);
end;

Function CheckODBC(Res : Integer;Msg : String) : Integer;

begin
  Result:=Res;
  if not Res in [SQL_SUCCESS,SQL_SUCCESS_WITH_INFO] then
    begin
    If MSG='' then
      MSG:=SErrUnexpected;
    ODBCErrorFmt(msg,[res]);
    end;
end;

function TODBCObject.CheckODBC(Res: Integer; Msg: String): Integer;

Var S : String;

begin
  Result:=Res;
  if not Res in [SQL_SUCCESS,SQL_SUCCESS_WITH_INFO] then
    begin
    If MSG='' then
      MSG:=SErrUnexpected;
    S:=GetExtendedErrorInfo;
    If S<>'' then
      Msg:=Msg+LineEnding+S;
    ODBCError(msg);
    end;
end;

function TODBCObject.GetExtendedErrorInfo : String;

Var
  Res : SQLreturn;
  I,MsgLen : SQLSmallInt;
  SQLState : Array[0..6] of Char;
  NativeError : SQLInteger;
  MSg : Array[0..SQL_MAX_MESSAGE_LENGTH] of Char;
  SState,SMsg : String;

begin
   I:=0;
   Result:='';
   Repeat
     Inc(i);
     Res:=SQLGetDiagRec(FhandleType, FHandle, i, SqlState, NativeError,
            Msg, sizeof(Msg), MsgLen);
     If Res<>SQL_NO_DATA then
       begin
       SState:=SQLState;
       SMsg:=Msg;
       If Length(Result)>0 then
         Result:=Result+LineEnding;
       Result:=Result+Format('[%s] : %s (%d)',[SState,SMsg,NativeError]);
       end;
   Until (Res=SQL_NO_DATA);
end;




function TODBCObject.CreateHandle: SQLHandle;
begin
{$ifdef debug}
  Writeln(Classname,': Creating handle of type ',FHAndleType,' and parent ',ParentHandle);
{$endif}
  CheckODBC(SQLAllocHandle(FHandleType,ParentHandle,FHandle),SErrEnvironmentHandle);
  Result:=FHandle;
end;


destructor TODBCObject.Destroy;
begin
  If FHandle<>0 then
    FreeHandle;
  inherited;
end;

procedure TODBCObject.FreeHandle;
begin
  If FHandle<>0 then
    begin
    SQLFreeHandle(FHandleType,FHandle);
    FHandle:=0;
    end;
end;

function TODBCObject.GetHandle: SQLHandle;
begin
  If FHandle=0 then
    CreateHandle;
  Result:=FHandle;
end;

function TODBCObject.GetHandleAllocated: Boolean;
begin
  Result:=(FHandle<>0)
end;

function TODBCObject.ParentHandle: SQLHandle;
begin
  Result:=SQL_NULL_HANDLE;
end;

{ TODBCEnvironment }

constructor TODBCEnvironment.Create(Aowner: TComponent);
begin
  FHandleType:=SQL_HANDLE_ENV;
  inherited;
end;

function TODBCEnvironment.CreateHandle: SQLHandle;
begin
  Result:=Inherited CreateHandle;
  ODBCbehaviour:=SQL_OV_ODBC3;
end;

function TODBCEnvironment.GetDataSourceNames(List: Tstrings;
  Types: TDSNTypes;Descriptions : Boolean): Integer;

var
  DSNName,
  DSNDesc: array[0..SQL_MAX_OPTION_STRING_LENGTH] of Char;
  lenn,lend : SQLSmallInt;
  Dir : SQLSmallInt;
  Sn,SD : String;

begin
  Case Types of
    dtSystem : Dir:=SQL_FETCH_FIRST_SYSTEM;
    dtUser : Dir:=SQL_FETCH_FIRST_USER;
    dtBoth : Dir:=SQL_FETCH_FIRST;
  end;
  List.Clear;
  CheckODBC(SQLDatasources(Handle, Dir,
                           DSNName,SQL_MAX_OPTION_STRING_LENGTH, @lenn,
                           DSNDesc,SQL_MAX_OPTION_STRING_LENGTH, @lend),SErrGettingDataSources);
  Repeat
    If Not Descriptions then
      List.Add(DSNName)
    else
      begin
      SN:=DSNName;
      SD:=DSNDesc;
      List.Add(SN+'='+SD);
      end;
  Until Not (SQLDataSources(Handle, SQL_FETCH_NEXT,
                            DSNName, SQL_MAX_OPTION_STRING_LENGTH, @lenn,
                            DSNDesc,SQL_MAX_OPTION_STRING_LENGTH, @lend) in ODBCSuccess);
  Result:=List.Count;
end;

function TODBCEnvironment.GetDriverNames(List : Tstrings): Integer;

Var
  DriverName: array[0..SQL_MAX_OPTION_STRING_LENGTH] of Char;
  len : SQLSmallInt;

begin
  List.Clear;
  CheckODBC(SQLDrivers(Handle, SQL_FETCH_FIRST, DriverName,
        SQL_MAX_OPTION_STRING_LENGTH, @len, Nil,0,Nil),SErrGettingDriverNames);
  Repeat
    List.Add(DriverName);
  Until Not (SQLDrivers(Handle, SQL_FETCH_NEXT, DriverName,
        SQL_MAX_OPTION_STRING_LENGTH, @len, Nil,0,Nil) in ODBCSuccess);
  Result:=List.Count;
end;

function TODBCEnvironment.GetDriverOptions(Driver : String;Options: Tstrings): Integer;

Var
  DriverName,
  DriverOptions: array[0..SQL_MAX_OPTION_STRING_LENGTH] of Char;
  lenn,leno : SQLSmallInt;
  Found : Boolean;
  P : PChar;
  S : string;

begin
  CheckODBC(SQLDrivers(Handle, SQL_FETCH_FIRST, DriverName,
        SQL_MAX_OPTION_STRING_LENGTH, @lenn, DriverOptions,
        SQL_MAX_OPTION_STRING_LENGTH,@Leno),SErrGettingDriverOptions);
  Result:=0;
  Options.Clear;
  Repeat
    Found:=CompareText(Driver,DriverName)=0;
    If Found then
      begin
      P:=@DriverOptions[0];
      While P[0]<>#0 do
        begin
        S:=StrPas(P);
        options.Add(S);
        Inc(P,Length(S)+1);
        end;
      end;
  Until Not (SQLDrivers(Handle, SQL_FETCH_NEXT, DriverName,
        SQL_MAX_OPTION_STRING_LENGTH, @lenn, DriverOptions,
        SQL_MAX_OPTION_STRING_LENGTH,@Leno) in ODBCSuccess) or Found;
  Result:=Options.Count;
end;

function TODBCEnvironment.GetIntAttribute(const Attr: Integer): Integer;
begin
  CheckODBC(SQLSetEnvAttr(Handle,Attr,SQLPointer(@result),0),SErrSettingEnvAttribute);
end;

function TODBCEnvironment.GetNullTerminate: Boolean;
begin
  Result:=(GetIntAttribute(SQL_ATTR_OUTPUT_NTS)=SQL_TRUE);
end;

function TODBCEnvironment.GetStringAttribute(const Attr: Integer): String;

Var
  OldLen,Len: Integer;

begin
  OldLen:=0;
  Repeat
    Inc(OldLen,255);
    SetLength(Result,OldLen);
    CheckODBC(SQLGetEnvAttr(Handle,Attr,SQLPointer(@result),OldLen,@Len),SErrGettingEnvAttribute);
  until (Len<=OldLen);
  SetLength(Result,Len);
end;

procedure TODBCEnvironment.SetIntAttribute(const Attr, Value: Integer);
begin
  CheckODBC(SQLSetEnvAttr(Handle,Attr,SQLPointer(Value),0),SErrSettingEnvAttribute);
end;

procedure TODBCEnvironment.SetNullTerminate(const Value: Boolean);
begin
  If Value then
    SetIntAttribute(SQL_ATTR_OUTPUT_NTS,SQL_TRUE)
  else
    SetIntAttribute(SQL_ATTR_OUTPUT_NTS,SQL_FALSE);
end;

procedure TODBCEnvironment.SetODBCbehaviour(const Value: Integer);
begin
  If (Value<>FODBCBehaviour) then
    begin
    If Not (Value in [SQL_OV_ODBC3,SQL_OV_ODBC2]) Then
      ODBCErrorFmt(SErrInvalidBehaviour,[Value]);
    SetIntAttribute(SQL_ATTR_ODBC_VERSION,Value);
    FODBCBehaviour := Value;
    end;
end;

procedure TODBCEnvironment.SetStringAttribute(const Attr: Integer;
  Value: String);
begin
  CheckODBC(SQLSetEnvAttr(Handle,Attr,SQLPointer(Value),Length(Value)),SErrSettingEnvAttribute);
end;

{ TODBCConnection }

procedure TODBCConnection.CheckActive;
begin
  If Not FActive then
    ODBCError(SErrNotConnected);
end;

procedure TODBCConnection.CheckInActive;
begin
  If FActive then
    ODBCError(SErrConnected);
end;

procedure TODBCConnection.Connect;
begin
  If Not FActive then
    begin
    If Assigned (FonBrowseConnection) then
      ConnectBrowsing
    else If (FDSN<>'') then
      ConnectToDSN
    else if FDriverName<>'' then
      ConnectToDriver
    else
      ODBCError(SNeedDSNOrDriver);
    FActive:=True;
    end;
end;

Function ListToBuf(List : Tstrings; Buf : PChar; Sep : Char; MaxLen : Integer) : Boolean;

Var
  P : PChar;
  S : String;
  I,Len : Integer;

begin
  P:=Buf;
  I:=0;
  Result:=True;
  While Result and (I<List.Count) do
    begin
    S:=List[i];
    If I<List.Count-1 then
      S:=S+Sep;
    Len:=Length(S);
    Result:=(Longint(P-Buf)+Len)<=MaxLen;
    If Result then
      begin
      Move(S[1],P^,Len);
      Inc(P,Len);
      end;
    Inc(i);
    end;
  P[0]:=#0;
end;

Function BufToList(Buf : PChar;MaxLen : Integer;List : Tstrings;Sep : Char) : Integer;

Var
  S : String;
  P : PChar;
  Totlen,Len : Integer;

begin
  List.Clear;
  Result:=0;
  P:=Buf;
  TotLen:=0;
  While (P[0]<>#0) or (totlen<Maxlen) do
    begin
    Len:=0;
    While Not (P[len] in [Sep,#0]) do
      Inc(len);
    SetLength(S,Len);
    List.Add(S);
    Move(P[0],S[1],Len);
    Inc(P,Len);
    If P[0]<>#0 then
      Inc(P,1);
    inc(Totlen,Len+1);
    end;
  Result:=List.Count;
end;


Procedure TODBCConnection.ConnectBrowsing;

Var
  Inlist,OutList : TStringList;
  InStr,
  OutStr: Array[0..SQL_MAX_OPTION_STRING_LENGTH] of Char;
  i,Res : Integer;
  olen : SQLSmallint;

begin
  InList:=TStringList.Create;
  OutList:=TstringList.Create;
  try
    If FDSN<>'' then
      InList.Add('DSN='+FDSN)
    else If FDriverName<>'' then
      begin
      Inlist.Add('DRIVER='+FDriverName);
      For I:=0 to DriverParams.Count-1 do
        Inlist.Add(DriverParams[i]);
      end;
    Repeat
      ListToBuf(Inlist,Instr,';',SQL_MAX_OPTION_STRING_LENGTH);
      Res:=SQLBrowseConnect(Handle,Instr,SQL_NTS,Outstr,SQL_MAX_OPTION_STRING_LENGTH,Olen);
      If RES=SQL_NEED_DATA then
        begin
        OutList.Clear;
        BufToList(OutStr,Olen,OutList,';');
        FOnBrowseConnection(Self,InList,OutList);
        end
    Until (Res<>SQL_NEED_DATA);
    CheckODBC(Res,SErrBrowseConnecting);
  Finally
    Outlist.free;
    InList.Free;
  end;
end;

Procedure TODBCConnection.ConnectToDSN;
begin
  CheckODBC(SQLConnect(Handle,PSQLChar(FDSN),SQL_NTS,
                    PSQLChar(FUserName),SQL_NTS,
                    PSQLChar(FPassword),SQL_NTS),SErrDSNConnect);
end;


Procedure TODBCConnection.ConnectToDriver;

Var
  Instr,
  OutStr :  Array[0..SQL_MAX_OPTION_STRING_LENGTH] of Char;
  OLen : SQLSmallint;
  InList : TStringList;

begin
  InList:=TStringList.Create;
  Try
    Inlist.Assign(DriverParams);
    Inlist.Insert(0,'DRIVER={'+DRIVERNAME+'}');
    ListToBuf(Inlist,InStr,';',SQL_MAX_OPTION_STRING_LENGTH);
  Finally
    Inlist.Free;
  end;
  CheckODBC(SQLDriverConnect(Handle,FWindowHandle,
               Instr,SQL_NTS,
               OutStr,SQL_MAX_OPTION_STRING_LENGTH,
               Olen,FDriverCompletion),SErrDriverConnect);
end;

constructor TODBCConnection.Create(Aowner: TComponent);
begin
  inherited;
  FHandleType:=SQL_HANDLE_DBC;
  FDriverParams:=TStringList.Create;
  FDriverCompletion:=SQL_DRIVER_NOPROMPT;
end;

destructor TODBCConnection.Destroy;
begin
  Disconnect;
  inherited;
end;

procedure TODBCConnection.Disconnect;
begin
  If FActive then
    begin
    CheckODBC(SQLDisconnect(Handle),SErrDisconnecting);
    Factive:=False;
    end;
end;

function TODBCConnection.GetDriverName: String;
begin
  Result:=FDriverName;
end;

function TODBCConnection.GetDriverParams: TStrings;
begin
  Result:=FDriverParams;
end;

function TODBCConnection.GetEnvironment: TODBCEnvironMent;
begin
  If FEnvironment=Nil then
    result:=DefaultEnvironment
  else
    Result:=FEnvironment;
end;

procedure TODBCConnection.SetActive(const Value: Boolean);
begin
  If Value then
    Connect
  else
    Disconnect;
end;

procedure TODBCConnection.SetDriverName(const Value: String);
begin
  CheckInactive;
  FDSN:='';
  If CompareText(FDriverName,Value)<>0 then
    begin
    FDriverName:=Value;
    FDriverParams.Clear;
    end;
end;

procedure TODBCConnection.SetDriverParams(const Value: TStrings);
begin
  CheckInactive;
  FDriverParams.Assign(Value);
end;

procedure TODBCConnection.SetDSN(const Value: String);
begin
  CheckInactive;
  FDSN := Value;
end;

procedure TODBCConnection.SetEnvironment(const Value: TODBCEnvironMent);
begin
  CheckInactive;
  If (Value<>Environment) then // !! may be defaultenvironment...
    begin
    If HandleAllocated then
      FreeHandle;
    FEnvironment:=Value
    end;
end;


function TODBCConnection.ParentHandle: SQLHandle;
begin
  Result:=Environment.Handle
end;

Const
  DefEnv : Pointer = Nil;

Function DefaultEnvironment : TODBCEnvironment;

begin
  If DefEnv=Nil then
    DefEnv:=TODBCEnvironment.Create(Nil);
  Result:=TODBCEnvironment(DefEnv);
end;

procedure TODBCConnection.GetTableNames(S: TStrings;
  SystemTables: Boolean);
begin
  With TODBCTableList.Create(Self) do
    try
      GetTableNames(S,SystemTables);
    finally
      Free;
    end;
end;

procedure TODBCConnection.GetFieldNames(TableName: String; S: TStrings);
begin
  With TODBCFieldNamesList.Create(Self) do
    try
      GetFieldNames(TableName,S);
    finally
      Free;
    end;
end;

procedure TODBCConnection.GetPrimaryKeyFields(TableName: String;
  S: TStrings);
begin
  With TODBCPrimaryKeyFieldsList.Create(Self) do
    try
      GetPrimaryKeyFields(TableName,S);
    finally
      Free;
    end;
end;

procedure TODBCConnection.GetProcedureNames(S: TStrings);
begin
  With TODBCProcedureList.Create(Self) do
    try
      GetProcedureList(S);
    Finally
      Free;
    end;
end;

procedure TODBCConnection.GetProcedureParams(ProcName: String;
  ParamTypes: TODBCParamTypes; S: TStrings);
begin
  With TODBCProcedureParams.Create(Self) do
    Try
      GetProcedureParams(ProcName,Paramtypes,S);
    finally
      Free;
    end;
end;

{ TODBCStatement }

Type
  TODBCFieldBufRec = Record
    T{ype}    : SQlSmallint;
    B{ufsize} : SQLInteger;
    {Buftyp}e : SQLSmallint;
  end;

Const
  BufDescrCount = 26;
  BufDescr : Array[1..BufDescrCount] of TODBCFieldBufRec =
  { Type                Bufsize              Buftype }
  (
  (T:SQL_CHAR          ;b:-1                  ;e: SQL_CHAR),
  (T:SQL_NUMERIC       ;b:sizeof(SQLDouble)   ;e: SQL_DOUBLE),
  (T:SQL_DECIMAL       ;b:sizeof(SQLDouble)   ;e: SQL_DOUBLE),
  (T:SQL_INTEGER       ;b:sizeof(SQLInteger)  ;e: SQL_INTEGER),
  (T:SQL_SMALLINT      ;b:sizeof(SQLSmallInt) ;e: SQL_SMALLINT),
  (T:SQL_FLOAT         ;b:sizeof(SQLDOUBLE)   ;e: SQL_DOUBLE),
  (T:SQL_REAL          ;b:sizeof(SQLDOUBLE)   ;e: SQL_DOUBLE),
  (T:SQL_DOUBLE        ;b:Sizeof(SQLDOUBLE)   ;e: SQL_DOUBLE),
  (T:SQL_DATE          ;b:Sizeof(SQL_DATE_STRUCT) ;e: SQL_DATE),
  (T:SQL_TIME          ;b:sizeof(SQL_TIME_STRUCT) ;e: SQL_TIME),
  (T:SQL_TIMESTAMP     ;b:sizeof(SQL_TIMESTAMP_STRUCT) ;e: SQL_TIMESTAMP),
  (T:SQL_VARCHAR       ;b:-1                  ;e: SQL_CHAR),
  (T:SQL_UNKNOWN_TYPE  ;b:0                   ;e: SQL_UNKNOWN_TYPE),
  (T:SQL_LONGVARCHAR   ;b:-1                  ;e: SQL_CHAR),
  (T:SQL_BINARY        ;b:-2                  ;e: SQL_BINARY),
  (T:SQL_VARBINARY     ;b:-2                  ;e: SQL_BINARY),
  (T:SQL_LONGVARBINARY ;b:-2                  ;e: SQL_BINARY),
  (T:SQL_BIGINT        ;b:sizeOf(SQLDOUBLE)   ;e: SQL_DOUBLE),
  (T:SQL_TINYINT       ;b:Sizeof(SQLSMALLINT) ;e: SQL_SMALLINT),
  (T:SQL_BIT           ;b:sizeof(SQL_CHAR)    ;e: SQL_BIT),
  (T:SQL_WCHAR         ;b:-1                  ;e: SQL_CHAR),
  (T:SQL_WVARCHAR      ;b:-1                  ;e: SQL_CHAR),
  (T:SQL_WLONGVARCHAR  ;b:-1                  ;e: SQL_CHAR),
  (T:SQL_TYPE_DATE     ;b:sizeof(SQL_DATE_STRUCT) ;e: SQL_TYPE_DATE),
  (T:SQL_TYPE_TIME     ;b:sizeof(SQL_TIME_STRUCT) ;e: SQL_TYPE_TIME),
  (T:SQL_TYPE_TIMESTAMP;b:sizeof(SQL_TIMESTAMP_STRUCT) ;e: SQL_TYPE_TIMESTAMP)
  );
{  // template
  (T: ;b: ;e: ),
}

Function GetColSizeBufType (Coltype: SQLSmallint;
                             Var BufSize : SQLInteger;
                             Var BufType : SQLSmallInt) : Boolean;
Var
  I : Integer;

begin
  I:=0;
  BufSize:=0;
  BufType:=0;
  While (I<=BufDescrCount) and (BufDescr[i].t<>Coltype) do
    Inc(i);
  Result:=(i<=BufDescrCount);
  If Result then
    begin
    BufSize:=BufDescr[i].b;
    BufType:=BufDescr[i].e;
    end;
end;


procedure TODBCStatement.BindFields(RestrictList : TStrings);

Var
  Count: SQLSmallInt;
  CName : Array[0..SQL_NAME_LEN] of Char;
  CSize : SQLUINTEGER;
  CDataType,CDecimals,CNullable,CNameLen: SQLSmallInt;
  I : integer;

begin
  CheckODBC(SQLNumResultCols(Handle,Count),SErrColumnCount);
  For I:=1 to Count do
    begin
    CheckODBC(SQLDescribeCol(Handle,i,CName,SQL_NAME_LEN,CNameLen,
                             CdataType,CSize, CDecimals,CNullable)
              ,SErrColDescription);
    If Not Assigned(RestrictList) or (RestrictList.IndexOf(Cname)<>-1) then
      With FFields.Add as TODBCField do
        begin
        FPosition:=I;
        FName:=Cname;
        FDataType:=CDataType;
        FSize:=CSize;
        FDecimalDigits:=CDecimals;
        FNullable:=(CNullable=SQL_TRUE);
        GetColsizeBufType(FDataType,FBufSize,FBufType);
        If FBufSize=-1 then
          FBufSize:=FSize;
        end;
    end;
  AllocBuffers;
  For I:=0 to Count-1 do
    With FFields.Items[i] as TODBCField do
      CheckODBC(SQLBindCol(Handle,FPosition,FBufType,GetData,FBufSize,FBuffer+FBuffOffset)
               ,SErrBindCol);

end;

procedure TODBCStatement.ClearFields;
begin
  FFields.Clear;
end;

constructor TODBCStatement.Create(Aowner: TComponent);
begin
  FHandleType:=SQL_HANDLE_STMT;
  inherited;
  If AOwner is TODBCConnection then
    Connection:=TODBCConnection(Aowner);
  FFields:=TODBCFieldList.Create(Self);
end;

function TODBCStatement.ParentHandle: SQLHandle;
begin
   If (Connection=Nil) then
     ODBCError(SErrNoConnectionForStatement);
   Result:=Connection.Handle;
end;

procedure TODBCStatement.SetConnection(const Value: TODBCConnection);
begin
  If Value<>FConnection then
    begin
    If HandleAllocated then
      FreeHandle;
    FConnection := Value;
    end;
end;

Function TODBCStatement.fetch : Boolean;

Var
  res : SQLReturn;

begin
  Res:=SQLFetch(Handle);
  Result:=(Res=SQL_SUCCESS);
  If Not Result and (Res<>SQL_NO_DATA) then
    CheckODBC(Res,SErrFetchingData);
  FBof:=False;
  If (Res=SQL_NO_DATA) then
    FEOF:=True;
end;

destructor TODBCStatement.Destroy;
begin
  FFields.Free;
  inherited;
end;

{ TODBCSQLStatement }

procedure TODBCSQLStatement.GetFieldList(List : TStrings);

Var
  Count: SQLSmallInt;
  CName : Array[0..SQL_NAME_LEN] of Char;
  CSize : SQLUINTEGER;
  CDataType,CDecimals,CNullable,CNameLen: SQLSmallInt;
  I : integer;

begin
  if Not (FState in [ssPrepared,ssBound,ssOpen]) then
    ODBCError(SErrNotPrepared);
  List.Clear;
  CheckODBC(SQLNumResultCols(Handle,Count),SErrColumnCount);
  For I:=1 to Count do
    begin
    CheckODBC(SQLDescribeCol(Handle,i,CName,SQL_NAME_LEN,CNameLen,
                             CdataType,CSize, CDecimals,CNullable)
              ,SErrColDescription);
    List.Add(CName);
    end;
end;


procedure TODBCSQLStatement.Unprepare;

begin
  Case FState of
    ssBound,ssOpen :
              begin
              ClearFields;
              FreeStatement(SQL_CLOSE);
              end;
    ssPrepared : begin
                 FreeStatement(SQL_CLOSE);
                 end;
  end;
  FState:=ssInactive;
end;

procedure TODBCSQLStatement.FreeStatement(Option : SQLUSMALLINT);

begin
  SQLFreeStmt(Handle,SQL_CLOSE);
end;

procedure TODBCSQLStatement.Close;
begin
  if FState<>ssInactive then
    begin
    Unprepare;
    FreeStatement(SQL_CLOSE);
    FState:=ssInactive;
    end;
end;

constructor TODBCSQLStatement.Create(Aowner: TComponent);
begin
  inherited;
  FSQL:=TStringList.Create;
end;

destructor TODBCSQLStatement.Destroy;
begin
  if FState=ssOpen then
    Close
  else If FState<>ssInactive then
    Unprepare;
  FSQL.Free;
  inherited;
end;

procedure TODBCSQLStatement.ExecSQL;
begin
  Case FState of
    ssPrepared,ssBound : ExecutePrepared;
    ssInactive : ExecuteDirect;
  else
    Raise Exception.Create(SErrStatementActive)
  end;
end;

procedure TODBCSQLStatement.ExecuteDirect;

Var
  S : String;

begin
  if FState<>ssInactive then
    ODBCError(SErrStatementActive);
  S:=SQL.Text;
  CheckODBC(SQLExecDirect(Handle,PChar(S),SQL_NTS),SErrExecuting);
end;

procedure TODBCSQLStatement.ExecutePrepared;
begin
  if Not (FState in [ssPrepared,ssBound]) then
    ODBCError(SErrNotPrepared);
  CheckODBC(SQLExecute(Handle),SErrExecutingPrepared);
end;

function TODBCSQLStatement.GetActive: Boolean;
begin
  Result:=(FState=ssOpen);
end;

procedure TODBCSQLStatement.Open;
begin
  if (FState<>ssOpen) then
    begin
    Writeln('Preparing');
    If FState=ssInactive then
      Prepare;
    Writeln('Bind fields');
    if FState=ssPrepared then
      BindFields(Nil);
    Writeln('Executing');
    ExecSQL;
    Writeln('Fetching');
    If FState=ssBound then
      Fetch;
    FState:=ssOpen;
    FBOF:=True;
    end;
end;

procedure TODBCSQLStatement.Prepare;

Var
  S : String;

begin
  If FState<>ssInactive then
    ODBCError(SErrNotInactive);
  If (FSQL.Count=0) then
    ODBCError(SErrNoSQLStatement);
  S:=FSQL.Text;
  CheckODBC(SQLPrepare(Handle,PChar(S),SQL_NTS),SErrPreparing);
  FState:=ssPrepared;
end;

procedure TODBCSQLStatement.SetActive(const Value: Boolean);
begin
  If Value then
    Open
  else
    Close;
end;

procedure TODBCSQLStatement.SetSQL(const Value: TStrings);

begin
  FSQL.Assign(Value);
end;


procedure TODBCSQLStatement.BindFields(RestrictList: TStrings);
begin
  inherited;
  FState:=ssBound;
end;


procedure TODBCStatement.AllocBuffers;

Var
  I,TotalSize,AddSize : Integer;

begin
  TotalSize:=0;
  For i:=0 to FFields.Count-1 do
    With (FFields.Items[i] as TODBCField) do
        begin
        AddSize:=FBufSize;
        If FBufSize=-2 then // Blob.
          AddSize:=0
        else if FBufSize=-1 then
          AddSize:=FSize+1; // some Char variant.
        // Store offset temporarily in FData
        FBuffOffset:=TotalSize;
        Inc(TotalSize,AddSize+SizeOf(SQLinteger));
        end;
  FBuffer:=GetMem(TotalSize);
  TotalSize:=0;
  For i:=0 to FFields.Count-1 do
    With (FFields.Items[i] as TODBCField) do
      FBuffer:=Self.FBuffer;
end;

{ TODBCTableList }

procedure TODBCTableList.GetTableNames(S: TStrings; SystemTables : Boolean);

var
  TName,
  TType: array[0..SQL_NAME_LEN+1] of char;
  NL,TL: SQLINTEGER;
  Res: SQLRETURN;

begin
  S.Clear;
  Res:=CheckODBC(SQLTables(handle, nil,0,nil,0,nil,0,nil,0),SErrGettingTableNames);
  if Res=SQL_SUCCESS then
    begin
    // Must bind by colno, because names changed between ODBC 2.0 and 3.0 !!
    SQLBindCol(handle,3,SQL_CHAR,@TName,SQL_NAME_LEN,@NL);
    SQLBindCol(handle,4,SQL_CHAR,@TType,SQL_NAME_LEN,@TL);
    While Fetch do
      if SystemTables or (CompareText(TType,'SYSTEM TABLE')<>0) then
         S.Add(TName);
    end;
end;

{ TODBCFieldNamesList }

procedure TODBCFieldNamesList.GetFieldNames(TableName: String;
  S: TStrings);

var
  FName : array[0..SQL_NAME_LEN+1] of char;
  NF : SQLINTEGER;
  Res: SQLRETURN;

begin
  S.Clear;
  Res:=CheckODBC(SQLColumns(handle, nil, 0, nil, 0, pchar(TableName), SQL_NTS, nil, 0),SErrFieldNames);
  if Res=SQL_SUCCESS then
    begin
    SQLBindCol(handle, 4, SQL_CHAR, @FNAme, SQL_NAME_LEN, @NF);
    While Fetch do
       S.Add(FName);
    end;
end;

{ TODBCPrimaryKeyFieldsList }

procedure TODBCPrimaryKeyFieldsList.GetPrimaryKeyFields(TableName: String;
  S: TStrings);
var
  FName : array[0..SQL_NAME_LEN+1] of char;
  NF : SQLINTEGER;
  Res: SQLRETURN;

begin
  S.Clear;
  Res:=CheckODBC(SQLPrimaryKeys(handle, nil, 0, nil, 0, pchar(TableName), SQL_NTS),SErrPrimaryKeys);
  if Res=SQL_SUCCESS then
    begin
    SQLBindCol(handle, 4, SQL_CHAR, @FNAme, SQL_NAME_LEN, @NF);
    While Fetch do
       S.Add(FName);
    end;

end;

{ TODBCProcedureList }

procedure TODBCProcedureList.GetProcedureList(S: TStrings);

var
  PName : array[0..SQL_NAME_LEN+1] of char;
  NP : SQLINTEGER;
  Res: SQLRETURN;

begin
  S.Clear;
  Res:=CheckODBC(SQLProcedures(handle, nil, 0, nil, 0, Nil, 0),SErrProcedureNames);
  if Res=SQL_SUCCESS then
    begin
    SQLBindCol(handle, 3, SQL_CHAR, @PNAme, SQL_NAME_LEN, @NP);
    While Fetch do
      S.Add(PName);
    end;

end;

{ TODBCProcedureParams }

procedure TODBCProcedureParams.GetProcedureParams(ProcName: String;
  ParamTypes: TODBCParamTypes; S: TStrings);

var
  PName : array[0..SQL_NAME_LEN+1] of char;
  NP,NT : SQLINTEGER;
  Ptype : SQLSmallInt;
  Res: SQLRETURN;

begin
  S.Clear;
  Res:=CheckODBC(SQLProcedureColumns(handle, nil, 0, nil, 0, PChar(ProcName),SQL_NTS,Nil, 0),SErrProcedureNames);
  if Res=SQL_SUCCESS then
    begin
    SQLBindCol(handle, 4, SQL_CHAR, @PName, SQL_NAME_LEN, @NP);
    SQLBindCol(handle, 5, SQL_SMALLINT, @PType, SizeOf(SQLSmallInt), @NT);
    While Fetch do
      begin
      If TODBCParamType(PType) in ParamTypes then
        S.Add(PName);
      end;
    end;
end;

{ TODBCFieldList }

constructor TODBCFieldList.Create(Statement: TODBCStatement);
begin
  FStatement:=Statement;
  Inherited Create(TODBCField);
end;

{ TODBCField }

function TODBCField.GetAsString: String;
begin
  If IsNull then
    Result:=''
  else
    Case FBufType of
      SQL_Smallint : Result:=IntToStr(PSQLSmallInt(Data)^);
      SQL_Integer  : Result:=IntToStr(PSQLINTEGER(Data)^);
      SQL_BIT      : Result:=IntToStr(PByte(Data)^);
      SQL_CHAR     : Result:=StrPas(Data);
      SQL_DOUBLE   : Result:=FloatToStr(GetAsDouble);
      SQL_DATE     : result:=DateToStr(AsDateTime);
      SQL_TIME     : Result:=TimeToStr(AsDateTime);
      SQL_TIMESTAMP : result:=datetimeToStr(AsDateTime);
      SQL_TYPE_DATE  : result:=dateToStr(AsDateTime);
      SQL_TYPE_TIMESTAMP : result:=datetimeToStr(AsDateTime);
      SQL_TYPE_TIME : Result:=TimeToStr(AsDateTime);
    else
      ODBCError(SErrInvalidConversion)
    end;
end;

function TODBCField.GetData : Pchar;

begin
  Result:=FBuffer+FBuffOffset+SizeOf(SQLinteger);
end;

function TODBCField.GetIsNull : boolean;

begin
  Result:=PSQLinteger(FBuffer+FBuffOffset)^=SQL_NULL_DATA;
end;

Function TODBCField.GetAsInteger : Integer;

begin
  If IsNull then
    Result:=0
  else
    Case FBufType of
      SQL_Smallint : Result:=PSQLSmallInt(Data)^;
      SQL_Integer  : Result:=PSQLINTEGER(Data)^;
      SQL_BIT      : Result:=PByte(Data)^;
      SQL_CHAR     : Result:=StrToInt(GetAsString);
      SQL_DOUBLE   : Result:=Round(GetAsDouble);
      SQL_DATE,
      SQL_TIME,
      SQL_TIMESTAMP,
      SQL_TYPE_DATE,
      SQL_TYPE_TIMESTAMP,
      SQL_TYPE_TIME : Result:=Round(AsDateTime);
    else
      ODBCError(SErrInvalidConversion)
    end;
end;

Function TODBCField.GetAsBoolean : Boolean;

begin
  If IsNull then
    Result:=False
  else
    Case FBufType of
      SQL_Smallint : Result:=PSQLSmallInt(Data)^=0;
      SQL_Integer  : Result:=PSQLINTEGER(Data)^=0;
      SQL_BIT      : Result:=PBYTE(Data)^=0;
      SQL_CHAR     : Result:=(StrToInt(GetAsString)=0);
      SQL_DOUBLE   : Result:=Round(GetAsDouble)=0;
      SQL_DATE,
      SQL_TIME,
      SQL_TIMESTAMP,
      SQL_TYPE_DATE,
      SQL_TYPE_TIMESTAMP,
      SQL_TYPE_TIME : Result:=Round(AsDateTime)=0;
    else
      ODBCError(SErrInvalidConversion)
    end;
end;

Function TODBCField.GetAsDouble : Double;

begin
  If IsNull then
    Result:=0
  else
    Case FBufType of
      SQL_Smallint : Result:=PSQLSmallInt(Data)^;
      SQL_Integer  : Result:=PSQLINTEGER(Data)^;
      SQL_BIT      : Result:=PBYTE(Data)^;
      SQL_CHAR     : Result:=StrToFloat(GetAsString);
      SQL_DOUBLE   : Result:=PSQLDOUBLE(GetData)^;
      SQL_DATE,
      SQL_TIME,
      SQL_TIMESTAMP,
      SQL_TYPE_DATE,
      SQL_TYPE_TIMESTAMP,
      SQL_TYPE_TIME : Result:=AsDateTime;
    else
      ODBCError(SErrInvalidConversion)
    end;
end;

{
function DateStructToDateTime( b:PSQL_DATE_STRUCT):TDateTime;
function DateTimeToDateStruct( b:TDateTime):SQL_DATE_STRUCT;
procedure DateTime2TimeStampStruct( var Value:SQL_TIMESTAMP_STRUCT; b:TDateTime);
}
Function TODBCField.GetAsDateTime : TDateTime;

begin
  If IsNull then
    Result:=0
  else
    Case FBufType of
      SQL_Smallint : Result:=PSQLSmallInt(Data)^;
      SQL_Integer  : Result:=PSQLINTEGER(Data)^;
      SQL_BIT      : Result:=PBYTE(Data)^;
      SQL_CHAR     : Result:=StrToInt(GetAsString);
      SQL_DOUBLE   : Result:=PSQLDOUBLE(GetData)^;
      SQL_DATE     : Result:=DateStructToDateTime(PSQL_DATE_STRUCT(Data));
      SQL_TIME     : Result:=TimeStructToDateTime(PSQL_TIME_STRUCT(Data));
      SQL_TIMESTAMP : Result:=TimeStampStructToDateTime(PSQL_TIMESTAMP_STRUCT(Data));
      SQL_TYPE_DATE : Result:=DateStructToDateTime(PSQL_DATE_STRUCT(Data));
      SQL_TYPE_TIMESTAMP :  Result:=TimeStampStructToDateTime(PSQL_TIMESTAMP_STRUCT(Data));
      SQL_TYPE_TIME : Result:=TimeStructToDateTime(PSQL_TIME_STRUCT(Data));
    else
      ODBCError(SErrInvalidConversion)
    end;
end;

Finalization
  If Assigned(DefEnv) then
    TODBCEnvironment(DefEnv).Free;
end.