Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2018 Robert Farmer & The MESA Team
4 : !
5 : ! This program is free software: you can redistribute it and/or modify
6 : ! it under the terms of the GNU Lesser General Public License
7 : ! as published by the Free Software Foundation,
8 : ! either version 3 of the License, or (at your option) any later version.
9 : !
10 : ! This program is distributed in the hope that it will be useful,
11 : ! but WITHOUT ANY WARRANTY; without even the implied warranty of
12 : ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13 : ! See the GNU Lesser General Public License for more details.
14 : !
15 : ! You should have received a copy of the GNU Lesser General Public License
16 : ! along with this program. If not, see <https://www.gnu.org/licenses/>.
17 : !
18 : ! ***********************************************************************
19 :
20 : module utils_system
21 : implicit none
22 :
23 : interface
24 : function f_mkdir_p(folder) bind(C,name='c_mkdir_p')
25 : use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_INT
26 : implicit none
27 : integer(C_INT) :: f_mkdir_p
28 : character(kind=C_CHAR) :: folder(*)
29 : end function f_mkdir_p
30 :
31 : function f_mv(src, dest) bind(C,name='c_mv')
32 : use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_INT
33 : implicit none
34 : integer(C_INT) :: f_mv
35 : character(kind=C_CHAR) :: src(*), dest(*)
36 : end function f_mv
37 :
38 : function f_cp(src, dest) bind(C,name='c_cp')
39 : use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_INT
40 : implicit none
41 : integer(C_INT) :: f_cp
42 : character(kind=C_CHAR) :: src(*), dest(*)
43 : end function f_cp
44 :
45 : function f_is_dir(folder) bind(C,name='is_dir')
46 : use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_INT
47 : implicit none
48 : integer(C_INT) :: f_is_dir
49 : character(kind=C_CHAR) :: folder(*)
50 : end function f_is_dir
51 :
52 : end interface
53 :
54 : private
55 : public :: mkdir_p, mv, cp, is_dir
56 :
57 :
58 : contains
59 :
60 :
61 : ! Converts a fortran string to a NULL terminated string
62 482 : pure function f_c_string (f_str) result (c_str)
63 : use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_NULL_CHAR
64 : character(len=*), intent(in) :: f_str
65 : character(len=1,kind=C_CHAR) :: c_str(len_trim(f_str)+1)
66 : integer :: n, i
67 :
68 482 : n = len_trim(f_str)
69 22420 : do i = 1, n
70 22420 : c_str(i) = f_str(i:i)
71 : end do
72 482 : c_str(n + 1) = C_NULL_CHAR
73 :
74 482 : end function f_c_string
75 :
76 : ! Makes a directory, potentially making any needed parent directories
77 52 : integer function mkdir_p(folder)
78 : character(len=*), intent(in) :: folder
79 :
80 52 : mkdir_p = f_mkdir_p(f_c_string(folder))
81 :
82 52 : end function mkdir_p
83 :
84 : ! Moves src to dest, if dest is on a different filesystem, do a cp
85 : ! to the same filesystem then mv to dest
86 211 : integer function mv(src,dest)
87 : character(len=*), intent(in) :: src, dest
88 :
89 211 : mv = f_mv(f_c_string(src),f_c_string(dest))
90 :
91 211 : end function mv
92 :
93 : ! Copies src to dest
94 0 : integer function cp(src,dest)
95 : character(len=*), intent(in) :: src, dest
96 :
97 0 : cp = f_cp(f_c_string(src),f_c_string(dest))
98 :
99 0 : end function cp
100 :
101 : ! Checks if folder exists or not
102 8 : logical function is_dir(folder)
103 : character(len=*), intent(in) :: folder
104 :
105 8 : is_dir = f_is_dir(f_c_string(folder)) == 1
106 :
107 8 : end function is_dir
108 :
109 :
110 : end module utils_system
111 :
112 :
113 : ! Left for testing
114 :
115 : !program sys
116 : ! use system_utils
117 : ! implicit none
118 : ! integer :: num, res
119 : ! character(len=256) :: f1, f2
120 :
121 : ! num = command_argument_count()
122 : ! call get_command_argument(1,f1)
123 :
124 : ! if(num==1) then
125 : ! write(*,*) "Test mkdir_p ",trim(f1)
126 : ! res = mkdir_p(f1)
127 : ! else
128 : ! call get_command_argument(2,f2)
129 : !! write(*,*) "Test mv ",trim(f1)," * ",trim(f2)
130 : !! res = mv(f1,f2)
131 : ! write(*,*) "Test cp ",trim(f1)," * ",trim(f2)
132 : ! res = cp(f1,f2)
133 : ! end if
134 :
135 : ! write(*,*) "Result: ", res
136 :
137 : !end program sys
|
