aboutsummaryrefslogtreecommitdiff
path: root/common
diff options
context:
space:
mode:
authorJeffrey Armstrong <jeff@approximatrix.com>2021-03-25 16:50:32 -0400
committerJeffrey Armstrong <jeff@approximatrix.com>2021-03-25 16:50:32 -0400
commit2a79043e4b33118437b3ade35a792b9e0d1323be (patch)
treeea2e50b8a624543b59ab8a0da7b3a630dd9143f0 /common
parent1545914afff13e37bfcfee1b04828942e430a819 (diff)
downloadlevitating-2a79043e4b33118437b3ade35a792b9e0d1323be.tar.gz
levitating-2a79043e4b33118437b3ade35a792b9e0d1323be.zip
Started on server components. Implemented thin, only-necessary sqlite wrapping in Fortran.
Diffstat (limited to 'common')
-rw-r--r--common/utilities.F90222
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