path: root/captain/sqlite.f90

! Copyright (c) 2021 Approximatrix, LLC <support@approximatrix.com>
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! The Software shall be used for Good, not Evil.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module sqlite
use iso_c_binding
implicit none

    integer(kind=c_int), parameter::SQLITE_OK = 0
    integer(kind=c_int), parameter::SQLITE_ERROR = 1
    integer(kind=c_int), parameter::SQLITE_BUSY = 5
    integer(kind=c_int), parameter::SQLITE_ROW = 100
    integer(kind=c_int), parameter::SQLITE_DONE = 101
    
    integer(kind=c_int), parameter::SQLITE_INTEGER = 1
    integer(kind=c_int), parameter::SQLITE_FLOAT = 2
    integer(kind=c_int), parameter::SQLITE_TEXT = 3
    integer(kind=c_int), parameter::SQLITE_BLOB = 4
    integer(kind=c_int), parameter::SQLITE_NULL = 5
    
    integer, parameter::sqlite3_max_free_strings = 32

    interface
        function c_strlen(p) bind(c, name='strlen')
        use iso_c_binding
        type(c_ptr), value::p
        integer(kind=c_size_t)::c_strlen
        end function c_strlen
        
        function c_malloc(x) bind(c, name='malloc')
        use iso_c_binding
        type(c_ptr)::c_malloc
        integer(kind=c_size_t), value::x
        end function c_malloc
        
        subroutine c_free(p) bind(c, name='free')
        use iso_c_binding
        type(c_ptr), value::p
        end subroutine c_free
        
        function c_strcpy(p1, p2) bind(c, name='strcpy')
        use iso_c_binding
        type(c_ptr), value::p1, p2
        type(c_ptr)::c_strcpy
        end function c_strcpy
        
    end interface
    
    ! Wrapping necessary
    interface
        function c_sqlite3_open(p,d) bind(c, name='sqlite3_open')
        use iso_c_binding
        type(c_ptr), value::p
        type(c_ptr), intent(out)::d
        integer(c_int)::c_sqlite3_open
        end function c_sqlite3_open
        
        function c_sqlite3_prepare(db, zsql, n, pstmt, punused) bind(c, name='sqlite3_prepare_v2')
        use iso_c_binding
        type(c_ptr), value::db, zsql
        type(c_ptr), intent(out)::pstmt, punused
        integer(c_int), value::n
        integer(c_int)::c_sqlite3_prepare
        end function c_sqlite3_prepare
        
        function c_sqlite3_bind_int(p, i, j) bind(c, name='sqlite3_bind_int')
        use iso_c_binding
        type(c_ptr), value::p
        integer(c_int), value::i, j
        integer(c_int)::c_sqlite3_bind_int
        end function c_sqlite3_bind_int
        
        function c_sqlite3_bind_text(p, i, str, j, pfunc) bind(c, name='sqlite3_bind_text')
        use iso_c_binding
        type(c_ptr), value::p, str, pfunc
        integer(c_int), value::i, j
        integer(c_int)::c_sqlite3_bind_text
        end function c_sqlite3_bind_text
        
        function c_sqlite3_bind_null(p, i) bind(c, name='sqlite3_bind_null')
        use iso_c_binding
        type(c_ptr), value::p
        integer(c_int), value::i
        integer(c_int)::c_sqlite3_bind_null
        end function c_sqlite3_bind_null
        
        function c_sqlite3_column_int(p, i) bind(c, name='sqlite3_column_int')
        use iso_c_binding
        type(c_ptr), value::p
        integer(c_int), value::i
        integer(c_int)::c_sqlite3_column_int
        end function c_sqlite3_column_int
        
        function c_sqlite3_column_text(p, i) bind(c, name='sqlite3_column_text')
        use iso_c_binding
        type(c_ptr), value::p
        integer(c_int), value::i
        type(c_ptr)::c_sqlite3_column_text
        end function c_sqlite3_column_text
        
    end interface

    ! Good to go
    interface
        function sqlite3_close(p) bind(c, name='sqlite3_close')
        use iso_c_binding
        type(c_ptr), value::p
        integer(c_int)::sqlite3_close
        end function sqlite3_close
        
        function sqlite3_finalize(p) bind(c, name='sqlite3_finalize')
        use iso_c_binding
        type(c_ptr), value::p
        integer(c_int)::sqlite3_finalize
        end function sqlite3_finalize
        
        function sqlite3_step(p) bind(c, name='sqlite3_step')
        use iso_c_binding
        type(c_ptr), value::p
        integer(c_int)::sqlite3_step
        end function sqlite3_step
        
        function sqlite3_column_type(p, c) bind(c, name='sqlite3_column_type')
        use iso_c_binding
        type(c_ptr), value::p
        integer(kind=c_int), value::c
        integer(c_int)::sqlite3_column_type
        end function sqlite3_column_type
        
    end interface
    
    type :: sqlite3_stmt
    
        type(c_ptr)::stmt
        
        type(c_ptr), dimension(sqlite3_max_free_strings)::pointers
        
        contains
        
        procedure::prepare => stmt_prepare
        procedure::finalize => stmt_finalize
        procedure::bind_int => stmt_bind_int
        procedure::bind_text => stmt_bind_text
        procedure::bind_null => stmt_bind_null
        procedure::step => stmt_step
        procedure::step_now => stmt_step_ignore
        procedure::column_int => stmt_column_int
        procedure::column_text => stmt_column_text
        procedure::column_type => stmt_column_type
        
    end type
    
