aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--app/main.f9077
-rw-r--r--src/fpm_command_line.f9021
-rw-r--r--src/fpm_filesystem.f9011
-rw-r--r--src/fpm_os.F9060
4 files changed, 135 insertions, 34 deletions
diff --git a/app/main.f90 b/app/main.f90
index 7476df6..5600f98 100644
--- a/app/main.f90
+++ b/app/main.f90
@@ -1,4 +1,5 @@
program main
+use, intrinsic :: iso_fortran_env, only : error_unit, output_unit
use fpm_command_line, only: &
fpm_cmd_settings, &
fpm_new_settings, &
@@ -8,17 +9,57 @@ use fpm_command_line, only: &
fpm_install_settings, &
fpm_update_settings, &
get_command_line_settings
+use fpm_error, only: error_t
+use fpm_filesystem, only: exists, parent_dir, join_path
use fpm, only: cmd_build, cmd_run
use fpm_cmd_install, only: cmd_install
use fpm_cmd_new, only: cmd_new
use fpm_cmd_update, only : cmd_update
+use fpm_os, only: change_directory, get_current_directory
implicit none
class(fpm_cmd_settings), allocatable :: cmd_settings
+type(error_t), allocatable :: error
+character(len=:), allocatable :: pwd_start, pwd_working, working_dir, project_root
call get_command_line_settings(cmd_settings)
+call get_current_directory(pwd_start, error)
+call handle_error(error)
+
+call get_working_dir(cmd_settings, working_dir)
+if (allocated(working_dir)) then
+ ! Change working directory if requested
+ if (len_trim(working_dir) > 0) then
+ call change_directory(working_dir, error)
+ call handle_error(error)
+
+ call get_current_directory(pwd_working, error)
+ call handle_error(error)
+ write(output_unit, '(*(a))') "fpm: Entering directory '"//pwd_working//"'"
+ else
+ pwd_working = pwd_start
+ end if
+else
+ pwd_working = pwd_start
+end if
+
+if (.not.has_manifest(pwd_working)) then
+ project_root = pwd_working
+ do while(.not.has_manifest(project_root))
+ working_dir = parent_dir(project_root)
+ if (len(working_dir) == 0) exit
+ project_root = working_dir
+ end do
+
+ if (has_manifest(project_root)) then
+ call change_directory(project_root, error)
+ call handle_error(error)
+ write(output_unit, '(*(a))') "fpm: Entering directory '"//project_root//"'"
+ end if
+end if
+
select type(settings=>cmd_settings)
type is (fpm_new_settings)
call cmd_new(settings)
@@ -34,4 +75,40 @@ type is (fpm_update_settings)
call cmd_update(settings)
end select
+if (allocated(project_root)) then
+ write(output_unit, '(*(a))') "fpm: Leaving directory '"//project_root//"'"
+end if
+
+if (pwd_start /= pwd_working) then
+ write(output_unit, '(*(a))') "fpm: Leaving directory '"//pwd_working//"'"
+end if
+
+contains
+
+ function has_manifest(dir)
+ character(len=*), intent(in) :: dir
+ logical :: has_manifest
+
+ character(len=:), allocatable :: manifest
+
+ has_manifest = exists(join_path(dir, "fpm.toml"))
+ end function has_manifest
+
+ subroutine handle_error(error)
+ type(error_t), optional, intent(in) :: error
+ if (present(error)) then
+ write(error_unit, '("[Error]", 1x, a)') error%message
+ stop 1
+ end if
+ end subroutine handle_error
+
+ !> Save access to working directory in settings, in case setting have not been allocated
+ subroutine get_working_dir(settings, working_dir)
+ class(fpm_cmd_settings), optional, intent(in) :: settings
+ character(len=:), allocatable, intent(out) :: working_dir
+ if (present(settings)) then
+ working_dir = settings%working_dir
+ end if
+ end subroutine get_working_dir
+
end program main
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