Started on server components. Implemented thin, only-necessary sqlite wrapping in Fortran.

1 files changed, 222 insertions, 0 deletions

diff --git a/common/utilities.F90 b/common/utilities.F90
new file mode 100644
index 0000000..2e19031
--- /dev/null
+++ b/common/utilities.F90
@@ -0,0 +1,222 @@
+module utilities
+
+#ifdef WINDOWS
+    character, parameter::dir_sep = '\'
+#else
+    character, parameter::dir_sep = '/'
+#endif
+
+contains
+
+    function is_absolute_path(path)
+    implicit none
+    
+        logical::is_absolute_path
+        character(len=*), intent(in)::path
+        
+        is_absolute_path = .false.
+        if(path(1:1) == dir_sep) then
+            is_absolute_path = .true.
+        else
+#ifdef WINDOWS
+            if(path(2:2) == ":") then
+                is_absolute_path = .true.
+            end if
+#endif
+        end if
+        
+    end function is_absolute_path
+        
+    subroutine combine_paths(first, second, res)
+    implicit none
+    
+        character(len=*), intent(in)::first, second
+        character(len=*), intent(out)::res
+    
+        integer::i
+        
+        i = len_trim(first)
+    
+        if(first(i:i) == dir_sep) then
+            res = trim(first)//trim(second)
+        else
+            res = trim(first)//dir_sep//trim(second)
+        end if
+        
+    end subroutine combine_paths
+    
+    subroutine write_date_and_time(unit_number, values)
+    implicit none
+    
+        integer, intent(in)::unit_number
+        integer, intent(in), dimension(8)::values
+
+        write(unit_number, '(I4, A1, I2, A1, I2, 1X, I2, A1, I2, A1, I2)') &
+            values(1), "-", &
+            values(2), "-", &
+            values(3),  &
+            values(5), ":", &
+            values(6), ":", &
+            values(7)
+
+    end subroutine write_date_and_time
+    
+    function remove_directory(absolute_dir, and_files)
+    implicit none
+    
+        character(*), intent(in)::absolute_dir
+        logical, intent(in), optional::and_files
+        logical::remove_directory
+        
+        character(len=8)::cmd, flags
+        integer::retval
+        
+#ifdef WINDOWS        
+        flags = " "
+        cmd = "rmdir"
+#else
+        flags = "-r"
+        cmd = "rm"
+#endif
+
+        if(present(and_files)) then
+            if(and_files) then
+#ifdef WINDOWS
+                flags = "/S /Q"
+#else
+                flags = "-rf"
+#endif
+            end if
+        end if
+        
+        call execute_command_line(trim(cmd)//" "//trim(flags)//" "//trim(absolute_dir), &
+                                  wait=.true., exitstat=retval)
+            
+        remove_directory = (retval == 0)
+        
+    end function remove_directory
+    
+    function read_into_buffer(unit_number, buffer)
+    implicit none
+    
+        integer, intent(in)::unit_number
+        character, dimension(*), intent(out)::buffer
+        integer::read_into_buffer
+        
+        integer::i, ierr
+        
+        ierr = 0
+        i = 0
+        do while(ierr == 0 .and. i < len(buffer))
+            i = i + 1
+            read(unit_number, iostat=ierr) buffer(i)
+        end do
+            
+        if(ierr /= 0) then
+            i = i - 1
+        end if
+        
+        read_into_buffer = i
+    
+    end function read_into_buffer
+    
+    function generate_temporary_filename() result(fullpath)
+    use iso_c_binding
+    implicit none
+    
+        character(len=:), pointer::fullpath
+        type(c_ptr)::tmp_name
+        character(kind=c_char), dimension(:), pointer::cfullpath
+        integer(kind=c_size_t)::clength
+        integer::i
+        
+        interface
+            function c_strlen(p) bind(c, name='strlen')
+            use iso_c_binding
+            type(c_ptr), value::p
+            integer(kind=c_size_t)::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
+            
+        end interface
+
+#ifdef WINDOWS
+        interface
+            function GetTempPath(n, b) bind(c, name='GetTempPathA')
+            use iso_c_binding
+            integer(kind=c_int32_t)::GetTempPath
+            integer(kind=c_int32_t), value::n
+            type(c_ptr), value::b
+            end function GetTempPath
+        
+            function GetTempFileName(pn, prefix, unique, b) bind(c, name='GetTempFileNameA')
+            use iso_c_binding
+            integer(kind=c_int)::GetTempFileName
+            integer(kind=c_int), value::unique
+            type(c_ptr), value::pn, prefix, b
+            end function GetTempFileName
+        end interface
+        
+        type(c_ptr)::tmp_path
+        integer::res
+        
+        tmp_path = c_malloc(int(1024, kind=c_size_t))
+        res = GetTempPath(1023, tmp_path)
+        
+        tmp_name = c_malloc(int(1024, kind=c_size_t))
+        res = GetTempFileName(tmp_path, c_null_ptr, 0, tmp_name)
+        
+        call c_free(tmp_path)
+#else
+        interface
+            function tmpnam(p) bind(c, name='tmpnam')
+            use iso_c_binding
+            type(c_ptr), value::p
+            type(c_ptr)::tmpnam
+            end function tmpnam
+        end interface
+        
+        type(c_ptr)::ignored
+        
+        tmp_name = c_malloc(int(1024, kind=c_size_t))
+        
+        ignored = tmpnam(tmp_name)
+#endif
+
+        ! Convert the C Ptr to a Fortran object
+        clength = c_strlen(tmp_name)
+        call c_f_pointer(tmp_name, cfullpath, (/ clength /))
+        allocate(character(len=clength)::fullpath)
+        do i = 1, clength
+            fullpath(i:i) = cfullpath(i)
+        end do
+        
+        cfullpath => null()
+        call c_free(tmp_name)
+        
+    end function generate_temporary_filename
+    
+    subroutine delete_file(filename)
+    implicit none
+    
+        character(*), intent(in)::filename
+        
+#ifdef GNU
+        call unlink(filename)
+#else
+        ! Not implemented...
+#endif
+
+    end subroutine delete_file
+    
+end module utilities
\ No newline at end of file