Allow fpm to change the working directory

1 files changed, 79 insertions, 0 deletions

diff --git a/src/fpm_os.F90 b/src/fpm_os.F90
new file mode 100644
index 0000000..825df58
--- /dev/null
+++ b/src/fpm_os.F90
@@ -0,0 +1,79 @@
+module fpm_os
+    use, intrinsic :: iso_c_binding, only : c_char, c_int, c_null_char
+    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
+    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 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 get_current_directory(path)
+        character(len=:), allocatable, intent(out) :: path
+
+        integer :: length, stat
+
+        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
+            end if
+        end if
+
+    end subroutine get_current_directory
+
+end module fpm_os