aboutsummaryrefslogtreecommitdiff
path: root/src/fpm_os.F90
blob: 9b2be107a94d5e3fbcdf5a7b488f3f2bf523e82f (plain)
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