connection.f90

 
#include <c_interop.inc>
!! @endcond
module odbc_connection
    use, intrinsic :: iso_c_binding
    use, intrinsic :: iso_fortran_env, only: stderr => error_unit
    use sql
    use sqlext
    use odbc_constants
    use odbc_resultset, only: resultset, new
 
    implicit none; private
    
    public :: resultset
 
    type, public :: connection
        private
        type(SQLHENV)                   :: env
        type(SQLHDBC)                   :: dbc
        type(SQLHSTMT)                  :: stmt
        logical                         :: opened
        integer                         :: timeout
        integer(SQLSMALLINT)            :: rec
        character(kind=SQLTCHAR, len=6) :: state
        character(kind=SQLTCHAR, len=SQL_MAX_MESSAGE_LENGTH) :: msg
        integer(SQLINTEGER)             :: ierr
        integer(SQLSMALLINT)            :: imsg
        character(1024)                 :: connstring
    contains
        private
        procedure, pass(this), public   :: set_timeout  => connection_set_timeout
        procedure, pass(this), public   :: get_timeout  => connection_get_timeout
        procedure, pass(this), public   :: is_open    => connection_isopened
        procedure, pass(this), private  :: connection_open
        generic, public                 :: open         => connection_open
        procedure, pass(this), public   :: execute      => connection_execute
        procedure, pass(this), private  :: connection_execute_query
        procedure, pass(this), private  :: connection_execute_query_with_cursor
        generic, public                 :: execute_query => connection_execute_query, &
                                                            connection_execute_query_with_cursor
        procedure, pass(this), public   :: commit       => connection_commit
        procedure, pass(this), public   :: rollback     => connection_rollback
        procedure, pass(this), public   :: close        => connection_close
        final :: connection_finalize
    end type
 
    interface connection
        module procedure :: connection_new
    end interface
 
    interface throw
            module procedure :: throw_i2
            module procedure :: throw_i4
    end interface
 
