diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/fpm_command_line.f90 | 21 | ||||
| -rw-r--r-- | src/fpm_filesystem.f90 | 11 | ||||
| -rw-r--r-- | src/fpm_os.F90 | 60 |
3 files changed, 58 insertions, 34 deletions
diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90 index 095a533..f44bcd0 100644 --- a/src/fpm_command_line.f90 +++ b/src/fpm_command_line.f90 @@ -26,9 +26,7 @@ module fpm_command_line use fpm_environment, only : get_os_type, get_env, & OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD -use fpm_error, only : error_t use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified -use fpm_os, only : change_directory, get_current_directory use fpm_strings, only : lower, split, fnv_1a use fpm_filesystem, only : basename, canon_path, to_fortran_name use fpm_compiler, only : get_default_compile_flags @@ -48,6 +46,7 @@ public :: fpm_cmd_settings, & get_command_line_settings type, abstract :: fpm_cmd_settings + character(len=:), allocatable :: working_dir logical :: verbose=.true. end type @@ -121,9 +120,7 @@ contains integer :: i integer :: widest type(fpm_install_settings), allocatable :: install_settings - character(len=:), allocatable :: pwd_start, working_dir - character(len=:), allocatable :: common_args - type(error_t), allocatable :: error + character(len=:), allocatable :: common_args, working_dir call set_help() ! text for --version switch, @@ -153,8 +150,6 @@ contains if(adjustl(cmdarg(1:1)) .ne. '-')exit enddo - call get_current_directory(pwd_start) - common_args = '--directory:C " " ' ! now set subcommand-specific help text and process commandline @@ -473,15 +468,9 @@ contains end select - ! Change working directory if requested - working_dir = sget("directory") - if (len_trim(working_dir) > 0) then - call change_directory(working_dir, error) - if (allocated(error)) then - write(stderr, '(*(a, 1x))') "<ERROR>", error%message - stop 1 - end if - write(stdout, '(*(a))') "fpm: Entering directory '"//working_dir//"'" + if (allocated(cmd_settings)) then + working_dir = sget("directory") + call move_alloc(working_dir, cmd_settings%working_dir) end if contains diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.f90 index 28c3b33..c9c97dd 100644 --- a/src/fpm_filesystem.f90 +++ b/src/fpm_filesystem.f90 @@ -10,7 +10,7 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, private public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, & mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name - public :: fileopen, fileclose, filewrite, warnwrite + public :: fileopen, fileclose, filewrite, warnwrite, parent_dir integer, parameter :: LINE_BUFFER_LEN = 1000 @@ -184,6 +184,15 @@ function dirname(path) result (dir) end function dirname +!> Extract dirname from path +function parent_dir(path) result (dir) + character(*), intent(in) :: path + character(:), allocatable :: dir + + dir = path(1:scan(path,'/\',back=.true.)-1) + +end function parent_dir + !> test if a name matches an existing directory path logical function is_dir(dir) 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 |