From 2a79043e4b33118437b3ade35a792b9e0d1323be Mon Sep 17 00:00:00 2001 From: Jeffrey Armstrong Date: Thu, 25 Mar 2021 16:50:32 -0400 Subject: Started on server components. Implemented thin, only-necessary sqlite wrapping in Fortran. --- player/levitating-player-windows.prj | 8 +- player/levitating-player.prj | 8 +- player/utilities.F90 | 222 ----------------------------------- 3 files changed, 8 insertions(+), 230 deletions(-) delete mode 100644 player/utilities.F90 (limited to 'player') diff --git a/player/levitating-player-windows.prj b/player/levitating-player-windows.prj index 0566b8a..5b0e5e0 100644 --- a/player/levitating-player-windows.prj +++ b/player/levitating-player-windows.prj @@ -15,6 +15,9 @@ },{ "filename":"..\\common\\request.f90", "enabled":"1" + },{ + "filename":".\\common\\utilities.F90", + "enabled":"1" },{ "filename":"..\\common\\wsa.f90", "enabled":"1" @@ -39,9 +42,6 @@ },{ "filename":".\\tasks.f90", "enabled":"1" - },{ - "filename":".\\utilities.F90", - "enabled":"1" }] }, "Name":"levitating-player-windows (levitating-player.exe)", @@ -99,4 +99,4 @@ "Link LAPACK":0 } } -} \ No newline at end of file +} diff --git a/player/levitating-player.prj b/player/levitating-player.prj index aaed51c..bda2479 100644 --- a/player/levitating-player.prj +++ b/player/levitating-player.prj @@ -15,6 +15,9 @@ },{ "filename":"..\\common\\request.f90", "enabled":"1" + },{ + "filename":".\\common\\utilities.F90", + "enabled":"1" },{ "filename":"..\\common\\wsa.f90", "enabled":"1" @@ -39,9 +42,6 @@ },{ "filename":".\\tasks.f90", "enabled":"1" - },{ - "filename":".\\utilities.F90", - "enabled":"1" }] }, "Name":"levitating-player (target.exe)", @@ -99,4 +99,4 @@ "Link LAPACK":0 } } -} \ No newline at end of file +} diff --git a/player/utilities.F90 b/player/utilities.F90 deleted file mode 100644 index 2e19031..0000000 --- a/player/utilities.F90 +++ /dev/null @@ -1,222 +0,0 @@ -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 -- cgit v1.2.3