Merge branch 'master' into master

4 files changed, 165 insertions, 13 deletions

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