Context Navigation

fsystem.F90 @ 1793

Last change on this file since 1793 was 1793, checked in by jvatant, 7 years ago

Making Titan's hazy again, part I
+ Added the source folder libf/muphytitan which contains

YAMMS ( Titan's microphysical model ) from J. Burgalat

+ Modif. compilation files linked to this change
JVO

File size: 39.6 KB

Line
1	! Copyright Jérémie Burgalat (2010-2015)
2	!
3	! burgalat.jeremie@gmail.com
4	!
5	! This software is a computer program whose purpose is to provide configuration
6	! file and command line arguments parsing features to Fortran programs.
7	!
8	! This software is governed by the CeCILL-B license under French law and
9	! abiding by the rules of distribution of free software. You can use,
10	! modify and/ or redistribute the software under the terms of the CeCILL-B
11	! license as circulated by CEA, CNRS and INRIA at the following URL
12	! "http://www.cecill.info".
13	!
14	! As a counterpart to the access to the source code and rights to copy,
15	! modify and redistribute granted by the license, users are provided only
16	! with a limited warranty and the software's author, the holder of the
17	! economic rights, and the successive licensors have only limited
18	! liability.
19	!
20	! In this respect, the user's attention is drawn to the risks associated
21	! with loading, using, modifying and/or developing or reproducing the
22	! software by the user in light of its specific status of free software,
23	! that may mean that it is complicated to manipulate, and that also
24	! therefore means that it is reserved for developers and experienced
25	! professionals having in-depth computer knowledge. Users are therefore
26	! encouraged to load and test the software's suitability as regards their
27	! requirements in conditions enabling the security of their systems and/or
28	! data to be ensured and, more generally, to use and operate it in the
29	! same conditions as regards security.
30	!
31	! The fact that you are presently reading this means that you have had
32	! knowledge of the CeCILL-B license and that you accept its terms.
33
34	!! file: fsystem.F90
35	!! summary: File system methods source file
36	!! date: 2013-2015
37	!! author: Burgalat
38
39	#include "defined.h"
40
41	MODULE FSYSTEM
42	!! File system methods module
43	USE, INTRINSIC :: ISO_C_BINDING
44	USE ERRORS
45	IMPLICIT NONE
46
47	PUBLIC
48
49	PRIVATE :: get_umask
50
51	INTEGER, PARAMETER :: MAX_PATH = 512 !! Maximum length of a path
52
53
54	INTERFACE
55
56	FUNCTION strlen_c(s) RESULT(length) bind(C,name="strlen")
57	!! Get length of C-string up to (but not including) the terminator
58	IMPORT C_PTR, C_SIZE_T
59	TYPE(C_PTR), INTENT(in), VALUE :: s !! C string (a C_PTR type)
60	INTEGER(kind=C_SIZE_T) :: length !! An integer with the size of the string.
61	END FUNCTION strlen_c
62
63	SUBROUTINE free_c(ptr) bind(C,name="free")
64	!! Free memory used by a C pointer
65	IMPORT C_PTR
66	TYPE(C_PTR), INTENT(in), VALUE :: ptr !! TYPE(C_PTR) object with the underlying C pointer to free
67	END SUBROUTINE free_c
68
69	FUNCTION errno_c() BIND(C,name="c_get_errno")
70	!! Get last error numbero
71	IMPORT C_INT
72	INTEGER(kind=C_INT) :: errno_c !! Last errno
73	END FUNCTION errno_c
74
75	FUNCTION usleep_c(usec) BIND(C,name="usleep")
76	!! (attemps to) Sleep for a given number of microseconds
77	IMPORT C_INT
78	INTEGER(kind=C_INT), INTENT(in), VALUE :: usec !! Number of microseconds to sleep
79	INTEGER(kind=C_INT) :: usleep_c !! An integer with 0 on success, last errno otherwise
80	END FUNCTION usleep_c
81
82	FUNCTION getgid_c() BIND(C, name="getgid")
83	!! Get Group ID
84	IMPORT C_INT
85	INTEGER(kind=C_INT) :: getgid_c !! Group identifier
86	END FUNCTION getgid_c
87
88	FUNCTION getpid_c() BIND(C, name="getpid")
89	!! Get Process ID
90	IMPORT C_INT
91	INTEGER(kind=C_INT) :: getpid_c !! Current process identifier
92	END FUNCTION getpid_c
93
94	FUNCTION getuid_c() BIND(C, name="getuid")
95	!! Get User ID
96	IMPORT C_INT
97	INTEGER(kind=C_INT) :: getuid_c !! User identifier
98	END FUNCTION getuid_c
99
100	FUNCTION umask_c() BIND(C,name="c_umask")
101	!! Get the current umask of the session
102	IMPORT C_INT
103	INTEGER(kind=C_INT) :: umask_c !! Current umask value in decimal system
104	END FUNCTION umask_c
105
106	FUNCTION access_c(path,perm) BIND(C,name="c_access")
107	!! Check if path is accessible for current user
108	IMPORT c_char, C_INT
109	CHARACTER(len=c_char), INTENT(in) :: path(*) !! Path to check
110	INTEGER(kind=C_INT), INTENT(in), VALUE :: perm !! User's permission to check
111	INTEGER(kind=C_INT) :: access_c !! 0 on success, last errno on failure
112	END FUNCTION access_c
113
114	FUNCTION create_c(path,mode,asfile,forced) BIND(C,name="c_create")
115	!! Create a directory or a file in given path
116	IMPORT c_char, C_INT
117	CHARACTER(len=c_char), INTENT(in) :: path(*) !! Path to create
118	INTEGER(kind=C_INT), INTENT(in), VALUE :: mode, & !! Decimal permission of the path
119	asfile, & !! 0 to create a directory, any other value to create file
120	forced !! non-zero value to force the creation of intermediate directories
121	INTEGER(kind=C_INT) :: create_c !! 0 on success, last errno otherwise
122	END FUNCTION create_c
123
124	FUNCTION uname_c(uid) BIND(C, name="c_uname")
125	!! Get the name of the given user id
126	IMPORT C_INT, c_ptr
127	INTEGER(kind=C_INT), INTENT(in), VALUE :: uid !! User id
128	TYPE(C_PTR) :: uname_c !! C_PTR to the underlying char* pointer storing user name
129	END FUNCTION uname_c
130
131	FUNCTION gname_c(gid) BIND(C, name="c_gname")
132	!! Get the name of the given group id
133	IMPORT C_INT, c_ptr
134	INTEGER(kind=C_INT), INTENT(in), VALUE :: gid !! Group id
135	TYPE(C_PTR) :: gname_c !! C_PTR to the underlying char* pointer storing group name
136	END FUNCTION gname_c
137
138	FUNCTION dirname_c(path) BIND(C,name="c_dirname")
139	!! Get the directory name of the path
140	IMPORT c_char, c_ptr
141	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Input path
142	TYPE(C_PTR) :: dirname_c !! C_PTR to the underlying char* pointer storing dirname
143	END FUNCTION dirname_c
144
145	FUNCTION basename_c(path) BIND(C,name="c_basename")
146	!! Get the basename of the path
147	IMPORT c_char, c_ptr
148	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Input path
149	TYPE(C_PTR) :: basename_c !! C_PTR to the underlying char* pointer sotring basename
150	END FUNCTION basename_c
151
152	FUNCTION getcwd_c() BIND(C,name="c_getcwd")
153	!! Get the current working directory
154	IMPORT c_ptr
155	TYPE(C_PTR) :: getcwd_c !! C_PTR to the underlying char* pointer storing current working directory
156	END FUNCTION getcwd_c
157
158	FUNCTION realpath_c(path) BIND(C, name="c_realpath")
159	!! Get the real path from given path
160	IMPORT c_char, c_ptr
161	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! The path to expand
162	TYPE(C_PTR) :: realpath_c !! C_PTR to the underlying char* pointer storing realpath
163	END FUNCTION realpath_c
164
165	FUNCTION relpath_c(fname,reldir) BIND(C, name="c_relpath")
166	!! Get the relative path of path from another
167	IMPORT c_char, c_ptr
168	CHARACTER(kind=c_char), INTENT(in) :: fname(*), & !! Path to process
169	reldir(*) !! New base path
170	TYPE(C_PTR) :: relpath_c !! C_PTR to the underlying char* pointer storing relative path
171	END FUNCTION
172
173	FUNCTION rename_c(input,output) BIND(C,name="c_rename")
174	!! Rename a path
175	IMPORT c_char, C_INT
176	CHARACTER(kind=c_char), INTENT(in) :: input(*) !! Path to rename
177	CHARACTER(kind=c_char), INTENT(in) :: output(*) !! New name of the path
178	INTEGER(kind=C_INT) :: rename_c !! 0 on success, last errno on failure
179	END FUNCTION rename_c
180
181	FUNCTION chmod_c(path,mode) BIND(C,name="c_chmod")
182	!! Change file/directory permissions
183	IMPORT c_char, C_INT
184	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Path to modify
185	INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! New decimal permissions of the path to set
186	INTEGER(kind=C_INT) :: chmod_c !! 0 on success, last errno on failure
187	END FUNCTION chmod_c
188
189	FUNCTION chdir_c(new) BIND(C,name="c_chdir")
190	!! Change current directory
191	IMPORT c_char, C_INT
192	CHARACTER(kind=c_char), INTENT(in) :: new(*) !! Path of the new working directory
193	INTEGER(kind=C_INT) :: chdir_c !! 0 on success, last errno on failure
194	END FUNCTION chdir_c
195
196	FUNCTION mkdir_c(dirname,mode) BIND(C,name="c_mkdir")
197	!! Create directory
198	IMPORT c_char, C_INT
199	CHARACTER(kind=c_char), INTENT(in) :: dirname(*) !! Path of the directory to create
200	INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! Decimal permission to set
201	INTEGER(kind=C_INT) :: mkdir_c !! 0 on success, last errno on failure
202	END FUNCTION mkdir_c
203
204	FUNCTION mkdirp_c(dirname,mode) BIND(C,name="c_mkdirp")
205	!! Create directory recursively
206	IMPORT c_char, C_INT
207	CHARACTER(kind=c_char), INTENT(in) :: dirname(*) !! Path of the directory to create
208	INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! Decimal permission to set
209	INTEGER(kind=C_INT) :: mkdirp_c !! 0 on success, last errno on failure
210	END FUNCTION mkdirp_c
211
212	FUNCTION remove_c(path) BIND(C,name="c_remove")
213	!! Remove a file (or a directory) from the filesystem
214	IMPORT c_char, C_INT
215	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Path to delete
216	INTEGER(kind=C_INT) :: remove_c !! 0 on success, last errno on failure
217	END FUNCTION remove_c
218
219	FUNCTION rmdir_c(dirpath) BIND(C,name="c_rmdir")
220	!! Remove empty directory
221	IMPORT c_char, C_INT
222	CHARACTER(kind=c_char), INTENT(in) :: dirpath(*) !! Directory to delete
223	INTEGER(kind=C_INT) :: rmdir_c !! 0 on success, last errno on failure
224	END FUNCTION rmdir_c
225
226	FUNCTION rmdirf_c(dirpath) BIND(C,name="c_rmdir_f")
227	!! Remove directory (forced)
228	IMPORT c_char, C_INT
229	CHARACTER(kind=c_char), INTENT(in) :: dirpath(*) !! Directory to delete
230	INTEGER(kind=C_INT) :: rmdirf_c !! 0 on success, last errno on failure
231	END FUNCTION rmdirf_c
232
233	FUNCTION fstat_c(pa, pe, ln, ty, ui, gi, si, at, mt, ct) BIND(C, name='c_fstat')
234	!! Get file informations
235	IMPORT c_char, c_long, C_INT
236	CHARACTER(kind=c_char), INTENT(in) :: pa(*) !! Path of the file
237	INTEGER(kind=C_INT), INTENT(out) :: pe !! Decimal permission of the path
238	INTEGER(kind=C_INT), INTENT(out) :: ln !! Number of links
239	INTEGER(kind=C_INT), INTENT(out) :: ty !! Type of the path
240	INTEGER(kind=C_INT), INTENT(out) :: ui !! User ID of the path
241	INTEGER(kind=C_INT), INTENT(out) :: gi !! Group ID of the path
242	INTEGER(kind=c_long), INTENT(out) :: si !! Size of the path
243	CHARACTER(kind=c_char), INTENT(out) :: at(20) !! Last access date
244	CHARACTER(kind=c_char), INTENT(out) :: mt(20) !! Last modification date
245	CHARACTER(kind=c_char), INTENT(out) :: ct(20) !! Creation date
246	INTEGER(kind=C_INT) :: fstat_c !! 0 on success, last errno on failure
247	END FUNCTION fstat_c
248
249	FUNCTION termsize_c(r,c) BIND(C, name='c_termsize')
250	!! Get terminal window size
251	IMPORT C_INT
252	INTEGER(kind=C_INT), INTENT(out) :: r, & !! Number of rows
253	c !! Number of columns
254	INTEGER(kind=C_INT) :: termsize_c !! 0 on success, last errno on failure
255	END FUNCTION termsize_c
256
257	END INTERFACE
258
259
260	CONTAINS
261
262	FUNCTION fstring(string) RESULT(str)
263	!! Convert C string to Fortran string
264	!!
265	!! The method copies the input C string up to the last C_NULL_CHAR found (not including it),
266	!! and returns the converted Fortran string.
267	!! All other C_NULL_CHAR found in the C string are removed.
268	CHARACTER(len=*), INTENT(in) :: string !! A string from C
269	CHARACTER(len=:), ALLOCATABLE :: str !! Converted fortran string
270	INTEGER :: i,idx
271	str = ""
272	idx = INDEX(string,C_NULL_CHAR,.true.)
273	IF (idx == 0) THEN
274	str = string
275	ELSE
276	DO i=1,idx-1
277	IF (string(i:i) /= C_NULL_CHAR) str = str//string(i:i)
278	ENDDO
279	ENDIF
280	str = TRIM(str)
281	END FUNCTION fstring
282
283	FUNCTION cstr2fstr(cstr) RESULT(fstr)
284	!! Get a Fortran (allocatable) string from a C string
285	!!
286	!! The method build the fortran string from a TYPE(C_PTR) object that represent a
287	!! C char\* pointer string.
288	!! @note
289	!! If __cstr__ is not allocated (i.e. the C_PTR is not associated) or if it is set
290	!! to a C empty string (i.e. '\0') then the method returns an empty string.
291	!! @attention
292	!! The method does not free the underlying C string and it should be free using
293	!! [[fsystem(module):free_c(interface)]] method.
294	TYPE(C_PTR), INTENT(in) :: cstr
295	!! A TYPE(C_PTR) that represent the pointer to the C char array.
296	CHARACTER(len=:), ALLOCATABLE :: fstr
297	!! An allocatable Fortran string with the content of the input char array.
298	CHARACTER(len=1,kind=C_CHAR), DIMENSION(:), POINTER :: pchars
299	INTEGER :: i,length
300	IF (.NOT.C_ASSOCIATED(cstr)) THEN
301	fstr = ""
302	RETURN
303	ENDIF
304	length = INT(strlen_c(cstr), kind=4)
305	IF (length ==0) THEN
306	fstr = ""
307	RETURN
308	ENDIF
309	CALL C_F_POINTER(cstr,pchars,(/length/))
310	ALLOCATE(CHARACTER(len=length) :: fstr)
311	DO i=1,length
312	fstr(i:i) = pchars(i)
313	ENDDO
314	END FUNCTION cstr2fstr
315
316
317	FUNCTION cstring(string) RESULT(str)
318	!> convert Fortran string to cstring
319	!!
320	!! The method returns a copy of the input string suitable for C functions argument.
321	!! @note
322	!! Input string is trimmed during computations
323	CHARACTER(len=*), INTENT(in) :: string
324	!! A fortran string
325	CHARACTER(len=:,kind=C_CHAR), ALLOCATABLE :: str
326	!! Same string as __string__ except that C_NULL_CHAR is appended at the end
327	INTEGER :: slen
328	slen = LEN_TRIM(string)
329	ALLOCATE(CHARACTER(len=slen+1,kind=C_CHAR) :: str)
330	str(:slen) = TRIM(string) ; str(slen+1:slen+1) = C_NULL_CHAR
331	END FUNCTION cstring
332
333	!===============================================================================
334	! C WRAPPER FUNCTIONS/SUBROUTINES
335	!===============================================================================
336
337	FUNCTION fs_getgid() RESULT(ret)
338	!! Get Group ID
339	INTEGER(kind=4) :: ret !! An integer with the group identifier
340	ret = INT(getgid_c(),kind=4)
341	RETURN
342	END FUNCTION fs_getgid
343
344	FUNCTION fs_getpid() RESULT(ret)
345	!! Get Process ID
346	INTEGER(kind=4) :: ret !! An integer with the current process identifier
347	ret = INT(getpid_c(),kind=4)
348	RETURN
349	END FUNCTION fs_getpid
350
351	FUNCTION fs_getuid() RESULT(ret)
352	!! Get User ID
353	INTEGER(kind=4) :: ret !! An integer with the user identifier
354	ret = INT(getuid_c(),kind=4)
355	RETURN
356	END FUNCTION fs_getuid
357
358	FUNCTION fs_gname(gid) RESULT(gname)
359	!! Get a group name from a group id
360	INTEGER, INTENT(in) :: gid !! User id to check
361	CHARACTER(len=:), ALLOCATABLE :: gname !! A string with the name of the group id
362	TYPE(C_PTR) :: zname
363	zname = gname_c(gid)
364	IF (.NOT.C_ASSOCIATED(zname)) THEN
365	gname = ""
366	ELSE
367	gname = cstr2fstr(zname)
368	ENDIF
369	CALL free_c(zname)
370	END FUNCTION fs_gname
371
372	FUNCTION fs_uname(uid) RESULT(uname)
373	!! Get a user name from a user id
374	INTEGER, INTENT(in) :: uid !! User id to check
375	CHARACTER(len=:), ALLOCATABLE :: uname !! A string with the name of the user id
376	TYPE(C_PTR) :: zname
377	zname = gname_c(uid)
378	IF (.NOT.C_ASSOCIATED(zname)) THEN
379	uname = ""
380	ELSE
381	uname = cstr2fstr(zname)
382	ENDIF
383	CALL free_c(zname)
384	END FUNCTION fs_uname
385
386	FUNCTION fs_dirname(path) RESULT(opath)
387	!! Get the parent directory path of the given path
388	CHARACTER(len=*), INTENT(in) :: path
389	!! A string with a (valid) path
390	CHARACTER(len=:), ALLOCATABLE :: opath
391	!! A Fortran allocated string with the parent directory path or an empty string if method fails
392	TYPE(C_PTR) :: zpath
393	IF (LEN_TRIM(path) == 0) THEN
394	opath = ""
395	RETURN
396	ENDIF
397	zpath = dirname_c(cstring(ADJUSTL(path)))
398	IF (.NOT.C_ASSOCIATED(zpath)) THEN
399	opath = ""
400	ELSE
401	opath = cstr2fstr(zpath)
402	ENDIF
403	CALL free_c(zpath)
404	END FUNCTION fs_dirname
405
406	FUNCTION fs_basename(path) RESULT(opath)
407	!! Get the base name of the path
408	CHARACTER(len=*), INTENT(in) :: path
409	!! A string with a (valid) path
410	CHARACTER(len=:), ALLOCATABLE :: opath
411	!! The basename of the path or an empty string if method fails
412	TYPE(C_PTR) :: zpath
413	IF (LEN_TRIM(path) == 0) THEN
414	opath = ""
415	RETURN
416	ENDIF
417	zpath = basename_c(cstring(ADJUSTL(path)))
418	IF (.NOT.C_ASSOCIATED(zpath)) THEN
419	opath = ""
420	ELSE
421	opath = cstr2fstr(zpath)
422	ENDIF
423	CALL free_c(zpath)
424	END FUNCTION fs_basename
425
426	FUNCTION fs_realpath(path) RESULT(opath)
427	!! Get the real path of the path
428	!!
429	!! The method computes the absolute path of the given path using C realpath function.
430	!! @note
431	!! If the input path is empty then current working directory is returned.
432	CHARACTER(len=*), INTENT(in) :: path
433	!! A string with a (valid) path
434	CHARACTER(len=:), ALLOCATABLE :: opath
435	!! The absolute of the path or an empty string if method fails
436	TYPE(C_PTR) :: zpath
437	zpath = realpath_c(cstring(ADJUSTL(path)))
438	IF (.NOT.C_ASSOCIATED(zpath)) THEN
439	opath = ""
440	ELSE
441	opath = cstr2fstr(zpath)
442	ENDIF
443	CALL free_c(zpath)
444	END FUNCTION fs_realpath
445
446	FUNCTION fs_relpath(path,reldir) RESULT(res)
447	!! Get the relative representation of two paths
448	!!
449	!! The method computes the relative representation of __path__ from __reldir__ if possible.
450	!! If no common prefix is found, the method returns __path__.
451	CHARACTER(len=*), INTENT(in) :: path, & !! Path to be computed relative to reldir
452	reldir !! A directory path from which output should be relative to
453	CHARACTER(len=:), ALLOCATABLE :: res !! An allocated string with the resulting path
454	TYPE(C_PTR) :: zpath
455	zpath = relpath_c(cstring(ADJUSTL(path)),cstring(ADJUSTL(reldir)))
456	IF (.NOT.C_ASSOCIATED(zpath)) THEN
457	res = TRIM(ADJUSTL(path))
458	ELSE
459	res = cstr2fstr(zpath)
460	ENDIF
461	CALL free_c(zpath)
462	END FUNCTION fs_relpath
463
464	FUNCTION fs_getcwd() RESULT(path)
465	!! Get the current working directory
466	CHARACTER(len=:), ALLOCATABLE :: path
467	!! The current working directory or an empty string if method fails
468	TYPE(C_PTR) :: zpath
469	zpath = getcwd_c()
470	IF (C_ASSOCIATED(zpath)) THEN
471	path = cstr2fstr(zpath)
472	ELSE
473	path = ""
474	ENDIF
475	CALL free_c(zpath)
476	RETURN
477	END FUNCTION fs_getcwd
478
479	FUNCTION fs_remove(path) RESULT(ret)
480	!! Delete the file/directory pointed by the given path
481	CHARACTER(len=*), INTENT(in) :: path !! A string with the (valid) file path to delete
482	LOGICAL :: ret !! True on success, false otherwise.
483	IF (LEN_TRIM(path) == 0) THEN
484	ret = .false.
485	ELSE
486	ret = INT(remove_c(cstring(ADJUSTL(path)))) == 0
487	ENDIF
488	RETURN
489	END FUNCTION fs_remove
490
491	FUNCTION fs_rename(old, new) RESULT(ret)
492	!! Rename a path
493	CHARACTER(len=*), INTENT(in) :: old, & !! A string with the (valid) path to rename
494	new !! A string with the new name of the path
495	LOGICAL :: ret !! True on success, false otherwise.
496	IF (LEN_TRIM(old) == 0.OR.LEN_TRIM(new) == 0) THEN
497	ret = .false.
498	ELSE
499	ret = INT(rename_c(cstring(ADJUSTL(old)),cstring(ADJUSTL(new)))) == 0
500	ENDIF
501	RETURN
502	END FUNCTION fs_rename
503
504	FUNCTION fs_chmod(path, mode) RESULT(ret)
505	!! Change file/directory permissions
506	CHARACTER(len=*), INTENT(in) :: path !! Path to modify
507	INTEGER, INTENT(in) :: mode !! New octal permissions of the file
508	LOGICAL :: ret !! True on success, false otherwise.
509	INTEGER(kind=C_INT) :: zmode
510	IF (LEN_TRIM(path) == 0) THEN
511	ret = .false.
512	ELSE
513	zmode = INT(oct_2_dec(mode),kind=C_INT)
514	ret = INT(chmod_c(cstring(ADJUSTL(path)), zmode)) == 0
515	ENDIF
516	RETURN
517	END FUNCTION fs_chmod
518
519	FUNCTION fs_chdir(path) RESULT(ret)
520	!! Change current working directory
521	CHARACTER(len=*), INTENT(in) :: path !! Path of the new working directory
522	LOGICAL :: ret !! True on success, false otherwise.
523	IF (LEN_TRIM(path) == 0) THEN
524	ret = .false.
525	ELSE
526	ret = INT(chdir_c(cstring(ADJUSTL(path)))) == 0
527	ENDIF
528	RETURN
529	END FUNCTION fs_chdir
530
531	FUNCTION fs_mkdir(path, mode, permissive) RESULT(ret)
532	!! Create directory
533	!!
534	!! The method attempts to create a new directory pointed by __path__ with the permission
535	!! given by mode.
536	CHARACTER(len=*), INTENT(in) :: path
537	!! The path to modify
538	INTEGER, INTENT(in), OPTIONAL :: mode
539	!! Optional octal permission to set for the new directory
540	LOGICAL, INTENT(in), OPTIONAL :: permissive
541	!! Optional boolean with .true. to create intermediate directories in the path
542	LOGICAL :: ret
543	!! True on success, false otherwise.
544	INTEGER :: zmode
545	LOGICAL :: zperm
546	IF (LEN_TRIM(path) == 0) THEN
547	ret = .false.
548	ELSE
549	zmode = oct_2_dec(744)
550	IF (PRESENT(mode)) THEN
551	IF (.NOT.chk_pm(mode)) THEN
552	ret = .false. ; RETURN
553	ENDIF
554	zmode = oct_2_dec(mode)
555	ENDIF
556	zperm = .false. ; IF (PRESENT(permissive)) zperm = permissive
557	IF (zperm) THEN
558	ret = INT(mkdirp_c(cstring(ADJUSTL(path)),INT(zmode,kind=C_INT))) == 0
559	ELSE
560	ret = INT(mkdir_c(cstring(ADJUSTL(path)),INT(zmode,kind=C_INT))) == 0
561	ENDIF
562	ENDIF
563	RETURN
564	END FUNCTION fs_mkdir
565
566	FUNCTION fs_rmdir(path,forced) RESULT(ret)
567	!! Remove directory
568	!!
569	!! By default, the function removes an __empty__ directory. If __forced__ is given and set
570	!! to .true. then the function recursively deletes the directory and __ALL__ its content.
571	CHARACTER(len=*), INTENT(in) :: path
572	!! The path of the directory to delete
573	LOGICAL, INTENT(in), OPTIONAL :: forced
574	!! Optional boolean with @ti{.true.} to remove all contents of the directory.
575	LOGICAL :: ret
576	!! True on success, false otherwise.
577	LOGICAL :: zforce
578	IF (LEN_TRIM(path) == 0) THEN
579	ret = .false.
580	ELSE
581	zforce = .false. ; IF (PRESENT(forced)) zforce = forced
582	IF (.NOT.zforce) THEN
583	ret = INT(rmdir_c(cstring(ADJUSTL(path)))) == 0
584	ELSE
585	ret = INT(rmdirf_c(cstring(ADJUSTL(path)))) == 0
586	ENDIF
587	ENDIF
588	RETURN
589	END FUNCTION fs_rmdir
590
591	FUNCTION fs_stat(path,type,perm,nlnks,uid,gid,fsize,atime,mtime,ctime) RESULT(ret)
592	!! Get some informations about a path
593	!!
594	!! The method retrieves various informations about the input path using fstat C function.
595	!! The type of path as returned in __type__ argument is can take the following values:
596	!!
597	!! - 0, a file
598	!! - 1, a link to a file
599	!! - 2, a directory
600	!! - 3, a link to a directory
601	!! - 4, other (fifo, socket, block special, char special...)
602	CHARACTER(len=*), INTENT(in) :: path !! Input path
603	INTEGER, INTENT(out), OPTIONAL :: type, & !! Optional type of path (see function documentation).
604	perm, & !! Optional permission of the path
605	nlnks, & !! Optional number of links to the path
606	uid, & !! Optional user id
607	gid !! Optional group id
608	INTEGER(kind=8), INTENT(out), OPTIONAL :: fsize !! Optional file size
609	CHARACTER(len=19), INTENT(out), OPTIONAL :: atime, & !! Optional last access time
610	mtime, & !! Optional last modification time
611	ctime !! Optional creation time
612	LOGICAL :: ret !! True on success, false otherwise.
613	INTEGER :: ty,pe,ln,ud,gd
614	INTEGER(kind=8) :: fs
615	CHARACTER(len=:), ALLOCATABLE :: at,mt,ct
616	INTEGER(kind=C_INT) :: p,l,t,u,g
617	INTEGER(kind=c_long) :: f
618	CHARACTER(len=20,kind=C_CHAR) :: ta,tm,tc
619	IF (LEN_TRIM(path) == 0) THEN
620	ret = .false.; RETURN
621	ELSE IF (.NOT.(PRESENT(type) .OR. PRESENT(perm) .OR. PRESENT(nlnks) .OR. &
622	PRESENT(uid) .OR. PRESENT(gid) .OR. PRESENT(fsize) .OR. &
623	PRESENT(atime) .OR. PRESENT(mtime) .OR. PRESENT(ctime))) THEN
624	ret = .true.
625	ELSE
626	! set default values
627	pe=-1 ; ty=-1 ; ud=-1 ; gd=-1 ; fs=-1 ; at="" ; mt="" ; ct=""
628	ret = INT(fstat_c(cstring(ADJUSTL(path)),p,l,t,u,g,f,ta,tm,tc)) == 0
629	IF (ret) THEN
630	pe=INT(p) ; ln=INT(l) ; ty=INT(t) ; ud=INT(u) ; gd=INT(g)
631	fs=INT(f,kind=8)
632	at = fstring(ta)
633	mt = fstring(tm)
634	ct = fstring(tc)
635	ENDIF
636	IF (PRESENT(type)) type = ty
637	IF (PRESENT(perm)) perm = pe
638	IF (PRESENT(nlnks)) nlnks = ln
639	IF (PRESENT(uid)) uid = ud
640	IF (PRESENT(gid)) gid = gd
641	IF (PRESENT(fsize)) fsize = fs
642	IF (PRESENT(atime)) atime = at
643	IF (PRESENT(mtime)) mtime = mt
644	IF (PRESENT(ctime)) ctime = ct
645	ENDIF
646	RETURN
647	END FUNCTION fs_stat
648
649	FUNCTION fs_isdir(path) RESULT (ret)
650	!! Check if a path is a directory
651	!!
652	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
653	!! information about __path__ type.
654	CHARACTER(len=*), INTENT(in) :: path !! The path to check
655	LOGICAL :: ret !! .true. if the path is a directory, .false. otherwise.
656	INTEGER :: ty
657	ret = fs_stat(path,type=ty)
658	ret = ret.AND.(ty==2.or.ty==3)
659	RETURN
660	END FUNCTION fs_isdir
661
662	FUNCTION fs_isfile(path) RESULT (ret)
663	!! Check if a path is a file
664	!!
665	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
666	!! information about __path__ type.
667	CHARACTER(len=*), INTENT(in) :: path !! The path to check
668	LOGICAL :: ret !! .true. if the path is a file, .false. otherwise.
669	INTEGER :: ty
670	ret=fs_stat(path,type=ty)
671	ret = ret.and.(ty==0.or.ty==1)
672	RETURN
673	END FUNCTION fs_isfile
674
675	FUNCTION fs_islink(path) RESULT (ret)
676	!! Check if a path is a link
677	!!
678	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
679	!! information about __path__ type.
680	CHARACTER(len=*), INTENT(in) :: path !! The path to check
681	LOGICAL :: ret !! .true. if the path is a link, .false. otherwise.
682	INTEGER :: ty
683	ret=fs_stat(path,type=ty)
684	ret = ret.and.(ty==1.or.ty==3)
685	RETURN
686	END FUNCTION fs_islink
687
688	FUNCTION fs_access(path,permission) RESULT(ret)
689	!! Check if a path is accessible for current user
690	!!
691	!! The method checks if the given path is accessible for the current user. By default,
692	!! it does not check for specific permissions. If __permission__ is given it should be
693	!! an integer between 0 and 7 resulting from the possible combinations:
694	!!
695	!! - 0 : Checks for path existence (default)
696	!! - 1 : Checks for EXECUTE permission
697	!! - 2 : Checks for WRITE permission
698	!! - 4 : Checks for READ permission
699	CHARACTER(len=*), INTENT(in) :: path !! Path to check
700	INTEGER, INTENT(in), OPTIONAL :: permission !! Optional permission to check
701	LOGICAL :: ret !! True on success, false otherwise.
702	INTEGER(kind=C_INT) :: zp
703	IF (LEN_TRIM(path) == 0) THEN
704	ret = .false.
705	ELSE
706	zp = 0 ; IF (PRESENT(permission)) zp = INT(permission,kind=C_INT)
707	! Defaults are set in the C function.
708	ret = INT(access_c(cstring(ADJUSTL(path)),zp)) == 0
709	ENDIF
710	RETURN
711	END FUNCTION fs_access
712
713	FUNCTION fs_split_ext(path, base, ext, absolute) RESULT(ret)
714	!! Split given path into base,extension
715	!!
716	!! The __base__ of a path is conventionnally defined as all characters before the last dot of the path.
717	!! The extension (__ext__) of the path gathers consequently all characters from the last dot to the end
718	!! of the string.
719	!! @note
720	!! If the basename of the path begins by a dot then the path is assumed to be an hidden file (directory).
721	!! __ext__ will then be empty.
722	CHARACTER(len=*), INTENT(in) :: path !! Path to split
723	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: base, & !! Output base of the path
724	ext !! Output extension of the path
725	LOGICAL, INTENT(in), OPTIONAL :: absolute !! .true. to return absolute path
726	LOGICAL :: ret !! .true. on success, .false. otherwise.
727	LOGICAL :: zabs
728	INTEGER :: p
729	CHARACTER(len=:), ALLOCATABLE :: d,b,apath
730	base = "" ; ext = ""
731	ret = .false.
732	IF (LEN_TRIM(path) == 0) THEN
733	RETURN
734	ENDIF
735	zabs = .false. ; IF (PRESENT(absolute)) zabs = absolute
736	apath = TRIM(path)
737	IF (zabs) THEN
738	apath = fs_realpath(path) ; IF (LEN_TRIM(apath) == 0) RETURN
739	ENDIF
740	d = fs_dirname(apath) ; IF (LEN_TRIM(d) == 0) RETURN
741	b = fs_basename(apath) ; IF (LEN_TRIM(b) == 0) RETURN
742	p = INDEX(b,".",.true.)
743	! If dot is set as first char of basename : it's an hidden file
744	IF (p > 1) THEN
745	ext = b(p:) ; base = TRIM(d)//"/"//b(:p-1)
746	ELSE
747	base = TRIM(apath)
748	ENDIF
749	ret = .true.
750	RETURN
751	END FUNCTION fs_split_ext
752
753	FUNCTION fs_create(path, mode, type, permissive) RESULT(ret)
754	!! Create a directory/file
755	!!
756	!! The method creates the file/directory pointed by given __path__.
757	!! If __type__ is not given, the method builds the path as :
758	!!
759	!! -# A file if the basename of the path contains an extension
760	!! -# A directory in any other cases.
761	!!
762	!! Otherwise __type__ should be set to "f" for file or "d" for directory.
763	!!
764	!! Unless __permissive__ is set to .true., the method will fails if intermediate
765	!! directories in the path do not exist.
766	CHARACTER(len=*), INTENT(in) :: path !! Path to create
767	INTEGER, INTENT(in), OPTIONAL :: mode !! Optional octal permisions to set
768	CHARACTER(len=1), INTENT(in), OPTIONAL :: type !! Optional type of path to create
769	LOGICAL, INTENT(in), OPTIONAL :: permissive !! .true. to create intermediate directories if not existing
770	LOGICAL :: ret !! True on success, false otherwise.
771	INTEGER :: zmd,zt,zp
772	CHARACTER(len=:), ALLOCATABLE :: b,e
773	ret = .false.
774	! Checking for existence
775	IF (LEN_TRIM(path) == 0) THEN
776	RETURN
777	ELSE IF (fs_access(path)) THEN
778	RETURN
779	ENDIF
780	! Set type of path
781	IF (PRESENT(type)) THEN
782	IF (.NOT.(type(1:1)=="f".OR.type(1:1)=="d")) THEN
783	RETURN
784	ELSE
785	zt=0 ; IF (type(1:1)=="f") zt = 1
786	ENDIF
787	ELSE
788	IF(.NOT.fs_split_ext(path,b,e)) RETURN
789	zt = 0 ; IF (LEN_TRIM(e) /= 0) zt=1
790	ENDIF
791	! set permissions according to type
792	IF (zt == 0) THEN
793	zmd = oct_2_dec(777)-get_umask()
794	ELSE
795	zmd = oct_2_dec(666) -get_umask()
796	ENDIF
797	! Check mode argument if present
798	IF (PRESENT(mode)) THEN
799	IF(.NOT.chk_pm(mode)) THEN
800	! not a valid permission : We raise an error and abort
801	RETURN
802	ELSE
803	zmd = oct_2_dec(mode)
804	ENDIF
805	ENDIF
806	zp = 0 ; IF(PRESENT(permissive)) THEN ; IF(permissive) zp=1 ; ENDIF
807	ret = INT(create_c(cstring(ADJUSTL(path)),INT(zmd,kind=C_INT),INT(zt,kind=C_INT),INT(zp,kind=C_INT))) == 0
808	RETURN
809	END FUNCTION fs_create
810
811	FUNCTION fs_get_parent(path, n) RESULT(opath)
812	!! Get the nth parent of the given path
813	!!
814	!! The method first resolves the given path using [[fsystem(module):fs_realpath(function)]]
815	!! to get an absolute path.
816	!! @note
817	!! If __n__ is greater than the maximum parent level of the path, "/" is returned.
818	CHARACTER(len=*), INTENT(in) :: path
819	!! Input path
820	INTEGER, INTENT(in), OPTIONAL :: n
821	!! The level of the parent to get
822	CHARACTER(len=:), ALLOCATABLE :: opath
823	!! The nth parent of the given path, or an empty string if the parent can not be computed
824	CHARACTER(len=:), ALLOCATABLE :: zp
825	INTEGER :: i,mx,zl,mzl
826	opath = ""
827	zl = 1 ; IF (PRESENT(n)) zl = MAX(n,1)
828	IF (LEN_TRIM(path) == 0) THEN
829	RETURN
830	ENDIF
831	! Gets the absolute path
832	zp = fs_realpath(TRIM(ADJUSTL(path)))
833	IF (LEN_TRIM(zp) == 0) RETURN
834	! removing trailing / (only if it's not the first ^^)
835	mx = LEN_TRIM(zp) ; IF (zp(mx:mx)=="/".AND.mx/=1) zp(mx:mx) = ""
836	! compute maximum level
837	mzl = 1 ; DO i=1,mx ; IF(zp(i:i) == '/') mzl=mzl+1 ; ENDDO
838	i=0
839	DO
840	mx = INDEX(zp(1:mx),'/',.true.) ; i=i+1
841	IF (mx==0.OR.i>=zl.OR.i>=mzl) EXIT
842	mx = mx - 1
843	ENDDO
844	IF (mx >= 1) THEN
845	opath = zp(1:MAX(1,mx-1))
846	ELSE
847	opath = "/"
848	ENDIF
849	RETURN
850	END FUNCTION fs_get_parent
851
852	SUBROUTINE fs_termsize(row, column)
853	!! Get the current terminal window size
854	!! @attention
855	!! If the program is redirected to a file (and maybe some other device), the C
856	!! function can raise an error. In that case, the default values (20,80) are
857	!! returned by the C function and thus the subroutine !
858	INTEGER, INTENT(out) :: row, & !! Number of rows of the window
859	column !! Number of columns of the window
860	INTEGER(kind=C_INT) :: r, c, ret
861	ret = termsize_c(r,c)
862	row = INT(r) ; column = INT(c)
863	RETURN
864	END SUBROUTINE fs_termsize
865
866	SUBROUTINE fs_usleep(usec)
867	!! Sleep for a given number of microseconds
868	!! @note
869	!! Currently if C usleep function failed, the system... does not sleep !
870	INTEGER, INTENT(in) :: usec !! The number of microseconds to sleep for
871	INTEGER(kind=C_INT) :: ret
872	! usleep expects useconds_t (unsigned int) which is given here as a 4-bytes int
873	ret = usleep_c(INT(usec,kind=C_INT))
874	END SUBROUTINE fs_usleep
875
876	SUBROUTINE fs_msleep(msec)
877	!! Sleep for a given number of milliseconds
878	INTEGER, INTENT(in) :: msec !! The number of milliseconds to sleep for
879	CALL fs_usleep(msec*1000)
880	END SUBROUTINE fs_msleep
881
882	!===============================================================================
883	! MODULE MISCELLANEOUS METHODS
884	!===============================================================================
885
886	FUNCTION oct_2_dec(octal) RESULT(res)
887	!> Octal to decimal conversion
888	!!
889	!! The method converts the octal number ranging from 0 to 777 in the decimal system.
890	!! @attention
891	!! If the __octal__ number is out of range then the method returns 384 (600 in octal).
892	INTEGER, INTENT(in) :: octal !! The octal value to convert
893	INTEGER :: res !! The converted decimal value
894	INTEGER :: o,d,i
895	IF (octal < 0 .OR. octal > 777) THEN
896	res = 384 ; RETURN ! --> 600 in octal : rw-------
897	ENDIF
898	d = 0 ; i = 0 ; o = octal
899	DO WHILE(o/=0)
900	d=d+mod(o,10)8*i ; i=i+1 ; o=o/10
901	ENDDO
902	res=d
903	RETURN
904	END FUNCTION oct_2_dec
905
906	FUNCTION dec_2_oct(decimal) RESULT(res)
907	!! Decimal to octal conversion
908	!! The method converts the decimal number ranging from 0 to 511 in the octal system.
909	!! @attention
910	!! If the __decimal__ number is out of range, then it the method returns 600 (384 in decimal).
911	INTEGER, INTENT(in) :: decimal !! The decimal value to convert
912	INTEGER :: res !! The converted octal value
913	! - LOCAL
914	INTEGER :: o,d,i,m
915	IF (decimal < 0 .OR. decimal > 511) THEN
916	res = 600 ; RETURN ! --> 384 in decimal : rw-------
917	ENDIF
918	o=0 ; d = decimal ; i=0 ; m=0
919	DO WHILE(d/=0)
920	d=d/8 ; m=m+1
921	ENDDO
922	m=m-1 ; d=decimal
923	DO i=0,m
924	o=o+mod(d,8)10*i ; d=d/8
925	ENDDO
926	res = o
927	RETURN
928	END FUNCTION dec_2_oct
929
930	FUNCTION sp_2_op(str) RESULT(oct)
931	!! Get octal number of string representation's permission
932	CHARACTER(len=3),INTENT(in) :: str !! The permission to convert
933	INTEGER :: oct !! Octal value of the string permission on succes, -1 otherwise.
934	oct = -1
935	IF (LEN_TRIM(str) /= 3) RETURN
936	SELECT CASE(str)
937	CASE("---") ; oct = 0
938	CASE("--x") ; oct = 1
939	CASE("-w-") ; oct = 2
940	CASE("-wx") ; oct = 3
941	CASE("r--") ; oct = 4
942	CASE("r-x") ; oct = 5
943	CASE("rw-") ; oct = 6
944	CASE("rwx") ; oct = 7
945	CASE DEFAULT
946	oct = -1 ; RETURN
947	END SELECT
948	RETURN
949	END FUNCTION sp_2_op
950
951	FUNCTION op_2_sp(oct) RESULT(str)
952	!! Get string representation of the octal number's permission
953	INTEGER, INTENT(in) :: oct !! Octal number to convert
954	CHARACTER(len=3) :: str !! String representation of the octal number on succes, 'ukn' otherwise
955	SELECT CASE(oct)
956	CASE(0) ; str="---"
957	CASE(1) ; str="--x"
958	CASE(2) ; str="-w-"
959	CASE(3) ; str="-wx"
960	CASE(4) ; str="r--"
961	CASE(5) ; str="r-x"
962	CASE(6) ; str="rw-"
963	CASE(7) ; str="rwx"
964	CASE DEFAULT
965	str='ukn' ; RETURN
966	END SELECT
967	RETURN
968	END FUNCTION op_2_sp
969
970	FUNCTION str_perm(oct_perm) RESULT(ret)
971	!! Get the string representation of the given permission mask
972	INTEGER, INTENT(in) :: oct_perm !! The octal representation of the permission
973	CHARACTER(len=9) :: ret !! String representation of the octal number on succes, 'ukn' otherwise
974	INTEGER :: u,g,o
975	IF (.NOT.chk_pm(oct_perm)) THEN
976	ret = "ukn" ; RETURN
977	ENDIF
978	u=int(oct_perm/100) ; g=int((oct_perm-u100)/10) ; o=int(oct_perm-u100-g*10)
979	ret(1:3) = op_2_sp(u) ; ret(4:6) = op_2_sp(g) ; ret(7:9) = op_2_sp(o)
980	RETURN
981	END FUNCTION str_perm
982
983	FUNCTION oct_perm(str) RESULT(ret)
984	!! Get the string representation of the given permission mask
985	CHARACTER(len=9), INTENT(in) :: str !! The string representation of the permission
986	INTEGER :: ret !! Octal permission on success, -1 otherwise
987	! - LOCAL
988	INTEGER :: u,g,o
989	u = sp_2_op(str(1:3)) ; g = sp_2_op(str(4:6)) ; o = sp_2_op(str(7:9))
990	IF (u==-1.OR.g==-1.OR.o==-1) THEN
991	ret = -1 ; RETURN
992	ELSE
993	ret = u100 + g10 + o
994	ENDIF
995	RETURN
996	END FUNCTION oct_perm
997
998	FUNCTION chk_pm(perm) RESULT(valid)
999	!! Check if the given permission is valid
1000	INTEGER, INTENT(in) :: perm !! Octal permission mask
1001	LOGICAL :: valid !! .true. if the permission mask is valid, .false. otherwise
1002	INTEGER :: u,g,o
1003	u=int(perm/100) ; g=int((perm-u100)/10) ; o=int(perm-u100-g*10)
1004	valid = (u>=0.AND.u<=7).AND.(g>=0.AND.g<=7).AND.(o>=0.AND.o<=7)
1005	RETURN
1006	END FUNCTION chk_pm
1007
1008	FUNCTION get_umask() RESULT(mask)
1009	!! Get the umask value of the current session
1010	INTEGER :: mask !! Current umask value in decimal system
1011	mask = INT(umask_c())
1012	RETURN
1013	END FUNCTION get_umask
1014
1015	FUNCTION sz2str(file_size) RESULT(fstr)
1016	!! Get a human readable file size
1017	INTEGER(kind=8), INTENT(in) :: file_size !! File size (assumed to be bytes)
1018	CHARACTER(len=50) :: fstr !! Size in a human readable format
1019	! - LOCAL
1020	INTEGER :: cc
1021	REAL(kind=8) :: zfs
1022	CHARACTER(len=2), DIMENSION(6), PARAMETER :: sn = &
1023	(/'B ','KB','MB','GB','TB','PB'/)
1024	zfs=DBLE(file_size)
1025	DO cc=1,size(sn)-1 ; IF (zfs<1024.) EXIT ; zfs=zfs/1024. ; ENDDO
1026	IF (MOD(zfs,1.0) == 0) THEN
1027	WRITE(fstr,'(I50)') INT(zfs) ; fstr = TRIM(ADJUSTL(fstr))//sn(cc)
1028	ELSE
1029	WRITE(fstr,'(F50.2)') zfs ; fstr = TRIM(ADJUSTL(fstr))//sn(cc)
1030	ENDIF
1031	RETURN
1032	END FUNCTION sz2str
1033
1034	END MODULE FSYSTEM

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format