1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
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
|