contains

    function c_string(str)
    use iso_c_binding
    implicit none
    
        type(c_ptr)::c_string
        character(*), intent(in)::str
        
        character(len=:), pointer::src
        
        allocate(character(len=len_trim(str)+1) :: src)
        src = trim(str)//c_null_char
        
        c_string = c_malloc(int(len_trim(str)+1, kind=c_size_t))
        c_string = c_strcpy(c_string, c_loc(src))
        
        deallocate(src)
        
    end function c_string

    function sqlite3_open(filename, db)
    implicit none
    
        character(*), intent(in)::filename
        type(c_ptr), intent(out)::db
        integer::sqlite3_open
        
        type(c_ptr)::cstr
        
        cstr = c_string(filename)
        
        sqlite3_open = c_sqlite3_open(cstr, db)
        
        call c_free(cstr)
    
    end function sqlite3_open
    
    function sqlite3_prepare(db, txt_stmt, stmt)
    use iso_c_binding
    implicit none
    
        type(c_ptr)::db
        type(c_ptr), intent(out)::stmt
        character(*), intent(in)::txt_stmt
        integer::sqlite3_prepare
        
        type(c_ptr)::csql, ctail
        
        csql = c_string(txt_stmt)
        
        sqlite3_prepare = c_sqlite3_prepare(db, csql, len_trim(txt_stmt), stmt, ctail)
        
        call c_free(csql)
    
    end function sqlite3_prepare
    
    subroutine stmt_finalize(self)
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        
        integer::istatus, i
    
        istatus = sqlite3_finalize(self%stmt)
        
        i = 1
        do while(c_associated(self%pointers(i)))
            call c_free(self%pointers(i))
            i = i + 1
        end do
        
    end subroutine stmt_finalize
    
    function stmt_prepare(self, db, txt)
    use iso_c_binding
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        type(c_ptr)::db
        character(*), intent(in)::txt
        integer::stmt_prepare
        type(c_ptr)::ctail
        
        self%pointers = c_null_ptr
        
        self%pointers(1) = c_string(txt)
        
        stmt_prepare = c_sqlite3_prepare(db, self%pointers(1), len_trim(txt), self%stmt, ctail)
    
    end function stmt_prepare
    
    function stmt_bind_int(self, i, j)
    use iso_c_binding
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        integer::i, j, stmt_bind_int
        
        stmt_bind_int = c_sqlite3_bind_int(self%stmt, int(i, c_int), int(j, c_int))
        
    end function stmt_bind_int
    
    function stmt_bind_text(self, i, text)
    use iso_c_binding
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        integer::i, stmt_bind_text
        character(*), intent(in)::text
        integer::iptr
        
        iptr = 2
        do while(c_associated(self%pointers(iptr)))
            iptr = iptr + 1
        end do
        
        self%pointers(iptr) = c_string(text)
        
        stmt_bind_text = c_sqlite3_bind_text(self%stmt, int(i, c_int), self%pointers(iptr), &
                                             int(-1, c_int), c_null_ptr)
                
    end function stmt_bind_text
    
    function stmt_bind_null(self, i)
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        integer, intent(in)::i
        integer::stmt_bind_null
        
        stmt_bind_null = c_sqlite3_bind_null(self%stmt, int(i, c_int))
    
    end function stmt_bind_null
    
    function stmt_step(self)
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        integer::stmt_step
        
        stmt_step = sqlite3_step(self%stmt)
        
    end function stmt_step
    
    subroutine stmt_step_ignore(self)
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        integer::ignored
        
        ignored = sqlite3_step(self%stmt)
        
    end subroutine stmt_step_ignore
    
    function stmt_column_int(self, i)
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        integer, intent(in)::i
        integer::stmt_column_int
    
        if(self%column_type(i) /= SQLITE_NULL) then
            stmt_column_int = c_sqlite3_column_int(self%stmt, i)
        else
            stmt_column_int = -1*huge(1)
        end if
    
    end function stmt_column_int
    
    function stmt_column_type(self, i)
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        integer, intent(in)::i
        integer::stmt_column_type
    
        stmt_column_type = sqlite3_column_type(self%stmt, i)
    
    end function stmt_column_type
    
    subroutine stmt_column_text(self, i, res)
    implicit none
    
        class(sqlite3_stmt), intent(inout)::self
        integer, intent(in)::i
        character(*), intent(out)::res
        
        character(kind=c_char), dimension(:), pointer::src
        type(c_ptr)::txtcol
        integer(kind=8)::n, i_char
    
        res = " "
        
        if(self%column_type(i) /= SQLITE_NULL) then
            txtcol = c_sqlite3_column_text(self%stmt, i)
            if(c_associated(txtcol)) then
                n = c_strlen(txtcol)
                call c_f_pointer(txtcol, src, (/ n /))
                do i_char=1, min(n, len(res))
                    res(i_char:i_char) = src(i_char)
                end do
            end if
        end if
    
    end subroutine stmt_column_text
    
end module sqlite