wyphan's patches

Author: freevryheid

src/fpm/installer.f90

@@ -31,6 +31,8 @@ module fpm_installer
     integer :: verbosity = 1
     !> Command to copy objects into the installation prefix
     character(len=:), allocatable :: copy
+    !> Command to move objects into the installation prefix
+    character(len=:), allocatable :: move
     !> Cached operating system
     integer :: os
   contains
@@ -69,11 +71,18 @@ module fpm_installer
   !> Copy command on Windows platforms
   character(len=*), parameter :: default_copy_win = "copy"
 
+  !> Move command on Unix platforms
+  character(len=*), parameter :: default_move_unix = "mv"
+
+  !> Move command on Windows platforms
+  character(len=*), parameter :: default_move_win = "move"
+
+
 contains
 
   !> Create a new instance of an installer
   subroutine new_installer(self, prefix, bindir, libdir, includedir, verbosity, &
-          copy)
+          copy, move)
     !> Instance of the installer
     type(installer_t), intent(out) :: self
     !> Path to installation directory
@@ -88,6 +97,8 @@ subroutine new_installer(self, prefix, bindir, libdir, includedir, verbosity, &
     integer, intent(in), optional :: verbosity
     !> Copy command
     character(len=*), intent(in), optional :: copy
+    !> Move command
+    character(len=*), intent(in), optional :: move
 
     self%os = get_os_type()
 
@@ -101,6 +112,16 @@ subroutine new_installer(self, prefix, bindir, libdir, includedir, verbosity, &
       end if
     end if
 
+    if (present(move)) then
+      self%move = move
+    else
+      if (os_is_unix(self%os)) then
+        self%move = default_move_unix
+      else
+        self%move = default_move_win
+      end if
+    end if
+
     if (present(includedir)) then
       self%includedir = includedir
     else
@@ -238,7 +259,12 @@ subroutine install(self, source, destination, error)
       end if
     end if
 
-    call self%run(self%copy//' "'//source//'" "'//install_dest//'"', error)
+    ! move instead of copy if already installed
+    if (exists(install_dest)) then
+      call self%run(self%move//' "'//source//'" "'//install_dest//'"', error)
+    else
+      call self%run(self%copy//' "'//source//'" "'//install_dest//'"', error)
+    end if
     if (allocated(error)) return
 
   end subroutine install

src/fpm_command_line.f90

@@ -759,7 +759,7 @@ subroutine set_help()
     '  + help     Alternate to the --help switch for displaying help text.  ', &
     '  + list     Display brief descriptions of all subcommands.            ', &
     '  + install  Install project.                                          ', &
-    '  + clean    Delete directories in the build/ directory, except        ', &
+    '  + clean    Delete directories in the "build/" directory, except      ', &
     '             dependencies. Prompts for confirmation to delete.         ', &
     '                                                                       ', &
     '  Their syntax is                                                      ', &

src/fpm_filesystem.F90

@@ -369,9 +369,9 @@ subroutine mkdir(dir, echo)
 
     if(present(echo))then
         echo_local=echo
-     else
+      else
         echo_local=.true.
-     end if
+    end if
 
     if (is_dir(dir)) return
 
@@ -929,15 +929,36 @@ subroutine run(cmd,echo,exitstat,verbose,redirect)
 
 end subroutine run
 
-!> delete dir using system os remove directory commands
-subroutine os_delete_dir(unix, dir)
+!> Delete directory using system OS remove directory commands
+subroutine os_delete_dir(unix, dir, echo)
     logical, intent(in) :: unix
     character(len=*), intent(in) :: dir
+    logical, intent(in), optional :: echo
+
+    logical :: echo_local
+
+    if(present(echo))then
+        echo_local=echo
+      else
+        echo_local=.true.
+    end if
+
     if (unix) then
         call run('rm -rf ' // dir, .false.)
+
+        if (echo_local) then
+          write (*, '(" + ",2a)') 'rm -rf ' // dir
+        end if
+
     else
         call run('rmdir /s/q ' // dir, .false.)
+
+        if (echo_local) then
+          write (*, '(" + ",2a)') 'rmdir /s/q ' // dir
+        end if
+
     end if
+
 end subroutine os_delete_dir
 
 end module fpm_filesystem

test/cli_test/cli_test.f90

@@ -27,10 +27,12 @@ program main
 integer                              :: i, ios
 logical                              :: w_e,act_w_e          ; namelist/act_cli/act_w_e
 logical                              :: w_t,act_w_t          ; namelist/act_cli/act_w_t
+logical                              :: c_s,act_c_s          ; namelist/act_cli/act_c_s
+logical                              :: c_a,act_c_a          ; namelist/act_cli/act_c_a
 
 character(len=63)                    :: profile,act_profile  ; namelist/act_cli/act_profile
 character(len=:),allocatable         :: args,act_args        ; namelist/act_cli/act_args
-namelist/expected/cmd,cstat,estat,w_e,w_t,name,profile,args
+namelist/expected/cmd,cstat,estat,w_e,w_t,c_s,c_a,name,profile,args
 integer                              :: lun
 logical,allocatable                  :: tally(:)
 logical,allocatable                  :: subtally(:)
@@ -42,7 +44,7 @@ program main
 'CMD="new",                                           ESTAT=1,', &
 !'CMD="new -unknown",                                  ESTAT=2,', &
 'CMD="new my_project another yet_another -test", ESTAT=2,', &
-'CMD="new my_project --app",              W_E=T,       NAME="my_project",',  &
+'CMD="new my_project --app",                          W_E=T,       NAME="my_project",',  &
 'CMD="new my_project --app --test",                   W_E=T,W_T=T, NAME="my_project",',  &
 'CMD="new my_project --test",                               W_T=T, NAME="my_project",',  &
 'CMD="new my_project",                                W_E=T,W_T=T, NAME="my_project",',  &
@@ -64,7 +66,11 @@ program main
    &NAME="proj1","p2","project3",profile="release" ARGS="""arg1"" ""-x"" ""and a long one""",                         ', &
 
 'CMD="build",                                                      NAME= profile="",ARGS="",', &
-'CMD="build --profile release",                                            NAME= profile="release",ARGS="",', &
+'CMD="build --profile release",                                    NAME= profile="release",ARGS="",', &
+
+'CMD="clean",                                                      NAME= ARGS="",', &
+'CMD="clean --skip",                                        C_S=T, NAME= ARGS="",', &
+'CMD="clean --all",                                   C_A=T,       NAME= ARGS="",', &
 ' ' ]
 character(len=256) :: readme(3)
 
@@ -95,6 +101,8 @@ program main
       profile=""                     ! --profile PROF
       w_e=.false.                    ! --app
       w_t=.false.                    ! --test
+      c_s=.false.                    ! --skip
+      c_a=.false.                    ! --all
       args=repeat(' ',132)           ! -- ARGS
       cmd=repeat(' ',132)            ! the command line arguments to test
       cstat=0                        ! status values from EXECUTE_COMMAND_LINE()
@@ -112,6 +120,8 @@ program main
              act_profile=''
              act_w_e=.false.
              act_w_t=.false.
+             act_c_s=.false.
+             act_c_a=.false.
              act_args=repeat(' ',132)
              read(lun,nml=act_cli,iostat=ios,iomsg=message)
              if(ios.ne.0)then
@@ -193,9 +203,10 @@ subroutine parse()
         fpm_build_settings, &
         fpm_run_settings, &
         fpm_test_settings, &
+        fpm_clean_settings, &
         fpm_install_settings, &
         get_command_line_settings
-use fpm, only: cmd_build, cmd_run
+use fpm, only: cmd_build, cmd_run, cmd_clean
 use fpm_cmd_install, only: cmd_install
 use fpm_cmd_new, only: cmd_new
 class(fpm_cmd_settings), allocatable :: cmd_settings
@@ -206,6 +217,8 @@ subroutine parse()
 act_args=''
 act_w_e=.false.
 act_w_t=.false.
+act_c_s=.false.
+act_c_a=.false.
 act_profile=''
 
 select type(settings=>cmd_settings)
@@ -223,6 +236,9 @@ subroutine parse()
     act_profile=settings%profile
     act_name=settings%name
     act_args=settings%args
+type is (fpm_clean_settings)
+    act_c_s=settings%clean_skip
+    act_c_a=settings%clean_call
 type is (fpm_install_settings)
 end select
 

test/fpm_test/test_filesystem.f90

@@ -1,6 +1,7 @@
 module test_filesystem
     use testsuite, only : new_unittest, unittest_t, error_t, test_failed
-    use fpm_filesystem, only: canon_path
+    use fpm_filesystem, only: canon_path, is_dir, mkdir, os_delete_dir
+    use fpm_environment, only: OS_WINDOWS, get_os_type, os_is_unix
     implicit none
     private
 
@@ -16,7 +17,8 @@ subroutine collect_filesystem(testsuite)
         type(unittest_t), allocatable, intent(out) :: testsuite(:)
 
         testsuite = [ &
-            & new_unittest("canon-path", test_canon_path) &
+            & new_unittest("canon-path", test_canon_path), &
+            & new_unittest("create-delete-directory", test_mkdir_rmdir) &
             ]
 
     end subroutine collect_filesystem
@@ -96,11 +98,102 @@ subroutine check_string(error, actual, expected)
 
         if (actual /= expected) then
             call test_failed(error, &
-                "Character value missmatch "//&
+                "Character value mismatch "//&
                 "expected '"//expected//"' but got '"//actual//"'")
         end if
 
     end subroutine check_string
 
 
+    subroutine test_mkdir_rmdir(error)
+
+        !> Error handling
+        type(error_t), allocatable, intent(out) :: error
+
+        logical :: is_win
+
+        is_win = (get_os_type() == OS_WINDOWS)
+
+        if (is_win) then
+            call check_mkdir(error, "tmpdir\subdir")
+          else
+            call check_mkdir(error, "tmpdir/subdir")
+        end if
+        if (allocated(error)) return
+
+        if (is_win) then
+            call check_rmdir(error, "tmpdir\subdir")
+          else
+            call check_rmdir(error, "tmpdir/subdir")
+        end if
+        if (allocated(error)) return
+
+        call check_rmdir(error, "tmpdir")
+        if (allocated(error)) return
+
+    end subroutine test_mkdir_rmdir
+
+
+    !> Create a directory and verify its existence
+    subroutine check_mkdir(error, path)
+
+        !> Error handling
+        type(error_t), allocatable, intent(out) :: error
+
+        !> Directory path
+        character(len=*), intent(in) :: path
+
+        logical :: stat
+
+        ! Directory shouldn't exist before it's created
+        stat = (is_dir(path) .eqv. .false.)
+        if (.not. stat) then
+            call test_failed(error, &
+                "Directory path "//path//" already exists before its creation")
+        end if
+
+        ! Create directory
+        call mkdir(path)
+
+        ! Check that directory is indeed created
+        stat = (is_dir(path) .eqv. .true.)
+        if (.not. stat) then
+            call test_failed(error, &
+                "Directory path "//path//" cannot be created")
+        end if
+
+      end subroutine check_mkdir
+
+
+    !> Create a directory and verify its existence
+    subroutine check_rmdir(error, path)
+
+        !> Error handling
+        type(error_t), allocatable, intent(out) :: error
+
+        !> Directory path
+        character(len=*), intent(in) :: path
+
+        logical :: stat
+
+        ! Directory should exist before it's deleted
+        stat = (is_dir(path) .eqv. .true.)
+        if (.not. stat) then
+            call test_failed(error, &
+                "Directory path "//path//" doesn't exist before its deletion")
+        end if
+
+        ! Delete directory
+        call os_delete_dir(os_is_unix(),path)
+
+        ! Check that directory is indeed deleted
+        stat = (is_dir(path) .eqv. .false.)
+        if (.not. stat) then
+            call test_failed(error, &
+                "Directory path "//path//" cannot be deleted")
+        end if
+
+      end subroutine check_rmdir
+
+
 end module test_filesystem