contains
 
    function connection_new(connstring) result(that)
        type(connection)            :: that
        character(*), intent(in)    :: connstring
 
        that%env = null
        that%dbc = null
        that%stmt = null
        that%opened = .false.
        that%timeout = 10
        that%rec = _short(1)
        that%connstring = _string(connstring)
    end function
 
    subroutine connection_open(this)
        class(connection), intent(inout)    :: this
 
        this%ierr = sqlallochandle(sql_handle_env, sql_null_handle, this%env)
        if (this%ierr /= 0) call handle_error(this, 'ENV')
 
        this%ierr = sqlsetenvattr(this%env, sql_attr_odbc_version, _ptr(sql_ov_odbc3), 0)
        if (this%ierr /= 0) call handle_error(this, 'ENV')
 
        this%ierr = sqlallochandle(sql_handle_dbc, this%env, this%dbc)
        if (this%ierr == sql_error) then
            call handle_error(this, 'ENV')
        else if (this%ierr == sql_invalid_handle .or. this%ierr < sql_success) then
            call handle_error(this, 'ENV')
        end if
 
        this%ierr = sqldriverconnect(this%dbc, null, this%connstring &
                , int(len_trim(this%connstring), c_short), str_null_ptr, _short(0), short_null_ptr, sql_driver_complete)
        if (this%ierr /= sql_success) call handle_error(this, 'DBC')
 
        this%ierr = sqlallocstmt(this%dbc, this%stmt)
        if (this%ierr /= sql_success) call handle_error(this, 'DBC')
 
        this%opened = .true.
    end subroutine
 
    function connection_get_timeout(this) result(res)
        class(connection), intent(in)       :: this
        integer :: res
 
        res = this%timeout
    end function
 
    subroutine connection_set_timeout(this, n)
        class(connection), intent(inout)    :: this
        integer, intent(in)                 :: n
 
        this%timeout = n
    end subroutine
 
    function connection_isopened(this) result(res)
        class(connection), intent(in)       :: this
        logical :: res
 
        res = this%opened
    end function
 
    function connection_execute(this, sql) result(count)
        class(connection), intent(inout)    :: this
        character(*), intent(in)            :: sql
        integer(c_int) :: count
        !private
        integer(SQLLEN), allocatable :: countint
        character(len(sql)) :: tmp
 
        if (.not. this%opened) call handle_error(this, 'Call Open() before execute()')
 
        this%ierr = sqlprepare(this%stmt, _string(sql), sql_nts)
        if (this%ierr == sql_error) call handle_error(this, 'STMT')
 
        this%ierr = sqlexecute(this%stmt)
        if (this%ierr == sql_error .or. this%ierr < sql_success) call handle_error(this, 'STMT')
 
        allocate(countint, source = _long(0))
        tmp = to_lower(sql)
        if (index(tmp, 'update') > 0 .or. &
            index(tmp, 'insert') > 0 .or. &
            index(tmp, 'delete') > 0) then
            this%ierr = sqlrowcount(this%stmt, countint)
        end if
        count = merge(int(this%ierr, c_int), int(countint, c_int), this%ierr /= sql_success)
    end function   
 
    subroutine connection_execute_query(this, sql, rslt)
        class(connection), intent(inout)    :: this
        character(*), intent(in)            :: sql
        type(resultset), intent(inout)      :: rslt
        !private
        integer(c_int), target :: cursor
 
        cursor = sql_cursor_dynamic
 
        if (.not. this%opened) call throw('Connection not opened', sql_error)
 
        this%ierr = sqlfreestmt(this%stmt, sql_close)
        this%ierr = sqlallocstmt(this%dbc, this%stmt)
        if (this%ierr == sql_error .or. &
            this%ierr == sql_invalid_handle .or. &
            this%ierr < sql_success) call handle_error(this, 'DBC')
 
        this%ierr = sqlsetstmtattr(this%stmt, sql_attr_cursor_type, c_loc(cursor), sql_is_integer)
        if (this%ierr < sql_success) call handle_error(this, 'STMT')
 
        this%ierr = sqlexecdirect(this%stmt, _string(sql), sql_nts)
        if (this%ierr == -1) call handle_error(this, 'STMT')
 
        call new(rslt, this%stmt)
    end subroutine
 
    subroutine connection_execute_query_with_cursor(this, sql, cursor_type, scrollable, rslt)
        class(connection), intent(inout)        :: this
        character(*), intent(in)                :: sql
        integer(c_short), intent(in), target    :: cursor_type
        logical, intent(in)                     :: scrollable
        type(resultset), intent(inout)          :: rslt
        !private
        integer(c_short), target :: dummy
 
        dummy = sql_scrollable
 
        if (.not. this%opened) call throw('Connection not opened', sql_error)
 
        if (cursor_type /= sql_cursor_dynamic .and. cursor_type /= sql_cursor_forward_only &
            .and. cursor_type /= sql_cursor_keyset_driven &
            .and. cursor_type /= sql_cursor_static) then
            call throw('Invalid cursor type', sql_error)
        end if
 
        this%ierr = sqlfreestmt(this%stmt, sql_close)
        this%ierr = sqlallocstmt(this%dbc, this%stmt)
        if (this%ierr == sql_error .or. &
            this%ierr == sql_invalid_handle .or. &
            this%ierr < sql_success) call handle_error(this, 'DBC')
 
        this%ierr = sqlsetstmtattr(this%stmt, sql_attr_cursor_type, c_loc(cursor_type), sql_is_integer)
        if (this%ierr < sql_success) call handle_error(this, 'STMT')
 
        if (scrollable) then
            this%ierr = sqlsetstmtattr(this%stmt, sql_attr_cursor_scrollable, c_loc(dummy), sql_is_integer)
            if (this%ierr < sql_success) call handle_error(this, 'STMT')
        end if
 
        this%ierr = sqlexecdirect(this%stmt, sql, len_trim(sql))
        if (this%ierr == sql_error) call handle_error(this, 'STMT')
 
        call new(rslt, this%stmt)
    end subroutine
 
    function connection_commit(this) result(success)
        class(connection), intent(inout)    :: this
        logical :: success
 
        this%ierr = sqlendtran(sql_handle_dbc, this%dbc, sql_commit)
        if (this%ierr == sql_error .or. &
            this%ierr == sql_invalid_handle) call throw('Commit failed', this%ierr)
 
        success = .true.
    end function
 
    function connection_rollback(this) result(success)
        class(connection), intent(inout)    :: this
        logical :: success
 
        this%ierr = sqlendtran(sql_handle_dbc, this%dbc, sql_rollback)
        if (this%ierr == sql_error .or.&
            this%ierr == sql_invalid_handle) call throw('Rollback failed', this%ierr)
 
        success = .true.
    end function
 
    subroutine connection_close(this)
        class(connection), intent(inout)    :: this
 
        if (this%opened) then
            this%ierr = sqlfreestmt(this%stmt, sql_close)
            this%ierr = sqldisconnect(this%dbc)
            this%ierr = sqlfreeconnect(this%dbc)
            this%ierr = sqlfreeenv(this%env)
            this%opened = .false.
        end if
    end subroutine
 
    subroutine connection_finalize(this)
        type(connection), intent(inout)    :: this
 
        call this%close()
    end subroutine
 
    subroutine handle_error(this, type)
        class(connection), intent(inout), target    :: this
        character(*), intent(in)                    :: type
        !private
        integer(SQLRETURN) :: status
 
        ! Error handling
        if (trim(type) == 'STMT') then
            status = sqlgetdiagrec(sql_handle_stmt, this%stmt, this%rec, &
                                    this%state, this%ierr, this%msg, &
                                    len(this%msg, sqlsmallint), this%imsg)
        else if (trim(type) == 'ENV') then
            status = sqlgetdiagrec(sql_handle_env, this%env, this%rec, &
                                    this%state, this%ierr, this%msg, &
                                    len(this%msg, sqlsmallint), this%imsg)
        else if (trim(type) == 'DBC') then
            status = sqlgetdiagrec(sql_handle_dbc, this%dbc, this%rec, &
                                   this%state, this%ierr, this%msg, &
                                   len(this%msg, sqlsmallint), this%imsg)
        else
            call throw(trim(this%msg), this%ierr)
        end if
 
        if (status /= sql_success) then
            call throw(trim(this%msg), this%ierr)
        end if
    end subroutine
 
    subroutine throw_i2(msg, ierr)
        character(*), intent(in)         :: msg
        integer(SQLSMALLINT), intent(in) :: ierr
 
        write(stderr, '("connection error: ", A, "Error code: ", i0)') msg, ierr
        error stop ierr
    end subroutine
 
    subroutine throw_i4(msg, ierr)
        character(*), intent(in)        :: msg
        integer(SQLINTEGER), intent(in) :: ierr
 
        write(stderr, '("connection error: ", A, "Error code: ", i0)') msg, ierr
        error stop ierr
    end subroutine
    
    pure function to_lower(str) result(res)
        character(*), intent(in)    :: str
        character(len(str))         :: res
        !private
        integer :: i,j
        integer, parameter :: a = iachar('A'), z = iachar('Z') 
        
        do i = 1, len(str)
            j = iachar(str(i:i))
            if (j >= a .and. j <= z) then
                res(i:i) = achar(iachar(str(i:i)) + 32)
            else
                res(i:i) = str(i:i)
            end if
        end do
    end function
end module