Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!! !!!!
4 : !!!! ParaMonte: Parallel Monte Carlo and Machine Learning Library. !!!!
5 : !!!! !!!!
6 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab !!!!
7 : !!!! !!!!
8 : !!!! This file is part of the ParaMonte library. !!!!
9 : !!!! !!!!
10 : !!!! LICENSE !!!!
11 : !!!! !!!!
12 : !!!! https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md !!!!
13 : !!!! !!!!
14 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16 :
17 : !> \brief
18 : !> This module contains implementations of the procedures in [pm_sysPath](@ref pm_sysPath).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \FatemehBagheri, Wednesday 12:20 AM, October 13, 2021, Dallas, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : #if INTEL_ENABLED && WINDOWS_ENABLED
28 : #define SHARED, shared
29 : #else
30 : #define SHARED
31 : #endif
32 : !%%%%%%%%%%%%
33 : #if isDir_ENABLED
34 : !%%%%%%%%%%%%
35 :
36 : character(*,SKC), parameter :: DSP = DIR_SEP_POSIX
37 : character(*,SKC), parameter :: DSW = DIR_SEP_WINDOWS
38 : #if INTEL_ENABLED && DD_ENABLED
39 : inquire(directory = path, exist = pathIsDir)
40 : #elif INTEL_ENABLED && II_ENABLED
41 : if (present(iomsg)) then
42 : inquire(directory = path, exist = pathIsDir, iostat = iostat, iomsg = iomsg)
43 : else
44 : inquire(directory = path, exist = pathIsDir, iostat = iostat)
45 : end if
46 : #elif GNU_ENABLED && DD_ENABLED
47 623 : inquire(file = path//DSP, exist = pathIsDir)
48 623 : if (.not. pathIsDir) then
49 279 : inquire(file = path//DSW, exist = pathIsDir)
50 : end if
51 : #elif GNU_ENABLED && II_ENABLED
52 2993 : if (present(iomsg)) then
53 1549 : inquire(file = path//DSP, exist = pathIsDir, iostat = iostat, iomsg = iomsg)
54 : else
55 1444 : inquire(file = path//DSP, exist = pathIsDir, iostat = iostat)
56 : end if
57 : #elif DD_ENABLED || II_ENABLED
58 : character(len(c_null_char),SKC), parameter :: NULL_CHAR = c_null_char
59 : character(len(path) + 1, c_char) :: pathc
60 : interface
61 : function pm_sys_isdirc(pathc) result(itis) bind(C, name = "pm_sys_isdirc")
62 : import :: c_int32_t, c_char
63 : character(1, c_char), intent(in) :: pathc(*)
64 : integer(c_int32_t) :: itis
65 : end function
66 : end interface
67 : pathc = path//NULL_CHAR
68 : pathIsDir = logical(pm_sys_isdirc(pathc) == 1_c_int32_t, LK)
69 : #else
70 : #error "Unrecognized interface."
71 : #endif
72 :
73 : !%%%%%%%%%%%%%
74 : #elif isFile_ENABLED
75 : !%%%%%%%%%%%%%
76 :
77 : #if DD_ENABLED
78 399 : inquire(file = path, exist = pathIsFile)
79 : #elif II_ENABLED
80 2381 : if (present(iomsg)) then
81 1177 : inquire(file = path, exist = pathIsFile, iostat = iostat, iomsg = iomsg)
82 : else
83 1204 : inquire(file = path, exist = pathIsFile, iostat = iostat)
84 : end if
85 2381 : if (iostat /= 0_IK) return
86 : #else
87 : #error "Unrecognized interface."
88 : #endif
89 : #if !INTEL_ENABLED
90 2780 : if (pathIsFile) then
91 : #if DD_ENABLED
92 212 : pathIsFile = .not. isDir(path)
93 : #elif II_ENABLED
94 4768 : pathIsFile = .not. isDir(path, iostat, iomsg)
95 : #endif
96 : end if
97 : #endif
98 :
99 : !%%%%%%%%%%%%%%%
100 : #elif isExtant_ENABLED
101 : !%%%%%%%%%%%%%%%
102 :
103 : #if DD_ENABLED
104 40 : extant = isFile(path)
105 40 : if (.not. extant) extant = isDir(path)
106 : #elif II_ENABLED
107 4789 : extant = isFile(path, iostat, iomsg)
108 2381 : if (.not. extant) extant = isDir(path, iostat, iomsg)
109 : #else
110 : #error "Unrecognized interface."
111 : #endif
112 : !#if DD_ENABLED
113 : ! inquire(file = path, exist = extant)
114 : !#elif II_ENABLED
115 : ! if (present(iomsg)) then
116 : ! inquire(file = path, exist = extant, iostat = iostat, iomsg = iomsg)
117 : ! else
118 : ! inquire(file = path, exist = extant, iostat = iostat)
119 : ! end if
120 : ! if (iostat /= 0_IK) return
121 : !#else
122 : !#error "Unrecognized interface."
123 : !#endif
124 : !#if !INTEL_ENABLED
125 : ! if (.not. extant) then
126 : !#if DD_ENABLED
127 : ! extant = isDir(path)
128 : !#elif II_ENABLED
129 : ! extant = isDir(path, iostat, iomsg)
130 : !#endif
131 : ! end if
132 : !#endif
133 :
134 : !%%%%%%%%%%%%%%%%%
135 : #elif getDirName_ENABLED
136 : !%%%%%%%%%%%%%%%%%
137 :
138 : integer(IK) :: index
139 : #if Def_ENABLED
140 205 : index = getIndexDirName(path, dirsep)
141 205 : if (0_IK < index) then
142 118 : dirname = path(1_IK : index)
143 : else
144 87 : dirname = SKC_"."
145 : end if
146 : #elif PM_ENABLED
147 177 : index = getIndexDirName(path, dirsep, style)
148 177 : dirname = path(1_IK : index)
149 : #else
150 : #error "Unrecognized interface."
151 : #endif
152 :
153 : !%%%%%%%%%%%%%%%%%%
154 : #elif getBaseName_ENABLED
155 : !%%%%%%%%%%%%%%%%%%
156 :
157 : #if Def_ENABLED
158 164 : if (1_IK < len(path, IK)) then
159 : block
160 : integer(IK) :: offset
161 : ! remove trailing directory separator duplicates.
162 : offset = len(path, IK)
163 136 : if (len(dirsep, IK) == 1_IK) then
164 52 : do
165 120 : if (offset < 2_IK) exit
166 108 : if (dirsep /= path(offset : offset)) exit
167 108 : offset = offset - 1_IK
168 : end do
169 : else
170 44 : do
171 112 : if (offset < 2_IK) exit
172 100 : if (index(dirsep, path(offset : offset), kind = IK) == 0_IK) exit
173 112 : offset = offset - 1_IK
174 : end do
175 : end if
176 136 : basename = path(getIndexBaseName(path(1 : offset), dirsep) : offset)
177 : end block
178 : else
179 28 : basename = path
180 : end if
181 : #elif PM_ENABLED
182 176 : basename = path(getIndexBaseName(path, dirsep, style) :)
183 : #else
184 : #error "Unrecognized interface."
185 : #endif
186 :
187 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
188 : #elif (getIndexDirName_ENABLED || getIndexBaseName_ENABLED) && PM_ENABLED
189 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
190 :
191 353 : CHECK_ASSERTION(__LINE__, 0_IK < len(dirsep, IK), MODULE_NAME//SK_": The input `0 < len(dirsep)` must be a positive number. len(dirsep) = "//getStr(len(dirsep, IK)))
192 353 : index = scan(path, dirsep, back = .true., kind = IK)
193 : #if getIndexBaseName_ENABLED
194 176 : index = index + 1_IK
195 : #elif !getIndexDirName_ENABLED
196 : #error "Unrecognized interface."
197 : #endif
198 :
199 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
200 : #elif (getIndexDirName_ENABLED || getIndexBaseName_ENABLED) && Def_ENABLED
201 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
202 :
203 : integer(IK) :: offset
204 521 : CHECK_ASSERTION(__LINE__, 0_IK < len(dirsep, IK), MODULE_NAME//SK_": The input `0 < len(dirsep)` must be a positive number. len(dirsep) = "//getStr(len(dirsep, IK)))
205 : #if getIndexDirName_ENABLED
206 277 : if (len(path, IK) < 2_IK) then
207 52 : index = scan(path, dirsep, back = .true., kind = IK)
208 : !index = index + 1_IK
209 52 : return
210 : end if
211 : #endif
212 : ! remove trailing directory separator duplicates.
213 244 : offset = len(path, IK)
214 469 : if (len(dirsep, IK) == 1_IK) then
215 74 : do
216 407 : if (offset < 2_IK) exit
217 347 : if (dirsep /= path(offset : offset)) exit
218 347 : offset = offset - 1_IK
219 : end do
220 : else
221 : block
222 : intrinsic :: index
223 44 : do
224 180 : if (offset < 2_IK) exit
225 156 : if (index(dirsep, path(offset : offset), kind = IK) == 0_IK) exit
226 180 : offset = offset - 1_IK
227 : end do
228 : end block
229 : end if
230 : #if getIndexDirName_ENABLED
231 : block
232 : intrinsic :: index
233 225 : offset = scan(path(1 : offset), dirsep, back = .true., kind = IK)
234 : do
235 253 : if (offset < 2_IK) exit
236 98 : offset = offset - 1_IK
237 253 : if (index(dirsep, path(offset : offset), kind = IK) == 0_IK) exit
238 : end do
239 225 : if (offset == 2_IK) then ! `$(dirname "../")` on POSIX command line yields `"."`
240 0 : if (path(1:2) == SKC_"..") offset = 1_IK
241 : end if
242 : end block
243 : index = offset
244 : #elif getIndexBaseName_ENABLED
245 244 : index = scan(path(1 : offset - 1), dirsep, back = .true., kind = IK) + 1_IK
246 : #else
247 : #error "Unrecognized interface."
248 : #endif
249 :
250 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
251 : #elif getDirSep_ENABLED || getDirSeps_ENABLED || getPathSep_ENABLED
252 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
253 :
254 : ! \warning
255 : ! We cannot use FPP macros because this is dependent on the runtime shell.
256 178 : type(shell_type) :: shell
257 178 : if (present(failed) .and. present(errmsg)) then
258 82 : shell = shell_type(failed, errmsg)
259 96 : elseif (present(failed)) then
260 24 : shell = shell_type(failed)
261 : else
262 72 : shell = shell_type()
263 : end if
264 : #if getDirSep_ENABLED
265 57 : dirsep = shell%dirsep
266 : #elif getDirSeps_ENABLED
267 29 : dirseps = shell%dirseps
268 : #elif getPathSep_ENABLED
269 92 : pathsep = shell%pathsep
270 : #else
271 : #error "Unrecognized interface."
272 : #endif
273 :
274 : !%%%%%%%%%%%%%%%%%%%%%%%%%
275 : #elif getPathVerbatimCMD_ENABLED
276 : !%%%%%%%%%%%%%%%%%%%%%%%%%
277 :
278 12 : pathVerbatim = SKC_'"'//getRemoved(path, SKC_'"')//SKC_'"'
279 :
280 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
281 : #elif getPathVerbatimPowerShell_ENABLED
282 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
283 :
284 12 : pathVerbatim = SKC_"'"//getReplaced(path, SKC_"'", SKC_"''")//SKC_"'"
285 :
286 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%
287 : #elif getPathVerbatimPosix_ENABLED
288 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%
289 :
290 638 : pathVerbatim = SKC_"'"//getReplaced(path, SKC_"'", SKC_"'\''")//SKC_"'"
291 :
292 : !%%%%%%%%%%%%%%%%%%%%%%%%%%
293 : #elif getPathVerbatimFish_ENABLED
294 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%
295 :
296 20 : pathVerbatim = SKC_"'"//getReplaced(getReplaced(path, SKC_"\", SKC_"\\"), SKC_"'", SKC_"\'")//SKC_"'"
297 :
298 : !%%%%%%%%%%%%%%%%%%%%%%%%%%
299 : #elif getPathPosixEscaped_ENABLED
300 : !%%%%%%%%%%%%%%%%%%%%%%%%%%
301 :
302 : call setPathPosixEscaped(pathEscaped, path)
303 :
304 : !%%%%%%%%%%%%%%%%%%%%%%%%%%
305 : #elif setPathPosixEscaped_ENABLED
306 : !%%%%%%%%%%%%%%%%%%%%%%%%%%
307 :
308 : character(1,SKC), parameter :: POSIX_RESERVED_CHR_SKC(*) = POSIX_RESERVED_CHR
309 112 : integer(IK) :: i, j, counter, lenPath, Loc(len(path, IK))
310 : lenPath = len(path, IK)
311 56 : if (lenPath == 0_IK) then
312 8 : pathEscaped = path
313 : else
314 : counter = 0_IK
315 520 : do i = 1_IK, lenPath
316 23000 : loopOverShellEscapeChars: do j = 1_IK, size(POSIX_RESERVED_CHR_SKC, 1, IK)
317 22952 : if (path(i:i) == POSIX_RESERVED_CHR_SKC(j)) then
318 96 : counter = counter + 1_IK
319 96 : Loc(counter) = i
320 96 : exit loopOverShellEscapeChars
321 : end if
322 : end do loopOverShellEscapeChars
323 : end do
324 48 : allocate(character(lenPath + counter, SKC) :: pathEscaped)
325 48 : call setInserted(pathEscaped, path, SKC_"\", Loc(1:counter))
326 : end if
327 :
328 : !%%%%%%%%%%%%%%%%%%%
329 : #elif getPathPosix_ENABLED
330 : !%%%%%%%%%%%%%%%%%%%
331 :
332 28 : pathPosix = path
333 76 : call setPathPosix(pathPosix, ignore)
334 :
335 : !%%%%%%%%%%%%%%%%%%%%%
336 : #elif getPathWindows_ENABLED
337 : !%%%%%%%%%%%%%%%%%%%%%
338 :
339 80 : pathWindows = path
340 232 : call setPathWindows(pathWindows, ignore)
341 :
342 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
343 : #elif setPathPosix_ENABLED || setPathWindows_ENABLED
344 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
345 :
346 : character(:,SKC), allocatable :: pathNew
347 : character(*,SKC), parameter :: PSA = DIR_SEP_ALL ! Path Separators All
348 : #if setPathPosix_ENABLED
349 : character(1,SKC), parameter :: PSN = DIR_SEP_POSIX ! Path Separator Native
350 : #elif setPathWindows_ENABLED
351 : character(1,SKC), parameter :: PSN = DIR_SEP_WINDOWS ! Path Separator Native
352 : #endif
353 : integer(IK) :: i, j, lenPath, lenPathMin, lenIgnore, lenPathNew!, lenSeg, istart
354 : !logical(LK) :: isDot ! is pattern `PSN//"."//PSN`.
355 : logical(LK) :: isSPS ! is significant slash (meaning that it is not preceded by a slash).
356 :
357 : ! \warning
358 : ! The following code assumes that the Windows and posix directory separators will not change for the foreseeable future.
359 : ! As a layer of safety, the following code checks for the length DSWA to be 2 and its contents to have the posix directory separator.
360 : !error_stop_if(len(DSWA) /= 2, SK_"@setPathPosix()/setPathWindows(): Internal library error occurred. The condition `len(DSWA) == 2` must hold.")
361 : !error_stop_if(len(DSWA) /= 2, SK_"@setPathPosix()/setPathWindows(): Internal library error occurred. The condition `len(DSWA) == 2` must hold.")
362 : !error_stop_if(index(DSWA,PSN) == 0, SK_"@setPathPosix()/setPathWindows(): Internal library error occurred. The condition `index(DSWA,PSN) > 0` must hold.")
363 :
364 248 : if (present(ignore)) then
365 : lenIgnore = len(ignore, IK)
366 : else
367 : lenIgnore = 0_IK
368 : end if
369 :
370 248 : lenPath = len(path, IK)
371 248 : if (lenPath == 0_IK) return
372 :
373 : ! Note that multiple `\` characters in sequence in Linux or Windows reduce to a single `\`. Therefore, ignore all `\` characters.
374 : ! Here we are assuming that the input path is convertible to a valid Windows path, meaning that no Windows reserved character appears in the path.
375 : ! If there are any such illegal characters (for example, double quotation marks) or Windows reserved words, we do not check for them here.
376 : ! Illegal Windows characters (particularly the double quotation mark) can be handled via `getPathVerbatimCMD()` and `getPathVerbatimPowerShell()`.
377 :
378 232 : allocate(character(lenPath,SKC) :: pathNew)
379 :
380 : ! Skip any UNC path root.
381 :
382 232 : lenPathNew = getPathHostNameIndex(path, PSA)
383 232 : if (lenPathNew > 0_IK) then
384 24 : if (lenIgnore == 0_IK) then
385 24 : pathNew(1:2) = PSN//PSN
386 0 : elseif (lenIgnore == 2_IK .and. pathNew(1:2) == ignore) then
387 0 : pathNew(1:2) = ignore
388 : else
389 0 : pathNew(1:2) = PSN//PSN
390 : end if
391 24 : pathNew(3:lenPathNew) = path(3:lenPathNew)
392 : end if
393 :
394 : ! Construct the normalized path.
395 :
396 : isSPS = .true._LK
397 : !isSPS = .false._LK
398 : !isDot = .false._LK
399 : !istart = lenPathNew + 1_IK
400 : !i = istart
401 232 : i = lenPathNew + 1_IK
402 : lenPathMin = max(1_IK, lenPathNew)
403 232 : if (lenIgnore == 0_IK) then
404 : ! Remove trailing directory separators.
405 : !do
406 : ! if (lenPath == lenPathMin) exit
407 : ! if (scan(PSA, path(lenPath:lenPath), kind = IK) == 0_IK) exit
408 : ! lenPath = lenPath - 1_IK
409 : !end do
410 1844 : do
411 2056 : if (i > lenPath) exit
412 : !#define INCREMENT_PATH_NEW \
413 : ! if (scan(PSA, path(i:i), kind = IK) == 0_IK) then; \
414 : ! lenPathNew = lenPathNew + 1_IK; \
415 : ! !isDot = path(i:i) == SKC_"." .and. .not. isSPS; \
416 : ! pathNew(lenPathNew:lenPathNew) = path(i:i); \
417 : ! isSPS = .true._LK; \
418 : ! elseif (isSPS) then; \
419 : ! !elseif (isSPS .or. i == istart) then; \
420 : ! !if (isDot .and. lenPath > 2_IK) then; \
421 : ! ! lenPathNew = lenPathNew - 1_IK; \
422 : ! !else; \
423 : ! lenPathNew = lenPathNew + 1_IK; \
424 : ! pathNew(lenPathNew:lenPathNew) = PSN; \
425 : ! !end if; \
426 : ! isSPS = .false._LK; \
427 : ! end if; \
428 : ! i = i + 1_IK;
429 : #define INCREMENT_PATH_NEW \
430 : if (scan(PSA, path(i:i), kind = IK) == 0_IK) then; \
431 : lenPathNew = lenPathNew + 1_IK; \
432 : pathNew(lenPathNew:lenPathNew) = path(i:i); \
433 : isSPS = .true._LK; \
434 : elseif (isSPS) then; \
435 : lenPathNew = lenPathNew + 1_IK; \
436 : pathNew(lenPathNew:lenPathNew) = PSN; \
437 : isSPS = .false._LK; \
438 : end if; \
439 : i = i + 1_IK;
440 1844 : INCREMENT_PATH_NEW
441 : end do
442 : else
443 : !! first start index.
444 : !j = (lenPath / lenIgnore) * lenIgnore
445 : !if (j == lenPath) then
446 : ! j = lenPath - lenIgnore + 1_IK
447 : !else
448 : ! j = min((lenPath / lenIgnore) * lenIgnore + 1_IK, lenPath)
449 : !end if
450 : !! Trim dirsep from the end.
451 : !do
452 : ! if (lenPath == lenPathMin) exit
453 : ! lenSeg = min(lenPath,j+lenIgnore-1_IK) - j + 1_IK
454 : ! if (lenSeg == lenIgnore .and. path(j:j+lenSeg-1_IK) == ignore) exit
455 : ! if (scan(PSA, path(lenPath:lenPath), kind = IK) == 0_IK) exit
456 : ! lenPath = lenPath - 1_IK
457 : ! j = max(1_IK, j - 1_IK)
458 : !end do
459 : do
460 284 : if (i > lenPath) exit
461 264 : j = min(i + lenIgnore - 1_IK, lenPath)
462 284 : if (j - i + 1_IK == lenIgnore .and. path(i:j) == ignore) then
463 40 : lenPathNew = lenPathNew + 1_IK ! Do not move this.
464 40 : pathNew(lenPathNew : lenPathNew + lenIgnore - 1_IK) = ignore
465 : lenPathNew = lenPathNew + lenIgnore - 1_IK
466 : i = i + lenIgnore
467 : else
468 224 : INCREMENT_PATH_NEW
469 : !else ! This should happen only occasionally when `j == lenPath` and path(i:j) must be padded for comparison with `ignore`.
470 : ! lenPathNew = lenPathNew + 1_IK ! Do not move this.
471 : ! pathNew(lenPathNew : lenPathNew + j - i + 1_IK) = path(i:j)
472 : ! lenPathNew = lenPathNew + j - i + 1_IK
473 : ! i = i + j - i + 2_IK
474 : end if
475 : end do
476 : end if
477 : !#if setPathPosix_ENABLED
478 : ! if (present(escaped)) then
479 : ! if (escaped) call setPathPosixEscaped(path, pathNew(1:lenPathNew))
480 : ! deallocate(pathNew) ! \bug : required because gfortran automatic deallocation of heap memory fails as of version 12.
481 : ! return
482 : ! end if
483 : !#endif
484 232 : if (lenPathNew > 1_IK .and. pathNew(lenPathNew:lenPathNew) == PSN) lenPathNew = lenPathNew - 1_IK
485 232 : path = pathNew(1:lenPathNew)
486 232 : deallocate(pathNew) ! \bug : required because gfortran automatic deallocation of heap memory fails as of version 12.
487 :
488 : #undef INCREMENT_PATH_NEW
489 :
490 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%
491 : #elif getPathHostNameIndex_ENABLED
492 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%
493 :
494 : integer(IK) :: lenPath
495 : index = 0_IK
496 344 : lenPath = len(path, IK)
497 344 : if (lenPath < 3_IK) return
498 284 : if (scan(dirsep, path(1:1), kind = IK) == 0_IK) return
499 120 : if (scan(dirsep, path(2:2), kind = IK) == 0_IK) return
500 96 : if (scan(dirsep, path(3:3), kind = IK) > 0_IK) return
501 : index = 3_IK
502 : do
503 376 : index = index + 1_IK
504 376 : if (index > lenPath) exit
505 376 : if (scan(dirsep, path(index:index), kind = IK) > 0_IK) exit
506 : end do
507 : index = index - 1_IK
508 :
509 : !%%%%%%%%%%%%%%%%%%%%%
510 : #elif hasDriveLetter_ENABLED
511 : !%%%%%%%%%%%%%%%%%%%%%
512 :
513 128 : if (len(path,IK) > 1_IK) then
514 112 : pathHasDriveLetter = isCharAlpha(path(1:1)) .and. path(2:2) == SKC_":"
515 : else
516 : pathHasDriveLetter = .false._LK
517 : end if
518 :
519 : !%%%%%%%%%%%%%%%%%%%%%%%
520 : #elif isPathAbsWindows_ENABLED
521 : !%%%%%%%%%%%%%%%%%%%%%%%
522 :
523 : character(*,SKC), parameter :: DSWA = DIR_SEP_WINDOWS_ALL
524 : ERROR_STOP_IF(len(DSWA) /= 2, MODULE_NAME//SK_"@isPathAbsWindows(): Internal library error occurred. The condition `len(DSWA) == 2` must hold.")
525 :
526 84 : if (len(path, IK) > 2_IK) then
527 : !pathIsAbs = logical(index(DSWA, path(1:1), kind = IK) > 0_IK, LK)
528 56 : pathIsAbs = hasDriveLetter(path) .and. scan(DSWA, path(3:3), kind = IK) > 0_IK ! (path(3:3) == DSWA(1:1) .or. path(3:3) == DSWA(2:2)) ! \bug gfortran 11 bug: Error: Operands of comparison operator '==' at (1) are CHARACTER(*,4)/CHARACTER(1)
529 : if (pathIsAbs) return
530 : end if
531 :
532 76 : if (len(path, IK) > 1_IK) then
533 : !pathIsAbs = (path(1:1) == DSWA(1:1) .or. path(1:1) == DSWA(2:2)) .and. (path(2:2) == DSWA(1:1) .or. path(2:2) == DSWA(2:2)) ! \bug gfortran 11 bug: Error: Operands of comparison operator '==' at (1) are CHARACTER(*,4)/CHARACTER(1)
534 60 : pathIsAbs = verify(path(1:2), DSWA, kind = IK) == 0_IK
535 60 : if (pathIsAbs) return
536 : end if
537 :
538 : pathIsAbs = .false._LK
539 :
540 : !%%%%%%%%%%%%%%%%%%%%%
541 : #elif isPathAbsPosix_ENABLED
542 : !%%%%%%%%%%%%%%%%%%%%%
543 :
544 : character(*,SKC), parameter :: DSPA = DIR_SEP_POSIX_ALL
545 : ERROR_STOP_IF(len(DSPA) > 1, MODULE_NAME//SK_"@isPathAbsPosix(): Internal error occurred. `len(DSPA) == 1` must hold.")
546 155 : if (len(path, IK) > 0_IK) then
547 151 : pathIsAbs = logical(path(1:1) == DSPA, LK)
548 : else
549 : pathIsAbs = .false._LK
550 : end if
551 :
552 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
553 : #elif isFailedGlob_ENABLED && BSSK_ENABLED
554 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
555 :
556 : integer(IK) :: iloc, nloc
557 : integer(IK), allocatable :: index(:,:)
558 53 : character(:,SKC), allocatable :: contents
559 53 : failed = isFailedGlob(pattern, contents, index, errmsg)
560 53 : nloc = size(index, 2, IK)
561 1209 : allocate(list(nloc))
562 : do concurrent(iloc = 1 : nloc)
563 1209 : list(iloc)%val = contents(index(1, iloc) : index(2, iloc))
564 : end do
565 :
566 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
567 : #elif isFailedGlob_ENABLED && SK_ENABLED
568 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
569 :
570 : character(*, SK), parameter :: NLC = new_line(SKC_"a")
571 : character(*, SK), parameter :: PROCEDURE_NAME = MODULE_NAME//SK_"@isFailedGlob()"
572 : character(:,SKC), allocatable :: command, errmsg_def
573 : integer(IK) :: exitstat, iell
574 81 : type(shell_type) :: shell
575 :
576 81 : if (present(errmsg)) then
577 53 : allocate(character(len(errmsg, IK), SK) :: errmsg_def)
578 : else
579 28 : allocate(character(31, SK) :: errmsg_def)
580 : end if
581 :
582 : ! Infer the runtime shell.
583 :
584 81 : shell = shell_type(failed, errmsg_def)
585 81 : if (failed) then
586 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg_def) ! LCOV_EXCL_LINE
587 : return ! LCOV_EXCL_LINE
588 : end if
589 :
590 : ! Determine sorting method.
591 :
592 81 : if (shell%is%powershell .or. shell%is%cmd) then
593 0 : command = SKC_"(Resolve-Path "//getPathVerbatimPowerShell(pattern)//SKC_").path"
594 0 : if (shell%is%cmd) command = SKC_"powershell -command "//command
595 81 : elseif (shell%is%bash .or. shell%is%ksh .or. shell%is%zsh) then
596 0 : command = getCommandBashStyle(pattern)
597 : else
598 : ! check if bash exists on the system.
599 81 : failed = isFailedExec(SKC_"bash --version > /dev/null 2>&1")
600 81 : if (failed) then
601 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": Unsupported runtime shell: "//shell%name ! LCOV_EXCL_LINE
602 : return ! LCOV_EXCL_LINE
603 : end if
604 81 : command = SKC_"bash -c "//getPathVerbatimPosix(getCommandBashStyle(pattern))
605 : end if
606 :
607 : ! Fetch the list.
608 :
609 81 : failed = isFailedGetOutput(command, list, errmsg_def, exitstat = exitstat)
610 81 : if (failed) then
611 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg_def) ! LCOV_EXCL_LINE
612 : return ! LCOV_EXCL_LINE
613 81 : elseif (exitstat /= 0_IK) then
614 0 : index = reshape([integer(IK) ::], [0,0])
615 0 : list = SKC_""
616 0 : return
617 : end if
618 :
619 81 : exitstat = 0_IK
620 81 : call setSplit(index, list, NLC)
621 2603 : do iell = 1, size(index, 2, IK)
622 4849 : if (.not. isExtant(list(index(1, iell) : index(2, iell)), exitstat, errmsg)) then
623 21 : index = reshape([integer(IK) ::], [0, 0])
624 21 : list = SKC_""
625 21 : return
626 2360 : elseif (exitstat /= 0) then
627 : failed = .true._LK ! LCOV_EXCL_LINE
628 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": Failed while verifying the existence of """// & ! LCOV_EXCL_LINE
629 : list(index(1, iell) : index(2, iell))//SK_""". "//trim(errmsg) ! LCOV_EXCL_LINE
630 : return ! LCOV_EXCL_LINE
631 : end if
632 : end do
633 :
634 : contains
635 :
636 81 : PURE function getCommandBashStyle(pattern) result(command)
637 : character(*,SKC), intent(in) :: pattern
638 : character(:,SKC), allocatable :: command
639 81 : command = getReplaced(getReplaced(getPathVerbatimPosix(pattern), SKC_"*", SKC_"'*'"), SKC_"?", SKC_"'?'")
640 81 : command = SKC_"list=("//command//SKC_"); for file in ""${list[@]}""; do echo ""$file""; done"
641 81 : end function
642 :
643 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
644 : #elif isFailedList_ENABLED && BSSK_ENABLED
645 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
646 :
647 : integer(IK) :: iloc, nloc
648 : integer(IK), allocatable :: index(:,:)
649 260 : character(:,SKC), allocatable :: contents
650 780 : failed = isFailedList(path, contents, index, sort, showdir, showfile, showhidden, reversed, errmsg)
651 260 : nloc = size(index, 2, IK)
652 1468 : allocate(list(nloc))
653 : do concurrent(iloc = 1 : nloc)
654 1468 : list(iloc)%val = contents(index(1, iloc) : index(2, iloc))
655 : end do
656 :
657 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
658 : #elif isFailedList_ENABLED && SK_ENABLED
659 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
660 :
661 : character(*, SK), parameter :: NLC = new_line(SKC_"a")
662 : character(*, SK), parameter :: PROCEDURE_NAME = MODULE_NAME//SK_"@isFailedList()"
663 268 : character(:,SKC), allocatable :: command, dirlist, filelist, errmsg_def
664 : integer(IK) , allocatable :: dirIndex(:,:), fileIndex(:,:)
665 : integer(IK) :: lenList, istart, endloc, i, exitstat
666 : logical(LK) :: showhidden_def
667 : logical(LK) :: reversed_def
668 : logical(LK) :: showfile_def
669 : logical(LK) :: showdir_def
670 268 : type(shell_type) :: shell
671 :
672 268 : if (present(errmsg)) then
673 260 : allocate(character(len(errmsg,IK), SK) :: errmsg_def)
674 : else
675 8 : allocate(character(31, SK) :: errmsg_def)
676 : end if
677 :
678 268 : if (present(reversed)) then
679 0 : reversed_def = reversed
680 : else
681 : reversed_def = .false._LK
682 : end if
683 :
684 268 : if (present(showdir)) then
685 0 : showdir_def = showdir
686 : else
687 : showdir_def = .true._LK
688 : end if
689 :
690 268 : if (present(showfile)) then
691 0 : showfile_def = showfile
692 : else
693 : showfile_def = .true._LK
694 : end if
695 :
696 268 : if (present(showhidden)) then
697 0 : showhidden_def = showhidden
698 : else
699 : showhidden_def = .true._LK
700 : end if
701 :
702 : ! Infer the runtime shell.
703 :
704 268 : shell = shell_type(failed, errmsg_def)
705 268 : if (failed) then
706 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg_def) ! LCOV_EXCL_LINE
707 : return ! LCOV_EXCL_LINE
708 : end if
709 :
710 : ! Determine sorting method.
711 :
712 360 : if (shell%is%posix .or. shell%is%fish) then
713 :
714 : ! `ls` flags:
715 : ! -a, --all : do not ignore entries starting with `.`.
716 : ! -Q, --quote-name : enclose entry names in double quotes.
717 : ! -A, --almost-all : do not list implied `.` and `..`.
718 : ! -b, --escape : print C-style escapes for nongraphic characters.
719 : ! -c with -lt : sort by, and show, ctime (time of last modification of file status information); with -l: show ctime and sort by name; otherwise: sort by ctime, newest first.
720 : ! -F, --classify : append indicator (one of */=>@|) to entries. Display
721 : ! -# a slash (/) immediately after each pathname that is a directory,
722 : ! -# an asterisk (`*') after each that is executable,
723 : ! -# an at sign (`@') after each symbolic link,
724 : ! -# a percent sign (`%') after each whiteout,
725 : ! -# an equal sign (`=') after each socket,
726 : ! -# avertical bar (`|') after each that is a FIFO.
727 : ! --group-directories-first : group directories before files; can be augmented with a `--sort` option, but any use of `--sort=none` (`-U`) disables grouping.
728 : ! -G, --no-group : in a long listing, don't print group names
729 : ! -h, --human-readable : with -l and -s, print sizes like 1K 234M 2G etc.
730 : ! -H : Evaluate the file information and file type for symbolic links specified on the command line to be those of the file referenced by the link, and not the link itself;
731 : ! however, ls shall write the name of the link itself and not the file referenced by the link.
732 : ! -L : Evaluate the file information and file type for all symbolic links (whether named on the command line or encountered in a file hierarchy)
733 : ! to be those of the file referenced by the link, and not the link itself; however, ls shall write the name of the link itself and not the file referenced by the link.
734 : ! When -L is used with -l, write the contents of symbolic links in the long format (see the STDOUT section).
735 : ! -k, --kibibytes : default to 1024-byte blocks for disk usage; used only with `-s` and per directory totals.
736 : ! -m : fill width with a comma separated list of entries.
737 : ! -p, --indicator-style=slash : append / indicator to directories.
738 : ! -Q, --quote-name : enclose entry names in double quotes.
739 : ! --quoting-style=WORD : use quoting style WORD for entry names: `literal`, `locale`, `shell`, `shell-always`, `shell-escape`, `shell-escape-always`, `c`, `escape` (overrides QUOTING_STYLE environment variable).
740 : ! -r, --reverse : reverse order while sorting.
741 : ! -S : sort by file size, largest first.
742 : ! --sort=WORD : sort by WORD instead of name: none (-U), size (-S), time (-t), version (-v), extension (-X).
743 : ! -X : sort alphabetically by entry extension.
744 : ! -t : sort by time, newest first.
745 : ! -1 : list one file per line. Avoid '\n' with -q or -b.
746 : ! -u : Use time of last access instead of last modification of the file for sorting (-t) or writing (-l).
747 : !
748 : ! \see
749 : ! https://pubs.opengroup.org/onlinepubs/9699919799/utilities/ls.html
750 : !
751 : ! \warning
752 : ! Grouping directories first in the command below is crucial for the proper functioning
753 : ! of the rest of the code below (when either `showdir` or `showfile` is `.false.`).
754 268 : command = SKC_"ls --group-directories-first -bpG"
755 268 : if (showhidden_def) command = command//SKC_"A"
756 268 : if (present(sort)) then
757 0 : if (sort /= SK_"name") then
758 0 : if (reversed_def) command = command//SKC_"r"
759 0 : elseif (sort == SK_"tmod") then
760 0 : if (reversed_def) then
761 0 : command = command//SKC_"t"
762 : else
763 0 : command = command//SKC_"tr"
764 : end if
765 0 : elseif (sort == SK_"tacc") then
766 0 : if (reversed_def) then
767 0 : command = command//SKC_"u"
768 : else
769 0 : command = command//SKC_"ur"
770 : end if
771 0 : elseif (sort == SK_"size") then
772 0 : if (reversed_def) then
773 0 : command = command//SKC_"S"
774 : else
775 0 : command = command//SKC_"Sr"
776 : end if
777 0 : elseif (sort == SK_"fext") then
778 0 : if (reversed_def) then
779 0 : command = command//SKC_"Xr"
780 : else
781 0 : command = command//SKC_"X"
782 : end if
783 : else
784 0 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": Unrecognized value for the `sort` input argument: "//sort
785 0 : failed = .true._LK
786 0 : return
787 : end if
788 : else
789 268 : if (reversed_def) command = command//SKC_" -r"
790 : end if
791 :
792 : ! Fetch the list.
793 268 : failed = isFailedGetOutput(command//SKC_" "//getPathVerbatimPosix(path), list, errmsg_def, exitstat = exitstat)
794 268 : if (failed) then
795 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg_def) ! LCOV_EXCL_LINE
796 : return ! LCOV_EXCL_LINE
797 268 : elseif (exitstat /= 0_IK) then
798 176 : index = reshape([integer(IK) ::], [0,0])
799 176 : list = SKC_""
800 176 : return
801 : end if
802 : #define UNESCAPE_REINDEX_LIST call setAsciiFromEscaped(list(index(1, i) : index(2, i)), endloc); index(2, i) = index(1, i) + endloc - 1_IK;
803 92 : call setSplit(index, list, NLC)
804 92 : lenList = size(index, 2, IK)
805 : ! Unescape the C-style escape sequences.
806 92 : if (showdir_def .and. showfile_def) then
807 1532 : do i = 1_IK, lenList
808 1532 : UNESCAPE_REINDEX_LIST
809 : !if (list(index(2, i) : index(2, i)) == shell%dirsep) index(2, i) = index(2, i) - 1_IK
810 : end do
811 0 : elseif (showfile_def) then
812 0 : do istart = 1_IK, lenList
813 0 : if (list(index(2, i) : index(2, i)) /= shell%dirsep) exit
814 : end do
815 0 : do i = istart, lenList
816 0 : UNESCAPE_REINDEX_LIST
817 : end do
818 0 : index = index(:, istart : lenList)
819 0 : elseif (showdir_def) then
820 0 : do istart = 1_IK, lenList
821 0 : if (list(index(2, i) : index(2, i)) /= shell%dirsep) exit
822 0 : UNESCAPE_REINDEX_LIST
823 : !if (list(index(2, i) : index(2, i)) == shell%dirsep) index(2, i) = index(2, i) - 1_IK
824 : end do
825 0 : index = index(:, 1 : istart)
826 : else
827 0 : index = reshape([integer(IK) ::], [0,0])
828 0 : list = SKC_""
829 0 : return
830 : end if
831 : #undef UNESCAPE_REINDEX_LIST
832 :
833 0 : elseif (shell%is%windows .and. shell%is%cmd) then
834 :
835 : ! see: https://www.computerhope.com/dirhlp.htm
836 : ! /p Displays one screen of the listing at a time. To see the next screen, press any key.
837 : ! /q Displays file ownership information.
838 : ! /w Displays the listing in wide format, with as many as five file names or directory names on each line.
839 : ! /d Displays the listing in the same format as /w, but the files are sorted by column.
840 : ! /a[[:]<attributes>] Displays only the names of those directories and files with your specified attributes. If you don't use this parameter, the command displays the names of all files except hidden and system files. If you use this parameter without specifying any attributes, the command displays the names of all files, including hidden and system files. The list of possible attributes values are:
841 : ! d - Directories
842 : ! h - Hidden files
843 : ! s - System files
844 : ! l - Reparse points
845 : ! r - Read-only files
846 : ! a - Files ready for archiving
847 : ! i - Not content indexed files
848 : ! You can use any combination of these values, but do not separate your values using spaces.
849 : ! Optionally you can use a colon (:) separator, or you can use a hyphen (-) as a prefix to mean, "not".
850 : ! For example, using the -s attribute will not show the system files.
851 : ! /o[[:]<sortorder>] Sorts the output according to sortorder, which can be any combination of the following values:
852 : ! n - Alphabetically by name
853 : ! e - Alphabetically by extension
854 : ! g - Group directories first
855 : ! s - By size, smallest first
856 : ! d - By date/time, oldest first
857 : ! Use the - prefix to reverse the sort order
858 : ! Multiple values are processed in the order in which you list them. Do not separate multiple values with spaces, but you can optionally use a colon (:).
859 : ! If sortorder is not specified, dir /o lists the directories alphabetically, followed by the files, which are also sorted alphabetically.
860 : ! /t[[:]<timefield>] Specifies which time field to display or to use for sorting. The available timefield values are:
861 : ! c - Creation
862 : ! a - Last accessed
863 : ! w - Last modified
864 : ! /s Lists every occurrence of the specified file name within the specified directory and all subdirectories.
865 : ! /b Displays a bare list of directories and files, with no additional information. The /b parameter overrides /w.
866 : ! /l Displays unsorted directory names and file names, using lowercase.
867 : ! /n Displays a long list format with file names on the far right of the screen.
868 : ! /x Displays the short names generated for non-8dot3 file names. The display is the same as the display for /n, but the short name is inserted before the long name.
869 : ! /c Displays the thousand separator in file sizes. This is the default behavior. Use /-c to hide separators.
870 : ! /4 Displays years in four-digit format.
871 : ! /r Display alternate data streams of the file.
872 : ! /? Displays help at the command prompt.
873 : !
874 : ! \see
875 : ! https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/dir
876 : !
877 0 : command = SKC_"dir /b /o:g"
878 0 : if (showhidden_def) then
879 0 : command = command//SKC_" /a:h"
880 : else
881 0 : command = command//SKC_" /a:-h"
882 : end if
883 0 : if (present(sort)) then
884 0 : if (sort /= SK_"name") then
885 0 : if (reversed_def) then
886 0 : command = command//SKC_" /o:-n"
887 : else
888 0 : command = command//SKC_" /o:n"
889 : end if
890 0 : elseif (sort == SK_"tmod") then
891 0 : if (reversed_def) then
892 0 : command = command//SKC_" /o:-d /t:w"
893 : else
894 0 : command = command//SKC_" /o:d /t:w"
895 : end if
896 0 : elseif (sort == SK_"tacc") then
897 0 : if (reversed_def) then
898 0 : command = command//SKC_" /o:-d /t:a"
899 : else
900 0 : command = command//SKC_" /o:d /t:a"
901 : end if
902 0 : elseif (sort == SK_"size") then
903 0 : if (reversed_def) then
904 0 : command = command//SKC_" /o:-s"
905 : else
906 0 : command = command//SKC_" /o:s"
907 : end if
908 0 : elseif (sort == SK_"fext") then
909 0 : if (reversed_def) then
910 0 : command = command//SKC_" /o:-e"
911 : else
912 0 : command = command//SKC_" /o:e"
913 : end if
914 : else
915 0 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": Unrecognized value for the `sort` input argument: "//sort
916 0 : failed = .true._LK
917 0 : return
918 : end if
919 : else
920 0 : if (reversed_def) then
921 0 : command = command//SKC_" /o:-n"
922 : else
923 0 : command = command//SKC_" /o:n"
924 : end if
925 : end if
926 : !if (len(exclude)>0 ) command = command // " | findstr /v /i " // exclude
927 :
928 0 : if (showdir_def) then
929 0 : if (isFailedGetOutput(command//SKC_" /a:d"//getPathVerbatimCMD(path), dirlist, errmsg_def, exitstat = exitstat)) then
930 : dirIndex = reshape([integer(IK) ::], [0,0]) ! LCOV_EXCL_LINE
931 : dirlist = SKC_"" ! LCOV_EXCL_LINE
932 0 : elseif (exitstat /= 0_IK) then
933 0 : index = reshape([integer(IK) ::], [0,0])
934 0 : list = SKC_""
935 0 : return
936 : else
937 0 : call setSplit(dirIndex, dirlist, NLC)
938 : !do i = 1_IK, size(dirIndex,2,IK) - 1_IK
939 : ! dirIndex(2, i) = dirIndex(2, i) + 1_IK
940 : ! dirlist(dirIndex(2, i) : dirIndex(2, i)) = shell%dirsep
941 : !end do
942 : !dirIndex(2, i) = dirIndex(2, i) + 1_IK
943 : !dirlist = dirlist//shell%dirsep
944 : end if
945 : end if
946 :
947 0 : if (showfile_def) then
948 0 : if (isFailedGetOutput(command//SKC_" /a:-d"//getPathVerbatimCMD(path), filelist, errmsg_def, exitstat = exitstat)) then
949 : fileIndex = reshape([integer(IK) ::], [0,0]) ! LCOV_EXCL_LINE
950 : filelist = SKC_"" ! LCOV_EXCL_LINE
951 0 : elseif (exitstat /= 0_IK) then
952 0 : index = reshape([integer(IK) ::], [0,0])
953 0 : list = SKC_""
954 0 : return
955 : else
956 0 : call setSplit(fileIndex, filelist, NLC)
957 : end if
958 : end if
959 :
960 0 : if (len(dirlist, IK) > 0_IK) then
961 0 : lenList = len(dirlist,IK) + 1_IK + len(filelist,IK) ! 1_IK takes care of the additional backslash for the last folder.
962 : else
963 0 : lenList = len(dirlist,IK) + len(filelist,IK)
964 : end if
965 :
966 0 : allocate(character(lenList,SKC) :: list)
967 0 : allocate(index(2,lenList))
968 0 : do i = 1_IK, size(dirIndex,2,IK)
969 0 : index(1, i) = dirIndex(1, i)
970 0 : index(2, i) = dirIndex(2, i) + 1_IK
971 0 : list(dirIndex(1, i) : dirIndex(2, i)) = dirlist(dirIndex(1, i) : dirIndex(2, i))
972 0 : list(index(2, i) : index(2, i)) = shell%dirsep
973 : end do
974 :
975 0 : istart = index(2, i)
976 0 : do i = 1_IK, size(fileIndex,2,IK)
977 0 : index(1,istart+i) = fileIndex(1, i)
978 0 : index(2,istart+i) = fileIndex(2, i)
979 0 : list(index(1,istart) + fileIndex(1, i) : index(1,istart) + fileIndex(2, i)) = filelist(fileIndex(1, i) : fileIndex(2, i))
980 : end do
981 :
982 0 : elseif (shell%is%windows .and. shell%is%powershell) then
983 :
984 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": PowerShell is currently unsupported." ! LCOV_EXCL_LINE
985 : failed = .true._LK ! LCOV_EXCL_LINE
986 : return ! LCOV_EXCL_LINE
987 :
988 : else
989 :
990 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": Unrecognized runtime shell." ! LCOV_EXCL_LINE
991 : failed = .true._LK ! LCOV_EXCL_LINE
992 : return ! LCOV_EXCL_LINE
993 :
994 : end if
995 :
996 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
997 : #elif isFailedCopy_ENABLED || isFailedMove_ENABLED
998 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
999 :
1000 : character(*,SKC), parameter :: DSP = DIR_SEP_POSIX
1001 : character(*,SKC), parameter :: DSW = DIR_SEP_WINDOWS
1002 : character(*,SKC), parameter :: DSPA = DIR_SEP_POSIX_ALL
1003 : character(*,SKC), parameter :: DSWA = DIR_SEP_WINDOWS_ALL
1004 : character(*,SKC), parameter :: LF = new_line(SKC_"a")
1005 : character(:,SKC), allocatable :: paths
1006 : character(:,SKC), allocatable :: dirname
1007 : character(:,SKC), allocatable :: command
1008 : logical(LK) :: wait_def
1009 : logical(LK) :: forced_def
1010 : integer(IK) :: ntry_def
1011 : integer(IK) :: itry
1012 : type(shellis_type) :: shellis
1013 : #if isFailedMove_ENABLED
1014 : character(*,SKC), parameter :: PROCEDURE_NAME = MODULE_NAME//SK_"@isFailedMove()"
1015 : #elif isFailedCopy_ENABLED
1016 : character(*,SKC), parameter :: PROCEDURE_NAME = MODULE_NAME//SK_"@isFailedCopy()"
1017 : logical(LK) :: recursive_def
1018 20 : if (present(recursive)) then
1019 4 : recursive_def = recursive
1020 : else
1021 : recursive_def = .false._LK
1022 : end if
1023 : #endif
1024 :
1025 : ERROR_STOP_IF(len(DSWA) /= 2, PROCEDURE_NAME//SK_": Internal library error occurred. The condition `len(DSWA) == 2` must hold.")
1026 :
1027 : ! The input source and destination cannnot be empty.
1028 :
1029 35 : failed = logical(from == SKC_"" .or. to == SKC_"", LK)
1030 35 : if (failed) then
1031 0 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": The input path `from` is empty."
1032 0 : return
1033 : end if
1034 :
1035 35 : if (present(forced)) then
1036 4 : forced_def = forced
1037 : else
1038 : forced_def = .false._LK
1039 : end if
1040 :
1041 35 : shellis = shellis_type(failed)
1042 :
1043 : ! Define the copy/move command
1044 :
1045 35 : blockDefineCommand: if (shellis%posix .or. shellis%fish) then
1046 :
1047 : ! Create the destination nested directory if needed.
1048 :
1049 35 : if (isDir(from)) then
1050 : ! `to` must be also a directory. If it does not exist, create it.
1051 13 : if (isFile(to)) then
1052 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": The input destination `to` must be a directory when the source `from` is a directory. to: """//getStr(to)//SK_"""" ! LCOV_EXCL_LINE
1053 : failed = .true._LK ! LCOV_EXCL_LINE
1054 : return ! LCOV_EXCL_LINE
1055 13 : elseif (.not. isDir(to)) then
1056 13 : dirname = getDirName(to, DSPA)
1057 13 : if (.not. isDir(dirname)) then ! it is a nonexistent dirname.
1058 6 : failed = isFailedMakeDir(dirname, errmsg = errmsg)
1059 : if (failed) then; if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg); return; end if ! LCOV_EXCL_LINE
1060 : end if
1061 : end if
1062 : else! `to` may still be a directory. If it is a directory, ensure it exists before copying the file.
1063 22 : if (to(len(to):len(to)) == DSPA) then ! it must be a dir.
1064 6 : if (.not. isDir(to)) then ! it is a nonexistent (potentially nested) dir. Create it.
1065 18 : failed = isFailedMakeDir(to, errmsg = errmsg)
1066 : if (failed) then; if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg); return; end if ! LCOV_EXCL_LINE
1067 : end if
1068 : else ! `to` must be a file. So make sure its (potentially nested) dirname exists.
1069 16 : dirname = getDirName(to, DSPA)
1070 16 : if (.not. isDir(dirname)) then ! it is a nonexistent dirname.
1071 12 : failed = isFailedMakeDir(dirname, errmsg = errmsg)
1072 : if (failed) then; if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg); return; end if ! LCOV_EXCL_LINE
1073 : end if
1074 : end if
1075 : end if
1076 :
1077 : ! quote the paths.
1078 :
1079 35 : if (shellis%powershell) then
1080 0 : paths = getPathVerbatimPowerShell(from)//SKC_" "//getPathVerbatimPowerShell(to)
1081 : else
1082 35 : paths = getPathVerbatimPosix(from)//SKC_" "//getPathVerbatimPosix(to)
1083 : end if
1084 :
1085 : ! copy/move path to destination.
1086 :
1087 : #if isFailedMove_ENABLED
1088 : ! -n, --no-clobber : do not overwrite an existing file.
1089 : ! -f, --force : if an existing destination file cannot be opened, remove it and try again (this option is ignored when the -n option is also used).
1090 15 : if (forced_def) then
1091 0 : command = SKC_"mv -f "//paths
1092 : else
1093 15 : command = SKC_"mv -n "//paths
1094 : end if
1095 : #elif isFailedCopy_ENABLED
1096 : ! -a, --archive : same as -dR --preserve=all.
1097 : ! -d : same as --no-dereference --preserve=links
1098 : ! -f, --force : if an existing destination file cannot be opened, remove it and try again (this option is ignored when the -n option is also used).
1099 : ! -n, --no-clobber : do not overwrite an existing file.
1100 : ! -R, -r, --recursive : copy directories recursively.
1101 20 : if (forced_def .and. recursive_def) then
1102 0 : command = SKC_"cp -arf "//paths
1103 20 : elseif (recursive_def) then
1104 4 : command = SKC_"cp -arn "//paths
1105 16 : elseif (forced_def) then
1106 4 : command = SKC_"cp -f "//paths
1107 : else
1108 12 : command = SKC_"cp "//paths
1109 : end if
1110 : #endif
1111 :
1112 0 : elseif (shellis%windows) then blockDefineCommand ! either CMD or PowerShell: robocopy automatically generates new directories if needed.
1113 :
1114 : ! LCOV_EXCL_START
1115 : if (isDir(from)) then ! use robocopy.
1116 :
1117 : ! To get the linux `cp` behavior on Windows when `to` is an existing directory, we should create a new directory in `to` with the basename of `from`.
1118 : if (isDir(to)) then
1119 : paths = getPathVerbatimCMD(from)//SKC_" "//getPathVerbatimCMD(to//DSW//getBaseName(from, DSWA))
1120 : else
1121 : paths = getPathVerbatimCMD(from)//SKC_" "//getPathVerbatimCMD(to)
1122 : end if
1123 :
1124 : ! Robocopy flags:
1125 : ! /e : Copies subdirectories. This option automatically includes empty directories.
1126 : ! /r:<n> : Specifies the number of retries on failed copies. The default value of n is 1,000,000 (one million retries).
1127 : ! /w:<n> : Specifies the wait time between retries, in seconds. The default value of n is 30 (wait time 30 seconds).
1128 : ! /xc : Excludes changed files.
1129 : ! /xn : Excludes newer files.
1130 : ! /xo : Excludes older files.
1131 : ! /xc /xn /xo : Does not overwrite existing files.
1132 : ! /is : Includes the same files. Same files are identical in name, size, times, and all attributes.
1133 : ! /move : Moves files and directories, and deletes them from the source after they are copied.
1134 : #if isFailedMove_ENABLED
1135 : if (forced_def) then
1136 : command = SKC_"robocopy "//paths//SKC_" /r:1 /w:1 /move /is /e"//SKC_" > nul"
1137 : else
1138 : command = SKC_"robocopy "//paths//SKC_" /r:1 /w:1 /move /xc /xn /xo /e"//SKC_" > nul"
1139 : end if
1140 : #elif isFailedCopy_ENABLED
1141 : if (forced_def .and. recursive_def) then
1142 : command = SKC_"robocopy "//paths//SKC_" /r:1 /w:1 /is /e"//SKC_" > nul"
1143 : elseif (recursive_def) then
1144 : command = SKC_"robocopy "//paths//SKC_" /r:1 /w:1 /xc /xn /xo /e"//SKC_" > nul"
1145 : elseif (forced_def) then
1146 : command = SKC_"robocopy "//paths//SKC_" /r:1 /w:1 /is "//SKC_" > nul"
1147 : else
1148 : command = SKC_"robocopy "//paths//SKC_" /r:1 /w:1 /xc /xn /xo "//SKC_" > nul"
1149 : end if
1150 : #endif
1151 :
1152 : else! `from` must be a file. Use xcopy/move, which can handle files with nested destinations.
1153 :
1154 : if (.not. forced_def) then
1155 : if (isFile(to)) then
1156 : return ! Attempting to overwrite a single existing file. Nothing to do. Return.
1157 : elseif (isDir(to)) then
1158 : if (isFile(to//DSW//getBaseName(from, DSWA))) return ! Attempting to overwrite a single existing file whose directory is `to`. Nothing to do. Return.
1159 : end if
1160 : end if
1161 :
1162 : ! Rest assured; `to` is not an existing file. However, `to` may still be intended as a (potentially non-existing) directory if it ends with a directory separator.
1163 : ! If so, pipe D to xcopy/move indicate it is a directory.
1164 :
1165 : ! copy or xcopy flags:
1166 : ! /e Copies all (even empty) subdirectories.
1167 : ! /q Suppresses the display of xcopy messages.
1168 : ! /y Suppresses prompting to confirm that you want to overwrite an existing destination file (as if `forced = .true.`).
1169 : ! /s Copies directories and subdirectories, unless they are empty. If one omits /s, xcopy works within a single directory.
1170 : ! command = SKC_"xcopy /e /q /s /Y "//getPathVerbatimCMD(from)//SKC_" "//getPathVerbatimCMD(to)//SKC_" > nul"
1171 :
1172 : itry = len(to, IK)
1173 : if (index(DSWA, to(itry:itry), kind = IK) > 0_IK) then ! it must be a dir.
1174 : ! \warning
1175 : ! `xcopy` cannot automatically create (nested) folders that end with a forward slash (no problem with backward slash.
1176 : ! Therefore, a safer and faster way of creating the directory is to let xcopy do it, while ignoring the last character (which is a directory separator).
1177 : ! `echo D` pipes the response `directory` to the question of how to interpret `to` if there is ambiquity (e.g., if `to` does not end with directory separator).
1178 : #if isFailedMove_ENABLED
1179 : ! move can neither realize `to` is a directory (on powershell) nor create a (potentially nested) `to` folder (in either cmd or powershell). So create it.
1180 : failed = isFailedMakeDir(to, errmsg = errmsg)
1181 : if (failed) then; if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg); return; end if ! LCOV_EXCL_LINE
1182 : #elif isFailedCopy_ENABLED
1183 : command = SKC_"echo D | xcopy /q /y "//getPathVerbatimCMD(from)//SKC_" "//getPathVerbatimCMD(to(1:itry-1))//SKC_" > nul"
1184 : else
1185 : ! `to` must be a file. So no problemino.
1186 : ! `echo F` pipes the response `file` to the question of how to interpret `to` if there is ambiquity (e.g., if `to` does not end with directory separator).
1187 : command = SKC_"echo F | xcopy /q /y "//getPathVerbatimCMD(from)//SKC_" "//getPathVerbatimCMD(to)//SKC_" > nul"
1188 : #endif
1189 : end if
1190 :
1191 : #if isFailedMove_ENABLED
1192 : if (shellis%cmd) then
1193 : command = SKC_"move /y "//getPathVerbatimCMD(from)//SKC_" "//getPathVerbatimCMD(to)//SKC_" > nul"
1194 : elseif (shellis%powershell) then
1195 : command = SKC_"move "//getPathVerbatimCMD(from)//SKC_" "//getPathVerbatimCMD(to)//SKC_" -Force > nul"
1196 : end if
1197 : #endif
1198 : end if
1199 : ! LCOV_EXCL_STOP
1200 :
1201 : else blockDefineCommand
1202 :
1203 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": Failed to fetch the runtime shell type."//LF//trim(errmsg) ! LCOV_EXCL_LINE
1204 : failed = .true._LK ! LCOV_EXCL_LINE
1205 : return ! LCOV_EXCL_LINE
1206 :
1207 : end if blockDefineCommand
1208 :
1209 : ! Attempt repeatedly to copy/move the file.
1210 :
1211 35 : if (present(ntry)) then
1212 0 : CHECK_ASSERTION(__LINE__, 0_IK < ntry, PROCEDURE_NAME//SK_": The condition `0 < ntry` must hold. ntry = "//getStr(ntry))
1213 0 : ntry_def = ntry
1214 : else
1215 35 : ntry_def = 1_IK
1216 : end if
1217 :
1218 35 : if (present(wait)) then
1219 0 : wait_def = wait
1220 : else
1221 35 : wait_def = .true._LK
1222 : end if
1223 :
1224 35 : do itry = 1_IK, ntry_def
1225 105 : failed = isFailedExec(command, wait = wait_def, cmdmsg = errmsg)
1226 : !failed = wait_def .and. .not. isExtant(to)
1227 35 : if (.not. failed) exit
1228 : end do
1229 :
1230 35 : if (failed .and. present(errmsg)) errmsg = PROCEDURE_NAME//SK_": Failed to accomplish task file after "//getStr(ntry_def)//SK_" attempts."//LF//trim(errmsg)
1231 :
1232 : ! \warning do NOT remove.
1233 : ! \bug gfortran with heap memory allocations fails to automatically deallocate on exit.
1234 35 : deallocate(command)
1235 :
1236 : !%%%%%%%%%%%%%%%%%%%%%
1237 : #elif isFailedRemove_ENABLED
1238 : !%%%%%%%%%%%%%%%%%%%%%
1239 :
1240 : character(*, SK), parameter :: PROCEDURE_NAME = MODULE_NAME//"@isFailedRemove()"
1241 : character(*,SKC), parameter :: LF = new_line(SKC_"a")
1242 : logical(LK) :: forced_def, recursive_def, wait_def
1243 : character(:,SKC), allocatable :: command, cmdfull
1244 : character(511, SK) :: errmsg_def
1245 : integer(IK) :: i, itry, ntry_def
1246 : integer(IK) :: iostat
1247 :
1248 74 : errmsg_def = ""
1249 74 : failed = .false.
1250 74 : ntry_def = 1_IK
1251 74 : wait_def = .true._LK
1252 : forced_def = .false._LK
1253 : recursive_def = .false._LK
1254 74 : if (present(ntry)) ntry_def = ntry
1255 74 : if (present(wait)) wait_def = wait
1256 74 : if (present(forced)) forced_def = forced
1257 74 : if (present(recursive)) recursive_def = recursive
1258 74 : CHECK_ASSERTION(__LINE__, 0_IK < ntry_def, PROCEDURE_NAME//SK_": The condition `0 < ntry` must hold. ntry = "//getStr(ntry_def))
1259 :
1260 : ! non-existence is okay only if `forced` is `.true.`.
1261 :
1262 74 : if (isFile(path)) then
1263 : fileRemoval: block
1264 : logical(LK) :: opened
1265 : integer(IK) :: unit
1266 54 : inquire(file = path, opened = opened, number = unit, iostat = iostat, iomsg = errmsg_def)
1267 54 : if (iostat /= 0_IK) exit fileRemoval
1268 54 : if (.not. opened) then
1269 54 : open(newunit = unit, file = path, status = "replace", iostat = iostat, iomsg = errmsg_def SHARED)
1270 54 : if (iostat /= 0_IK) exit fileRemoval
1271 : end if
1272 54 : do itry = 1, ntry_def
1273 54 : close(unit, status = "delete", iostat = iostat, iomsg = errmsg_def)
1274 54 : if (iostat /= 0_IK) then
1275 0 : errmsg_def = SK_"The `close(unit,status='delete')` statement failed. "//trim(errmsg_def)
1276 0 : exit fileRemoval
1277 : end if
1278 54 : inquire(file = path, exist = failed, iostat = iostat, iomsg = errmsg_def)
1279 54 : if (iostat /= 0_IK) exit fileRemoval
1280 54 : failed = wait_def .and. failed
1281 54 : if (.not. failed) return
1282 : end do
1283 0 : errmsg_def = SK_": Failed to accomplish task file after "//getStr(ntry_def)//SK_" attempts."
1284 : end block fileRemoval
1285 0 : failed = .true._LK
1286 0 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg_def)
1287 0 : return
1288 : end if
1289 :
1290 : ! Remove possibly a directory or a pattern.
1291 : ! Note that some commands like Windows CMD `rd` do not digest wildcards.
1292 : ! As such a list of paths corresponding to the specified wildcards must be created first.
1293 :
1294 : recursiveRemoval: block
1295 :
1296 : type(shellis_type) :: shellis
1297 20 : type(css_type), allocatable :: list(:), verbatim(:)
1298 :
1299 20 : if (isDir(path)) then
1300 16 : list = [css_type(path)]
1301 : else
1302 16 : failed = isFailedGlob(path, list, errmsg_def)
1303 16 : if (failed) exit recursiveRemoval
1304 16 : if (size(list, 1, IK) == 0_IK) then
1305 8 : failed = .not. forced_def
1306 8 : if (failed) then
1307 4 : errmsg_def = SK_"The specified path does not match any file or directory. Set `forced = .true.` to gracefully ignore non-existing paths."
1308 4 : exit recursiveRemoval
1309 : else
1310 : return
1311 : end if
1312 : end if
1313 : end if
1314 :
1315 : ! Removing non-file paths requires `recursive` option to be `.true.`.
1316 :
1317 12 : if (0_IK < size(list, 1, IK) .and. .not. recursive_def) then
1318 0 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": Removing a directory or a set of paths matching a pattern requires setting the input argument `recursive = .true.`."
1319 0 : failed = .true._LK
1320 0 : return
1321 : end if
1322 :
1323 12 : shellis = shellis_type(failed, errmsg_def)
1324 12 : call setResized(verbatim, size(list, 1, IK))
1325 :
1326 12 : blockDefineCommand: if (shellis%posix .or. shellis%fish) then
1327 :
1328 28 : do i = 1, size(list, 1, IK)
1329 28 : if (shellis%powershell) then
1330 0 : verbatim(i)%val = getPathVerbatimPowerShell(list(i)%val)
1331 : else
1332 16 : verbatim(i)%val = getPathVerbatimPosix(list(i)%val)
1333 : end if
1334 : end do
1335 : ! -f, --force : ignore nonexistent files and arguments, never prompt.
1336 : ! -r, -R, --recursive : remove directories and their contents recursively.
1337 12 : command = SKC_"rm "
1338 12 : if (forced_def) command = command//SKC_"-f "
1339 12 : if (recursive_def) command = command//SKC_"-r "
1340 :
1341 0 : elseif (shellis%windows .and. shellis%cmd) then blockDefineCommand
1342 :
1343 0 : do i = 1, size(list, 1, IK)
1344 0 : verbatim(i)%val = getPathVerbatimCMD(list(i)%val)
1345 : end do
1346 : ! /Q : Quiet mode, do not ask if ok to remove a directory tree with /S.
1347 : ! /S : Removes all directories and files in the specified directory in addition to the directory itself. Used to remove a directory tree.
1348 0 : command = SKC_"rd "
1349 0 : if (forced_def) command = command//SKC_"/Q "
1350 0 : if (recursive_def) command = command//SKC_"/S "
1351 :
1352 0 : elseif (shellis%windows .and. shellis%powershell) then blockDefineCommand
1353 :
1354 0 : do i = 1, size(list, 1, IK)
1355 0 : verbatim(i)%val = getPathVerbatimPowerShell(list(i)%val)
1356 : end do
1357 : ! -Force : Forces the cmdlet to remove items that can't otherwise be changed, such as hidden or read-only files or read-only aliases or variables.
1358 : ! -Recurse : Indicates that this cmdlet deletes the items in the specified locations and in all child items of the locations.
1359 : ! The Recurse parameter might not delete all subfolders or all child items. This is a known issue.
1360 0 : command = SKC_"Remove-Item "
1361 0 : if (forced_def) command = command//SKC_"-Force "
1362 0 : if (recursive_def) command = command//SKC_"-Recurse "
1363 :
1364 : else blockDefineCommand
1365 :
1366 : errmsg_def = SK_": Failed to fetch the runtime shell type."//LF//trim(errmsg) ! LCOV_EXCL_LINE
1367 0 : exit recursiveRemoval
1368 :
1369 : end if blockDefineCommand
1370 :
1371 : ! Remove paths recursively.
1372 :
1373 28 : loopOverPath: do i = 1, size(list, 1, IK)
1374 16 : cmdfull = command//verbatim(i)%val
1375 16 : do itry = 1, ntry_def
1376 16 : failed = isFailedExec(cmdfull, wait = wait_def, cmdmsg = errmsg_def)
1377 16 : inquire(file = list(i)%val, exist = failed, iostat = iostat, iomsg = errmsg_def)
1378 16 : if (iostat /= 0_IK) exit recursiveRemoval
1379 16 : failed = wait_def .and. failed
1380 16 : if (.not. failed) cycle loopOverPath
1381 : end do
1382 0 : errmsg_def = SK_": Failed to accomplish remove path '"//list(i)%val//SK_"' after "//getStr(ntry_def)//SK_" attempts."
1383 28 : exit recursiveRemoval
1384 : end do loopOverPath
1385 :
1386 52 : return
1387 :
1388 : end block recursiveRemoval
1389 :
1390 4 : if (present(errmsg)) errmsg = PROCEDURE_NAME//SK_": "//trim(errmsg_def)
1391 : failed = .true._LK
1392 :
1393 : !%%%%%%%%%%%%%%%%%%%
1394 : #elif getPathMatch_ENABLED
1395 : !%%%%%%%%%%%%%%%%%%%
1396 :
1397 : use pm_err, only: getFine
1398 : integer(IK) :: lenList
1399 : logical(LK) :: failed_def
1400 : character(:,SKC), allocatable :: key_def, inc_def, sep_def, paths
1401 32 : if (present(failed)) failed = .false._LK
1402 32 : if (present(key)) then
1403 28 : key_def = key
1404 : else
1405 4 : key_def = ""
1406 : endif
1407 32 : if (present(inc)) then
1408 8 : inc_def = inc
1409 : else
1410 24 : inc_def = ""
1411 : endif
1412 32 : if (present(sep)) then
1413 20 : sep_def = sep
1414 : else
1415 36 : sep_def = getPathSep(failed = failed_def, errmsg = errmsg)
1416 12 : if (failed_def) then
1417 0 : if (present(failed)) then
1418 0 : if (present(errmsg)) errmsg = getFine(__FILE__, __LINE__)//MODULE_NAME//"@getPathMatch(): Failed to infer the path separator character. "//trim(errmsg)
1419 0 : call setResized(list, 0_IK)
1420 0 : failed = failed_def
1421 0 : return
1422 : else
1423 0 : error stop getFine(__FILE__, __LINE__)//MODULE_NAME//"@getPathMatch(): Failed to infer the path separator character. "//trim(errmsg)
1424 : end if
1425 : end if
1426 : endif
1427 32 : lenList = 4095_IK
1428 0 : do
1429 131072 : paths = repeat(" ", lenList)
1430 32 : call setPathMatch(key_def, inc_def, sep_def, paths, lenList)
1431 32 : if (len(paths, IK) < abs(lenList)) then
1432 0 : lenList = abs(lenList)
1433 : cycle
1434 32 : elseif (0_IK <= lenList) then
1435 32 : call setSplit(list, paths(1 : lenList), sep_def)
1436 : exit
1437 0 : elseif (present(failed)) then
1438 0 : if (present(errmsg)) errmsg = getFine(__FILE__, __LINE__)//MODULE_NAME//"@getPathMatch(): Failed to detect paths. "//trim(errmsg)
1439 0 : call setResized(list, 0_IK)
1440 0 : failed = .true._LK
1441 0 : return
1442 : else
1443 0 : error stop getFine(__FILE__, __LINE__)//MODULE_NAME//"@getPathMatch(): Failed to infer the path separator character. "//trim(errmsg)
1444 : end if
1445 : end do
1446 :
1447 : !%%%%%%%%%%%%%%%%%%%
1448 : #elif setPathMatch_ENABLED
1449 : !%%%%%%%%%%%%%%%%%%%
1450 :
1451 : integer(IK) :: ipath, lenkey, leninc, item, lenout, lenListInput, istart
1452 : logical(LK) :: isall, found, failed
1453 : character(255,SKC) :: errmsg
1454 : character(1,SKC) :: pathsep
1455 : !integer(IK), allocatable :: cindex(:,:)
1456 : !integer(IK), allocatable :: kindex(:,:)
1457 44 : type(css_type), allocatable :: csskey(:)
1458 44 : type(css_type), allocatable :: inclist(:)
1459 44 : type(css_type), allocatable :: csspath(:)
1460 44 : character(:,SKC), allocatable :: contents, lower, inclow
1461 44 : CHECK_ASSERTION(__LINE__, 0_IK < lenList, SK_"@setPathMatch(): The condition `0 < lenList` must hold. lenList = "//getStr(lenList))
1462 44 : CHECK_ASSERTION(__LINE__, 0_IK < len_trim(sep), SK_"@setPathMatch(): The condition `0 < len_trim(sep)` must hold. len_trim(sep) = "//getStr(len_trim(sep)))
1463 44 : lenListInput = lenList ! Keep a copy of the input value.
1464 44 : errmsg = ""
1465 :
1466 : ! First search the PATH env variable.
1467 :
1468 : success: block
1469 44 : failed = isFailedGetEnvVar("PATH", contents, errmsg)
1470 44 : if (failed) exit success
1471 44 : pathsep = getPathSep(failed, errmsg)
1472 44 : if (.not. failed) then
1473 : #if FORTRAN_ENABLED
1474 44 : leninc = len(inc, IK)
1475 44 : lenkey = len(key, IK)
1476 : #else
1477 : lenkey = 1_IK
1478 : do
1479 : if (key(lenkey : lenkey) == c_null_char) exit
1480 : lenkey = lenkey + 1_IK
1481 : end do
1482 : lenkey = lenkey - 1_IK
1483 : leninc = 1_IK
1484 : do
1485 : if (inc(leninc : leninc) == c_null_char) exit
1486 : leninc = leninc + 1_IK
1487 : end do
1488 : leninc = leninc - 1_IK
1489 : #endif
1490 44 : lenList = 0_IK
1491 44 : if (0_IK < leninc) inclow = getStrLower(inc(1 : leninc))
1492 44 : call setSplit(csskey, getStrLower(key(1 : lenkey)), sep)
1493 44 : isall = 0_IK == size(csskey, 1, IK)
1494 44 : if (.not. isall) then
1495 44 : call setSplit(csspath, contents, pathsep)
1496 44 : isall = 0_IK == size(csspath, 1, IK)
1497 2728 : do ipath = 1, size(csspath, 1, IK)
1498 2684 : lower = getStrLower(csspath(ipath)%val)
1499 : found = .true._LK
1500 4692 : do item = 1, size(csskey, 1, IK)
1501 3496 : found = 0 < index(lower, csskey(item)%val)
1502 4692 : if (.not. found) exit
1503 : end do
1504 2728 : if (found) then
1505 : ! Add the path only if the `inc` is also present.
1506 1196 : found = 0_IK == leninc
1507 1196 : if (.not. found) then
1508 1096 : failed = isFailedList(csspath(ipath)%val, inclist, errmsg = errmsg)
1509 232 : if (failed) exit success
1510 1072 : do item = 1, size(inclist, 1, IK)
1511 856 : found = 0 < index(getStrLower(inclist(item)%val), inclow)
1512 1072 : if (found) exit
1513 : end do
1514 : end if
1515 1196 : if (found) then
1516 : ! Add the separator.
1517 980 : if (0_IK < lenList) then
1518 948 : if (lenList + 1 <= lenListInput) list(lenList + 1 : lenList + 1) = sep
1519 948 : lenList = lenList + 1_IK
1520 : end if
1521 : ! Add the path.
1522 980 : if (lenList + len(lower, IK) <= lenListInput) list(lenList + 1 : lenList + len(lower, IK)) = csspath(ipath)%val
1523 980 : lenList = lenList + len(lower, IK)
1524 : end if
1525 : end if
1526 : end do
1527 : end if
1528 44 : if (isall) then
1529 0 : call setReplaced(contents, pathsep, sep)
1530 0 : lenout = len_trim(contents)
1531 0 : lenList = min(lenout, lenListInput)
1532 0 : list(1 : lenList) = contents(1 : lenList)
1533 0 : lenList = merge(lenout, lenList, lenListInput < lenout)
1534 : end if
1535 : end if
1536 :
1537 44 : if (isDarwin()) then
1538 0 : failed = isFailedGetOutput(SK_"system_profiler SPApplicationsDataType", contents, errmsg)!, exitstat = exitstat)
1539 0 : if (failed) exit success
1540 : ! The following is the typical output of the command:
1541 : !
1542 : ! MATLAB_R2019a:
1543 : !
1544 : ! Version: R2019a (9.6.0)
1545 : ! Obtained from: Unknown
1546 : ! Last Modified: 6/18/21, 2:15 AM
1547 : ! Location: /Applications/MATLAB_R2019a.inc
1548 : ! Kind: 64-bit
1549 : !
1550 : ! We search for all instances of lines matching "Location: " and the input keys.
1551 0 : call setSplit(csspath, contents, new_line(SKC_""))
1552 0 : do ipath = 1, size(csspath, 1, IK)
1553 0 : istart = index(csspath(ipath)%val, SK_"Location: ", kind = IK)
1554 0 : if (0 < istart) then
1555 0 : istart = istart + 10_IK
1556 0 : lower = getStrLower(csspath(ipath)%val(istart :))
1557 : found = .true._LK
1558 0 : do item = 1, size(csskey, 1, IK)
1559 0 : found = 0 < index(lower, csskey(item)%val)
1560 0 : if (.not. found) exit
1561 : end do
1562 0 : if (found) then
1563 : ! Add the path only if the `inc` is also present.
1564 0 : found = 0_IK == leninc
1565 0 : if (.not. found) then
1566 0 : failed = isFailedList(csspath(ipath)%val(istart :), inclist, errmsg = errmsg)
1567 0 : if (failed) exit success
1568 0 : do item = 1, size(inclist, 1, IK)
1569 0 : found = 0 < index(getStrLower(inclist(item)%val), inclow)
1570 0 : if (found) exit
1571 : end do
1572 : end if
1573 0 : if (found) then
1574 : ! Add the separator.
1575 0 : if (0_IK < lenList) then
1576 0 : if (lenList + 1 <= lenListInput) list(lenList + 1 : lenList + 1) = sep
1577 0 : lenList = lenList + 1_IK
1578 : end if
1579 : ! Add the path.
1580 0 : if (lenList + len(lower, IK) <= lenListInput) list(lenList + 1 : lenList + len(lower, IK)) = csspath(ipath)%val(istart :)
1581 0 : lenList = lenList + len(lower, IK)
1582 : end if
1583 : end if
1584 : end if
1585 : end do
1586 : end if
1587 :
1588 : end block success
1589 :
1590 : !if (isWindows() .or. isLinux()) then
1591 44 : if (failed) then
1592 0 : lenout = len_trim(errmsg)
1593 0 : lenList = min(lenout, lenListInput)
1594 0 : list(1 : lenList) = errmsg(1 : lenList)
1595 0 : list(lenList + 1 : lenListInput) = ""
1596 0 : lenList = -merge(lenout, lenList, lenListInput < lenout)
1597 : end if
1598 : #else
1599 : !%%%%%%%%%%%%%%%%%%%%%%%%
1600 : #error "Unrecognized interface."
1601 : !%%%%%%%%%%%%%%%%%%%%%%%%
1602 : #endif
1603 : #undef SHARED
|
