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. --- captain/captian.f90 | 12 ++ captain/db.f90 | 48 ++++++ captain/levitating-captain.prj | 100 +++++++++++ captain/sql/create.sql | 10 ++ captain/sqlite.f90 | 325 +++++++++++++++++++++++++++++++++++ common/utilities.F90 | 222 ++++++++++++++++++++++++ player/levitating-player-windows.prj | 8 +- player/levitating-player.prj | 8 +- player/utilities.F90 | 222 ------------------------ 9 files changed, 725 insertions(+), 230 deletions(-) create mode 100644 captain/captian.f90 create mode 100644 captain/db.f90 create mode 100644 captain/levitating-captain.prj create mode 100644 captain/sql/create.sql create mode 100644 captain/sqlite.f90 create mode 100644 common/utilities.F90 delete mode 100644 player/utilities.F90 diff --git a/captain/captian.f90 b/captain/captian.f90 new file mode 100644 index 0000000..e115280 --- /dev/null +++ b/captain/captian.f90 @@ -0,0 +1,12 @@ +program captain +use captain_db +implicit none + + + call initialize_db("/tmp/test.db") + + call add_player_db("windows", "asdf") + + call shutdown_db() + +end program captain \ No newline at end of file diff --git a/captain/db.f90 b/captain/db.f90 new file mode 100644 index 0000000..1efbb18 --- /dev/null +++ b/captain/db.f90 @@ -0,0 +1,48 @@ +module captain_db +use sqlite +implicit none + + character(1024)::database_file + type(c_ptr)::db + +contains + + subroutine initialize_db(filename) + implicit none + + character(*), intent(in)::filename + + if(sqlite3_open(filename, db) == SQLITE_OK) then + database_file = filename + else + Print *, "ERROR: Could not open db" + stop + end if + + end subroutine initialize_db + + subroutine shutdown_db() + implicit none + + integer::i + + i = sqlite3_close(db) + + end subroutine shutdown_db + + subroutine add_player_db(name, token) + implicit none + + character(*), intent(in)::name, token + type(sqlite3_stmt)::stmt + + if(stmt%prepare(db, "INSERT INTO players(name, token) VALUES(?, ?)") == SQLITE_OK) then + if(stmt%bind_text(1, "name!") == SQLITE_OK .and. stmt%bind_text(2, "token!") == SQLITE_OK) then + call stmt%step_now() + end if + end if + call stmt%finalize() + + end subroutine add_player_db + +end module captain_db diff --git a/captain/levitating-captain.prj b/captain/levitating-captain.prj new file mode 100644 index 0000000..3a11a71 --- /dev/null +++ b/captain/levitating-captain.prj @@ -0,0 +1,100 @@ +{ + "Root":{ + "Folders":[{ + "Folders":[], + "Name":"+common", + "Files":[{ + "filename":"../common/jessl.f90", + "enabled":"1" + },{ + "filename":"../common/network.F90", + "enabled":"1" + },{ + "filename":"../common/protocol.f90", + "enabled":"1" + },{ + "filename":"../common/request.f90", + "enabled":"1" + },{ + "filename":"../common/utilities.F90", + "enabled":"1" + },{ + "filename":"../common/wsa.f90", + "enabled":"0" + }] + },{ + "Folders":[], + "Name":"+sql", + "Files":[{ + "filename":"sql/create.sql", + "enabled":"1" + }] + }], + "Name":"+levitating-captain (levitating-captain)", + "Files":[{ + "filename":"captian.f90", + "enabled":"1" + },{ + "filename":"db.f90", + "enabled":"1" + },{ + "filename":"sqlite.f90", + "enabled":"1" + }] + }, + "Name":"levitating-captain (levitating-captain)", + "Options":{ + "Compiler Options":{ + "Fortran Flags":"", + "Link Flags":"-lsqlite3 -lssl -lcrypt", + "C Flags":"" + }, + "Architecture":0, + "Type":0, + "Revision":2, + "Windows GUI":0, + "File Options":{ + "Library Directories":["Default Library Directory"], + "Build Directory":"build", + "Module Directory":"modules", + "Include Directories":["Default Include Directory"] + }, + "Target":"levitating-captain", + "Fortran Options":{ + "Use C Preprocessor":"false", + "Runtime Diagnostics":"false", + "Floating Point Exception Trap":0, + "Cray Pointers":"false", + "Enable Coarrays":"false", + "Enable OpenMP":"false", + "Initialize Variables to Zero":"false", + "Default Double for Real":"false" + }, + "Code Generation Options":{ + "CPU Specific":"false", + "Processor":"generic", + "Aggressive Loops":"false", + "Debugging":"true", + "Optimization Mode":0, + "Profiling":"false" + }, + "Build Dependencies":1, + "Launch Options":{ + "Working Directory":"", + "Launch Using MPI":"false", + "Keep Console":"true", + "External Console":"false", + "Command Line Arguments":"", + "Build Before Launch":"true" + }, + "Build Options":{ + "Makefile":"Makefile", + "Auto Makefile":"true" + }, + "Linker Options":{ + "Static Linking Mode":0, + "Link MPI Library":"false", + "Link LAPACK":0 + } + } +} \ No newline at end of file diff --git a/captain/sql/create.sql b/captain/sql/create.sql new file mode 100644 index 0000000..d78c90c --- /dev/null +++ b/captain/sql/create.sql @@ -0,0 +1,10 @@ + +CREATE TABLE players(id INTEGER PRIMARY KEY, name TEXT NOT NULL, token TEXT NOT NULL); + +CREATE TABLE jobs(id INTEGER PRIMARY KEY, player INTEGER DEFAULT NULL, status INTEGER, FOREIGN KEY(player) REFERENCES players(id)); + +CREATE TABLE tasks(job INTEGER, task INTEGER, status INTEGER, FOREIGN KEY(job) REFERENCES jobs(id)); + +CREATE TABLE instructions(id INTEGER PRIMARY KEY, name TEXT NOT NULL, file TEXT NOT NULL); + +CREATE_TABLE available(instructions INTEGER, player INTEGER, FOREIGN KEY(instructions) REFERENCES instructions(id), FOREIGN KEY(player) REFERENCES players(id)); diff --git a/captain/sqlite.f90 b/captain/sqlite.f90 new file mode 100644 index 0000000..003bd6f --- /dev/null +++ b/captain/sqlite.f90 @@ -0,0 +1,325 @@ +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, 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 + + 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 + + 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 + + stmt_column_int = c_sqlite3_column_int(self%stmt, i) + + end function stmt_column_int + + 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::n, i_char + + txtcol = c_sqlite3_column_text(self%stmt, i) + res = " " + + 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 subroutine stmt_column_text + +end module sqlite \ No newline at end of file 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 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