From 3c9e6105c8458f6a59d2edc6fd7f2e79c18de943 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Thu, 27 May 2021 20:04:51 +0200 Subject: Allow fpm to change the working directory --- src/fpm_os.F90 | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 79 insertions(+) create mode 100644 src/fpm_os.F90 (limited to 'src/fpm_os.F90') diff --git a/src/fpm_os.F90 b/src/fpm_os.F90 new file mode 100644 index 0000000..825df58 --- /dev/null +++ b/src/fpm_os.F90 @@ -0,0 +1,79 @@ +module fpm_os + use, intrinsic :: iso_c_binding, only : c_char, c_int, c_null_char + use fpm_error, only : error_t, fatal_error + implicit none + private + public :: change_directory, get_current_directory + +#ifndef _WIN32 + character(len=*), parameter :: pwd_env = "PWD" +#else + character(len=*), parameter :: pwd_env = "CD" +#endif + + interface + function chdir(path) result(stat) & +#ifndef _WIN32 + bind(C, name="chdir") +#else + bind(C, name="_chdir") +#endif + import :: c_char, c_int + character(kind=c_char, len=1), intent(in) :: path(*) + integer(c_int) :: stat + end function chdir + end interface + +contains + + subroutine change_directory(path, error) + character(len=*), intent(in) :: path + type(error_t), allocatable, intent(out) :: error + + character(kind=c_char, len=1), allocatable :: cpath(:) + integer :: stat + + allocate(cpath(len(path)+1)) + call f_c_character(path, cpath, len(path)+1) + + stat = chdir(cpath) + + if (stat /= 0) then + call fatal_error(error, "Failed to change directory to '"//path//"'") + end if + end subroutine change_directory + + subroutine f_c_character(rhs, lhs, len) + character(kind=c_char), intent(out) :: lhs(*) + character(len=*), intent(in) :: rhs + integer, intent(in) :: len + integer :: length + length = min(len-1, len_trim(rhs)) + + lhs(1:length) = transfer(rhs(1:length), lhs(1:length)) + lhs(length+1:length+1) = c_null_char + + end subroutine f_c_character + + subroutine get_current_directory(path) + character(len=:), allocatable, intent(out) :: path + + integer :: length, stat + + call get_environment_variable(pwd_env, length=length, status=stat) + if (stat /= 0) return + + allocate(character(len=length) :: path, stat=stat) + if (stat /= 0) return + + if (length > 0) then + call get_environment_variable(pwd_env, path, status=stat) + if (stat /= 0) then + deallocate(path) + return + end if + end if + + end subroutine get_current_directory + +end module fpm_os -- cgit v1.2.3 From 5855337167b53abcaa17452ea1c3c048acb34e09 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Thu, 27 May 2021 21:40:35 +0200 Subject: Automatically search for package manifest --- src/fpm_os.F90 | 60 +++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 43 insertions(+), 17 deletions(-) (limited to 'src/fpm_os.F90') diff --git a/src/fpm_os.F90 b/src/fpm_os.F90 index 825df58..71663fe 100644 --- a/src/fpm_os.F90 +++ b/src/fpm_os.F90 @@ -1,5 +1,5 @@ module fpm_os - use, intrinsic :: iso_c_binding, only : c_char, c_int, c_null_char + use, intrinsic :: iso_c_binding, only : c_char, c_int, c_null_char, c_ptr, c_associated use fpm_error, only : error_t, fatal_error implicit none private @@ -22,6 +22,18 @@ module fpm_os character(kind=c_char, len=1), intent(in) :: path(*) integer(c_int) :: stat end function chdir + + function getcwd(buf, bufsize) result(path) & +#ifndef _WIN32 + bind(C, name="getcwd") +#else + bind(C, name="_getcwd") +#endif + import :: c_char, c_int, c_ptr + character(kind=c_char, len=1), intent(in) :: buf(*) + integer(c_int), value, intent(in) :: bufsize + type(c_ptr) :: path + end function getcwd end interface contains @@ -43,6 +55,25 @@ contains end if end subroutine change_directory + subroutine get_current_directory(path, error) + character(len=:), allocatable, intent(out) :: path + type(error_t), allocatable, intent(out) :: error + + character(kind=c_char, len=1), allocatable :: cpath(:) + integer(c_int), parameter :: buffersize = 1000_c_int + type(c_ptr) :: tmp + + allocate(cpath(buffersize)) + + tmp = getcwd(cpath, buffersize) + if (c_associated(tmp)) then + call c_f_character(cpath, path) + else + call fatal_error(error, "Failed to retrieve current directory") + end if + + end subroutine get_current_directory + subroutine f_c_character(rhs, lhs, len) character(kind=c_char), intent(out) :: lhs(*) character(len=*), intent(in) :: rhs @@ -55,25 +86,20 @@ contains end subroutine f_c_character - subroutine get_current_directory(path) - character(len=:), allocatable, intent(out) :: path + subroutine c_f_character(rhs, lhs) + character(kind=c_char), intent(in) :: rhs(*) + character(len=:), allocatable, intent(out) :: lhs - integer :: length, stat + integer :: ii - call get_environment_variable(pwd_env, length=length, status=stat) - if (stat /= 0) return - - allocate(character(len=length) :: path, stat=stat) - if (stat /= 0) return - - if (length > 0) then - call get_environment_variable(pwd_env, path, status=stat) - if (stat /= 0) then - deallocate(path) - return + do ii = 1, huge(ii) - 1 + if (rhs(ii) == c_null_char) then + exit end if - end if + end do + allocate(character(len=ii-1) :: lhs) + lhs = transfer(rhs(1:ii-1), lhs) - end subroutine get_current_directory + end subroutine c_f_character end module fpm_os -- cgit v1.2.3