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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
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, windows_is_wow64
#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
#ifdef _WIN32
function windows_is_wow64() result(wow64)
use iso_c_binding
implicit none
logical(kind=c_bool), target::wow64
! If compiled for 64-bit, then the answer is no
#ifndef __i386__
wow64 = .false.
#else
interface
function IsWow64Process(h, cptrbool)
type(c_ptr), value::h, cptrbool
logical(kind=c_bool)::IsWow64Process
end function IsWow64Process
end interface
interface
function GetModuleHandle(str) bind(c)
character(len=*, kind=c_char)::str
type(c_ptr)::GetModuleHandle
end function GetModuleHandle
end interface
interface
function GetProcAddress(libptr, str) bind(c)
type(c_ptr), value::libptr
character(len=*, kind=c_char)::str
type(c_funptr)::GetProcAddress
end function GetProcAddress
end interface
interface
function GetCurrentProcess() bind(c)
type(c_ptr)::GetCurrentProcess
end function GetCurrentProcess
end interface
type(c_funptr)::wow64_c
procedure(IsWow64Process), pointer::wow64_f
wow64_c = GetProcAddress( &
GetModuleHandle("kernel32"//c_null_char), &
"IsWow64Process"//c_null_char)
if(wow64_c == c_null_funptr) then
wow64 = .false.
else
call c_f_procpointer(wow64_c, wow64_f)
if(.not. wow64_f(GetCurrentProcess(), c_loc(wow64))) then
wow64 = .false.
end if
end if
#endif
end function windows_is_wow64
#else
! Non-windows systems...
function windows_is_wow64()
implicit none
logical::windows_is_wow64
windows_is_wow64 = .false.
end function windows_is_wow64
#endif
end module fpm_os
|
