diff options
| -rw-r--r-- | app/main.f90 | 77 | ||||
| -rwxr-xr-x | ci/run_tests.sh | 9 | ||||
| -rw-r--r-- | src/fpm_backend.f90 | 32 | ||||
| -rw-r--r-- | src/fpm_command_line.f90 | 30 | ||||
| -rw-r--r-- | src/fpm_filesystem.f90 | 11 | ||||
| -rw-r--r-- | src/fpm_os.F90 | 105 |
6 files changed, 246 insertions, 18 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/ci/run_tests.sh b/ci/run_tests.sh index ffcd9c2..9db88e8 100755 --- a/ci/run_tests.sh +++ b/ci/run_tests.sh @@ -13,11 +13,10 @@ fi pushd example_packages/ rm -rf ./*/build -pushd hello_world -"$fpm" build -"$fpm" run --target hello_world -"$fpm" run -popd +dir=hello_world +"$fpm" -C $dir build +"$fpm" -C $dir run --target hello_world +"$fpm" -C $dir/app run pushd hello_fpm "$fpm" build diff --git a/src/fpm_backend.f90 b/src/fpm_backend.f90 index 51861b4..99b6be8 100644 --- a/src/fpm_backend.f90 +++ b/src/fpm_backend.f90 @@ -27,12 +27,12 @@ !> module fpm_backend -use fpm_environment, only: run -use fpm_filesystem, only: dirname, join_path, exists, mkdir +use fpm_environment, only: run, get_os_type, OS_WINDOWS +use fpm_filesystem, only: dirname, join_path, exists, mkdir, unix_path use fpm_model, only: fpm_model_t use fpm_targets, only: build_target_t, build_target_ptr, FPM_TARGET_OBJECT, & FPM_TARGET_C_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE -use fpm_strings, only: string_cat +use fpm_strings, only: string_cat, string_t implicit none @@ -250,7 +250,16 @@ subroutine build_target(model,target) //" "//target%link_flags// " -o " // target%output_file) case (FPM_TARGET_ARCHIVE) - call run(model%archiver // target%output_file // " " // string_cat(target%link_objects," ")) + + select case (get_os_type()) + case (OS_WINDOWS) + call write_response_file(target%output_file//".resp" ,target%link_objects) + call run(model%archiver // target%output_file // " @" // target%output_file//".resp") + + case default + call run(model%archiver // target%output_file // " " // string_cat(target%link_objects," ")) + + end select end select @@ -262,4 +271,19 @@ subroutine build_target(model,target) end subroutine build_target +!> Response files allow to read command line options from files. +!> Whitespace is used to separate the arguments, we will use newlines +!> as separator to create readable response files which can be inspected +!> in case of errors. +subroutine write_response_file(name, argv) + character(len=*), intent(in) :: name + type(string_t), intent(in) :: argv(:) + integer :: iarg, io + open(file=name, newunit=io) + do iarg = 1, size(argv) + write(io, '(a)') unix_path(argv(iarg)%s) + end do + close(io) +end subroutine write_response_file + end module fpm_backend diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90 index 931178a..d324b97 100644 --- a/src/fpm_command_line.f90 +++ b/src/fpm_command_line.f90 @@ -48,6 +48,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,6 +122,7 @@ contains integer :: i integer :: widest type(fpm_install_settings), allocatable :: install_settings + character(len=:), allocatable :: common_args, working_dir call set_help() ! text for --version switch, @@ -147,12 +149,14 @@ contains CLI_RESPONSE_FILE=.true. cmdarg = get_subcommand() + common_args = '--directory:C " " ' + ! now set subcommand-specific help text and process commandline ! arguments. Then call subcommand routine select case(trim(cmdarg)) case('run') - call set_args('& + call set_args(common_args //'& & --target " " & & --list F & & --all F & @@ -205,7 +209,7 @@ contains & verbose=lget('verbose') ) case('build') - call set_args( '& + call set_args(common_args // '& & --profile " " & & --list F & & --show-model F & @@ -227,7 +231,7 @@ contains & verbose=lget('verbose') ) case('new') - call set_args('& + call set_args(common_args // '& & --src F & & --lib F & & --app F & @@ -297,7 +301,7 @@ contains endif case('help','manual') - call set_args('& + call set_args(common_args // '& & --verbose F & & ',help_help,version_text) if(size(unnamed).lt.2)then @@ -345,7 +349,8 @@ contains call printhelp(help_text) case('install') - call set_args('--profile " " --no-rebuild F --verbose F --prefix " " & + call set_args(common_args // '& + & --profile " " --no-rebuild F --verbose F --prefix " " & & --list F & & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & & --flag:: " "& @@ -370,7 +375,7 @@ contains call move_alloc(install_settings, cmd_settings) case('list') - call set_args('& + call set_args(common_args // '& & --list F& & --verbose F& &', help_list, version_text) @@ -379,7 +384,7 @@ contains call printhelp(help_list_dash) endif case('test') - call set_args('& + call set_args(common_args // '& & --target " " & & --list F& & --profile " "& @@ -424,7 +429,7 @@ contains & verbose=lget('verbose') ) case('update') - call set_args('--fetch-only F --verbose F --clean F', & + call set_args(common_args // ' --fetch-only F --verbose F --clean F', & help_update, version_text) if( size(unnamed) .gt. 1 )then @@ -439,6 +444,7 @@ contains clean=lget('clean')) case default + if(which('fpm-'//cmdarg).ne.'')then call run('fpm-'//trim(cmdarg)//' '// get_command_arguments_quoted(),.false.) else @@ -464,6 +470,12 @@ contains endif end select + + if (allocated(cmd_settings)) then + working_dir = sget("directory") + call move_alloc(working_dir, cmd_settings%working_dir) + end if + contains subroutine check_build_vals() @@ -676,6 +688,8 @@ contains ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] [options]', & ' ', & 'SUBCOMMAND OPTIONS ', & + ' -C, --directory PATH', & + ' Change working directory to PATH before running any command', & ' --profile PROF selects the compilation profile for the build.',& ' Currently available profiles are "release" for',& ' high optimization and "debug" for full debug options.',& diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.f90 index 87c8a88..486e989 100644 --- a/src/fpm_filesystem.f90 +++ b/src/fpm_filesystem.f90 @@ -11,7 +11,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 public :: which integer, parameter :: LINE_BUFFER_LEN = 1000 @@ -187,6 +187,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 new file mode 100644 index 0000000..71663fe --- /dev/null +++ b/src/fpm_os.F90 @@ -0,0 +1,105 @@ +module fpm_os + 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 + 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 + + 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 + + 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 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 + 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 c_f_character(rhs, lhs) + character(kind=c_char), intent(in) :: rhs(*) + character(len=:), allocatable, intent(out) :: lhs + + integer :: ii + + do ii = 1, huge(ii) - 1 + if (rhs(ii) == c_null_char) then + exit + end if + end do + allocate(character(len=ii-1) :: lhs) + lhs = transfer(rhs(1:ii-1), lhs) + + end subroutine c_f_character + +end module fpm_os |