-
Notifications
You must be signed in to change notification settings - Fork 97
/
fpm_filesystem.F90
1258 lines (1039 loc) · 36.6 KB
/
fpm_filesystem.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
!> This module contains general routines for interacting with the file system
!!
module fpm_filesystem
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
use,intrinsic :: iso_c_binding, only: c_new_line
use fpm_environment, only: get_os_type, &
OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
use fpm_environment, only: separator, get_env, os_is_unix
use fpm_strings, only: f_string, replace, string_t, split, split_first_last, dilate, str_begins_with_str
use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer
use fpm_error, only : fpm_stop, error_t, fatal_error
implicit none
private
public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, get_local_prefix, &
mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, fileopen, fileclose, &
filewrite, warnwrite, parent_dir, is_hidden_file, read_lines, read_lines_expanded, which, run, &
os_delete_dir, is_absolute_path, get_home, execute_and_read_output, get_dos_path
#ifndef FPM_BOOTSTRAP
interface
function c_opendir(dir) result(r) bind(c, name="c_opendir")
import c_char, c_ptr
character(kind=c_char), intent(in) :: dir(*)
type(c_ptr) :: r
end function c_opendir
function c_readdir(dir) result(r) bind(c, name="c_readdir")
import c_ptr
type(c_ptr), intent(in), value :: dir
type(c_ptr) :: r
end function c_readdir
function c_closedir(dir) result(r) bind(c, name="closedir")
import c_ptr, c_int
type(c_ptr), intent(in), value :: dir
integer(kind=c_int) :: r
end function c_closedir
function c_get_d_name(dir) result(r) bind(c, name="get_d_name")
import c_ptr
type(c_ptr), intent(in), value :: dir
type(c_ptr) :: r
end function c_get_d_name
function c_is_dir(path) result(r) bind(c, name="c_is_dir")
import c_char, c_int
character(kind=c_char), intent(in) :: path(*)
integer(kind=c_int) :: r
end function c_is_dir
end interface
#endif
character(*), parameter :: eol = new_line('a') !! End of line
contains
!> Extract filename from path with/without suffix
function basename(path,suffix) result (base)
character(*), intent(In) :: path
logical, intent(in), optional :: suffix
character(:), allocatable :: base
character(:), allocatable :: file_parts(:)
logical :: with_suffix
if (.not.present(suffix)) then
with_suffix = .true.
else
with_suffix = suffix
end if
call split(path,file_parts,delimiters='\/')
if(size(file_parts)>0)then
base = trim(file_parts(size(file_parts)))
else
base = ''
endif
if(.not.with_suffix)then
call split(base,file_parts,delimiters='.')
if(size(file_parts)>=2)then
base = trim(file_parts(size(file_parts)-1))
endif
endif
end function basename
!> Canonicalize path for comparison
!! * Handles path string redundancies
!! * Does not test existence of path
!!
!! To be replaced by realpath/_fullname in stdlib_os
!!
!! FIXME: Lot's of ugly hacks following here
function canon_path(path)
character(len=*), intent(in) :: path
character(len=:), allocatable :: canon_path
character(len=:), allocatable :: nixpath
integer :: istart, iend, nn, last
logical :: is_path, absolute
nixpath = unix_path(path)
istart = 0
nn = 0
iend = 0
absolute = nixpath(1:1) == "/"
if (absolute) then
canon_path = "/"
else
canon_path = ""
end if
do while(iend < len(nixpath))
call next(nixpath, istart, iend, is_path)
if (is_path) then
select case(nixpath(istart:iend))
case(".", "") ! always drop empty paths
case("..")
if (nn > 0) then
last = scan(canon_path(:len(canon_path)-1), "/", back=.true.)
canon_path = canon_path(:last)
nn = nn - 1
else
if (.not. absolute) then
canon_path = canon_path // nixpath(istart:iend) // "/"
end if
end if
case default
nn = nn + 1
canon_path = canon_path // nixpath(istart:iend) // "/"
end select
end if
end do
if (len(canon_path) == 0) canon_path = "."
if (len(canon_path) > 1 .and. canon_path(len(canon_path):) == "/") then
canon_path = canon_path(:len(canon_path)-1)
end if
contains
subroutine next(string, istart, iend, is_path)
character(len=*), intent(in) :: string
integer, intent(inout) :: istart
integer, intent(inout) :: iend
logical, intent(inout) :: is_path
integer :: ii, nn
character :: tok
nn = len(string)
if (iend >= nn) then
istart = nn
iend = nn
return
end if
ii = min(iend + 1, nn)
tok = string(ii:ii)
is_path = tok /= '/'
if (.not.is_path) then
is_path = .false.
istart = ii
iend = ii
return
end if
istart = ii
do ii = min(iend + 1, nn), nn
tok = string(ii:ii)
select case(tok)
case('/')
exit
case default
iend = ii
cycle
end select
end do
end subroutine next
end function canon_path
!> Extract dirname from path
function dirname(path) result (dir)
character(*), intent(in) :: path
character(:), allocatable :: dir
dir = path(1:scan(path,'/\',back=.true.))
end function dirname
!> Extract dirname from path
function parent_dir(path) result (dir)
character(*), intent(in) :: path
character(:), allocatable :: dir
dir = path(1:scan(path,'/\',back=.true.)-1)
end function parent_dir
!> test if a name matches an existing directory path
logical function is_dir(dir)
character(*), intent(in) :: dir
integer :: stat
select case (get_os_type())
case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
call run( "test -d " // dir , &
& exitstat=stat,echo=.false.,verbose=.false.)
case (OS_WINDOWS)
call run('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', &
& exitstat=stat,echo=.false.,verbose=.false.)
end select
is_dir = (stat == 0)
end function is_dir
!> test if a file is hidden
logical function is_hidden_file(file_basename) result(r)
character(*), intent(in) :: file_basename
if (len(file_basename) <= 2) then
r = .false.
else
r = str_begins_with_str(file_basename, '.')
end if
end function is_hidden_file
!> Construct path by joining strings with os file separator
function join_path(a1,a2,a3,a4,a5) result(path)
character(len=*), intent(in) :: a1, a2
character(len=*), intent(in), optional :: a3, a4, a5
character(len=:), allocatable :: path
character(len=1) :: filesep
logical, save :: has_cache = .false.
character(len=1), save :: cache = '/'
!$omp threadprivate(has_cache, cache)
if (has_cache) then
filesep = cache
else
select case (get_os_type())
case default
filesep = '/'
case (OS_WINDOWS)
filesep = '\'
end select
cache = filesep
has_cache = .true.
end if
if (a1 == "") then
path = a2
else
path = a1 // filesep // a2
end if
if (present(a3)) then
path = path // filesep // a3
else
return
end if
if (present(a4)) then
path = path // filesep // a4
else
return
end if
if (present(a5)) then
path = path // filesep // a5
else
return
end if
end function join_path
!> Determine number or rows in a file given a LUN
integer function number_of_rows(s) result(nrows)
integer,intent(in)::s
integer :: ios
rewind(s)
nrows = 0
do
read(s, *, iostat=ios)
if (ios /= 0) exit
nrows = nrows + 1
end do
rewind(s)
end function number_of_rows
!> read lines into an array of TYPE(STRING_T) variables expanding tabs
function read_lines_expanded(filename) result(lines)
character(len=*), intent(in) :: filename
type(string_t), allocatable :: lines(:)
integer :: i
character(len=:), allocatable :: content
integer, allocatable :: first(:), last(:)
content = read_text_file(filename)
if (len(content) == 0) then
allocate (lines(0))
return
end if
call split_first_last(content, eol, first, last) ! TODO: \r (< macOS X), \n (>=macOS X/Linux/Unix), \r\n (Windows)
! allocate lines from file content string
allocate (lines(size(first)))
do i = 1, size(first)
allocate(lines(i)%s, source=dilate(content(first(i):last(i))))
end do
end function read_lines_expanded
!> read lines into an array of TYPE(STRING_T) variables
function read_lines(filename) result(lines)
character(len=*), intent(in) :: filename
type(string_t), allocatable :: lines(:)
integer :: i
character(len=:), allocatable :: content
integer, allocatable :: first(:), last(:)
content = read_text_file(filename)
if (len(content) == 0) then
allocate (lines(0))
return
end if
call split_first_last(content, eol, first, last) ! TODO: \r (< macOS X), \n (>=macOS X/Linux/Unix), \r\n (Windows)
! allocate lines from file content string
allocate (lines(size(first)))
do i = 1, size(first)
allocate(lines(i)%s, source=content(first(i):last(i)))
end do
end function read_lines
!> read text file into a string
function read_text_file(filename) result(string)
character(len=*), intent(in) :: filename
character(len=:), allocatable :: string
integer :: fh, length
open (newunit=fh, file=filename, status='old', action='read', &
access='stream', form='unformatted')
inquire (fh, size=length)
allocate (character(len=length) :: string)
if (length == 0) return
read (fh) string
close (fh)
end function read_text_file
!> Create a directory. Create subdirectories as needed
subroutine mkdir(dir, echo)
character(len=*), intent(in) :: dir
logical, intent(in), optional :: echo
integer :: stat
if (is_dir(dir)) return
select case (get_os_type())
case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
call run('mkdir -p ' // dir, exitstat=stat,echo=echo,verbose=.false.)
case (OS_WINDOWS)
call run("mkdir " // windows_path(dir), &
& echo=echo, exitstat=stat,verbose=.false.)
end select
if (stat /= 0) then
call fpm_stop(1, '*mkdir*:directory creation failed')
end if
end subroutine mkdir
#ifndef FPM_BOOTSTRAP
!> Get file & directory names in directory `dir` using iso_c_binding.
!!
!! - File/directory names return are relative to cwd, ie. preprended with `dir`
!! - Includes files starting with `.` except current directory and parent directory
!!
recursive subroutine list_files(dir, files, recurse)
character(len=*), intent(in) :: dir
type(string_t), allocatable, intent(out) :: files(:)
logical, intent(in), optional :: recurse
integer :: i
type(string_t), allocatable :: dir_files(:)
type(string_t), allocatable :: sub_dir_files(:)
type(c_ptr) :: dir_handle
type(c_ptr) :: dir_entry_c
character(len=:,kind=c_char), allocatable :: fortran_name
character(len=:), allocatable :: string_fortran
integer, parameter :: N_MAX = 256
type(string_t) :: files_tmp(N_MAX)
integer(kind=c_int) :: r
if (c_is_dir(dir(1:len_trim(dir))//c_null_char) == 0) then
allocate (files(0))
return
end if
dir_handle = c_opendir(dir(1:len_trim(dir))//c_null_char)
if (.not. c_associated(dir_handle)) then
print *, 'c_opendir() failed'
error stop
end if
i = 0
allocate(files(0))
do
dir_entry_c = c_readdir(dir_handle)
if (.not. c_associated(dir_entry_c)) then
exit
else
string_fortran = f_string(c_get_d_name(dir_entry_c))
if ((string_fortran == '.' .or. string_fortran == '..')) then
cycle
end if
i = i + 1
if (i > N_MAX) then
files = [files, files_tmp]
i = 1
end if
files_tmp(i)%s = join_path(dir, string_fortran)
end if
end do
r = c_closedir(dir_handle)
if (r /= 0) then
print *, 'c_closedir() failed'
error stop
end if
if (i > 0) then
files = [files, files_tmp(1:i)]
end if
if (present(recurse)) then
if (recurse) then
allocate(sub_dir_files(0))
do i=1,size(files)
if (c_is_dir(files(i)%s//c_null_char) /= 0) then
call list_files(files(i)%s, dir_files, recurse=.true.)
sub_dir_files = [sub_dir_files, dir_files]
end if
end do
files = [files, sub_dir_files]
end if
end if
end subroutine list_files
#else
!> Get file & directory names in directory `dir`.
!!
!! - File/directory names return are relative to cwd, ie. preprended with `dir`
!! - Includes files starting with `.` except current directory and parent directory
!!
recursive subroutine list_files(dir, files, recurse)
character(len=*), intent(in) :: dir
type(string_t), allocatable, intent(out) :: files(:)
logical, intent(in), optional :: recurse
integer :: stat, fh, i
character(:), allocatable :: temp_file
type(string_t), allocatable :: dir_files(:)
type(string_t), allocatable :: sub_dir_files(:)
if (.not. is_dir(dir)) then
allocate (files(0))
return
end if
allocate (temp_file, source=get_temp_filename())
select case (get_os_type())
case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
call run('ls -A ' // dir , &
& redirect=temp_file, exitstat=stat,echo=.false.,verbose=.false.)
case (OS_WINDOWS)
call run('dir /b ' // windows_path(dir), &
& redirect=temp_file, exitstat=stat,echo=.false.,verbose=.false.)
end select
if (stat /= 0) then
call fpm_stop(2,'*list_files*:directory listing failed')
end if
files = read_lines(temp_file)
call delete_file(temp_file)
do i=1,size(files)
files(i)%s = join_path(dir,files(i)%s)
end do
if (present(recurse)) then
if (recurse) then
allocate(sub_dir_files(0))
do i=1,size(files)
if (is_dir(files(i)%s)) then
call list_files(files(i)%s, dir_files, recurse=.true.)
sub_dir_files = [sub_dir_files, dir_files]
end if
end do
files = [files, sub_dir_files]
end if
end if
end subroutine list_files
#endif
!> test if pathname already exists
logical function exists(filename) result(r)
character(len=*), intent(in) :: filename
inquire(file=filename, exist=r)
!> Directories are not files for the Intel compilers. If so, also use this compiler-dependent extension
#if defined(__INTEL_COMPILER)
if (.not.r) inquire(directory=filename, exist=r)
#endif
end function
!> Get a unused temporary filename
!! Calls posix 'tempnam' - not recommended, but
!! we have no security concerns for this application
!! and use here is temporary.
!! Works with MinGW
function get_temp_filename() result(tempfile)
!
use iso_c_binding, only: c_ptr, C_NULL_PTR, c_f_pointer
integer, parameter :: MAX_FILENAME_LENGTH = 32768
character(:), allocatable :: tempfile
type(c_ptr) :: c_tempfile_ptr
character(len=1), pointer :: c_tempfile(:)
interface
function c_tempnam(dir,pfx) result(tmp) bind(c,name="tempnam")
import
type(c_ptr), intent(in), value :: dir
type(c_ptr), intent(in), value :: pfx
type(c_ptr) :: tmp
end function c_tempnam
subroutine c_free(ptr) BIND(C,name="free")
import
type(c_ptr), value :: ptr
end subroutine c_free
end interface
c_tempfile_ptr = c_tempnam(C_NULL_PTR, C_NULL_PTR)
call c_f_pointer(c_tempfile_ptr,c_tempfile,[MAX_FILENAME_LENGTH])
tempfile = f_string(c_tempfile)
call c_free(c_tempfile_ptr)
end function get_temp_filename
!> Replace file system separators for windows
function windows_path(path) result(winpath)
character(*), intent(in) :: path
character(:), allocatable :: winpath
integer :: idx
winpath = path
idx = index(winpath,'/')
do while(idx > 0)
winpath(idx:idx) = '\'
idx = index(winpath,'/')
end do
end function windows_path
!> Replace file system separators for unix
function unix_path(path) result(nixpath)
character(*), intent(in) :: path
character(:), allocatable :: nixpath
integer :: idx
nixpath = path
idx = index(nixpath,'\')
do while(idx > 0)
nixpath(idx:idx) = '/'
idx = index(nixpath,'\')
end do
end function unix_path
!>AUTHOR: fpm(1) contributors
!!LICENSE: MIT
!>
!!##NAME
!! getline(3f) - [M_io:READ] read a line of arbintrary length from specified
!! LUN into allocatable string (up to system line length limit)
!! (LICENSE:PD)
!!
!!##SYNTAX
!! subroutine getline(unit,line,iostat,iomsg)
!!
!! integer,intent(in) :: unit
!! character(len=:),allocatable,intent(out) :: line
!! integer,intent(out) :: iostat
!! character(len=:), allocatable, optional :: iomsg
!!
!!##DESCRIPTION
!! Read a line of any length up to programming environment maximum
!! line length. Requires Fortran 2003+.
!!
!! It is primarily expected to be used when reading input which will
!! then be parsed or echoed.
!!
!! The input file must have a PAD attribute of YES for the function
!! to work properly, which is typically true.
!!
!! The simple use of a loop that repeatedly re-allocates a character
!! variable in addition to reading the input file one buffer at a
!! time could (depending on the programming environment used) be
!! inefficient, as it could reallocate and allocate memory used for
!! the output string with each buffer read.
!!
!!##OPTIONS
!! LINE The line read when IOSTAT returns as zero.
!! LUN LUN (Fortran logical I/O unit) number of file open and ready
!! to read.
!! IOSTAT status returned by READ(IOSTAT=IOS). If not zero, an error
!! occurred or an end-of-file or end-of-record was encountered.
!! IOMSG error message returned by system when IOSTAT is not zero.
!!
!!##EXAMPLE
!!
!! Sample program:
!!
!! program demo_getline
!! use,intrinsic :: iso_fortran_env, only : stdin=>input_unit
!! use,intrinsic :: iso_fortran_env, only : iostat_end
!! use FPM_filesystem, only : getline
!! implicit none
!! integer :: iostat
!! character(len=:),allocatable :: line, iomsg
!! open(unit=stdin,pad='yes')
!! INFINITE: do
!! call getline(stdin,line,iostat,iomsg)
!! if(iostat /= 0) exit INFINITE
!! write(*,'(a)')'['//line//']'
!! enddo INFINITE
!! if(iostat /= iostat_end)then
!! write(*,*)'error reading input:',iomsg
!! endif
!! end program demo_getline
!!
subroutine getline(unit, line, iostat, iomsg)
!> Formatted IO unit
integer, intent(in) :: unit
!> Line to read
character(len=:), allocatable, intent(out) :: line
!> Status of operation
integer, intent(out) :: iostat
!> Error message
character(len=:), allocatable, optional :: iomsg
integer, parameter :: BUFFER_SIZE = 1024
character(len=BUFFER_SIZE) :: buffer
character(len=256) :: msg
integer :: size
integer :: stat
allocate(character(len=0) :: line)
do
read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) &
& buffer
if (stat > 0) exit
line = line // buffer(:size)
if (stat < 0) then
if (is_iostat_eor(stat)) then
stat = 0
end if
exit
end if
end do
if (stat /= 0) then
if (present(iomsg)) iomsg = trim(msg)
end if
iostat = stat
end subroutine getline
!> delete a file by filename
subroutine delete_file(file)
character(len=*), intent(in) :: file
logical :: exist
integer :: unit
inquire(file=file, exist=exist)
if (exist) then
open(file=file, newunit=unit)
close(unit, status="delete")
end if
end subroutine delete_file
!> write trimmed character data to a file if it does not exist
subroutine warnwrite(fname,data)
character(len=*),intent(in) :: fname
character(len=*),intent(in) :: data(:)
if(.not.exists(fname))then
call filewrite(fname,data)
else
write(stderr,'(*(g0,1x))')'<INFO> ',fname,&
& 'already exists. Not overwriting'
endif
end subroutine warnwrite
!> procedure to open filename as a sequential "text" file
subroutine fileopen(filename,lun,ier)
character(len=*),intent(in) :: filename
integer,intent(out) :: lun
integer,intent(out),optional :: ier
integer :: ios
character(len=256) :: message
message=' '
ios=0
if(filename/=' ')then
open(file=filename, &
& newunit=lun, &
& form='formatted', & ! FORM = FORMATTED | UNFORMATTED
& access='sequential', & ! ACCESS = SEQUENTIAL| DIRECT | STREAM
& action='write', & ! ACTION = READ|WRITE| READWRITE
& position='rewind', & ! POSITION= ASIS | REWIND | APPEND
& status='new', & ! STATUS = NEW| REPLACE| OLD| SCRATCH| UNKNOWN
& iostat=ios, &
& iomsg=message)
else
lun=stdout
ios=0
endif
if(ios/=0)then
lun=-1
if(present(ier))then
ier=ios
else
call fpm_stop(3,'*fileopen*:'//filename//':'//trim(message))
endif
endif
end subroutine fileopen
!> simple close of a LUN. On error show message and stop (by default)
subroutine fileclose(lun,ier)
integer,intent(in) :: lun
integer,intent(out),optional :: ier
character(len=256) :: message
integer :: ios
if(lun/=-1)then
close(unit=lun,iostat=ios,iomsg=message)
if(ios/=0)then
if(present(ier))then
ier=ios
else
call fpm_stop(4,'*fileclose*:'//trim(message))
endif
endif
endif
end subroutine fileclose
!> procedure to write filedata to file filename
subroutine filewrite(filename,filedata)
character(len=*),intent(in) :: filename
character(len=*),intent(in) :: filedata(:)
integer :: lun, i, ios
character(len=256) :: message
call fileopen(filename,lun)
if(lun/=-1)then ! program currently stops on error on open, but might
! want it to continue so -1 (unallowed LUN) indicates error
! write file
do i=1,size(filedata)
write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i))
if(ios/=0)then
call fpm_stop(5,'*filewrite*:'//filename//':'//trim(message))
endif
enddo
endif
! close file
call fileclose(lun)
end subroutine filewrite
!>AUTHOR: John S. Urban
!!LICENSE: Public Domain
!>
!!##Name
!! which(3f) - [M_io:ENVIRONMENT] given a command name find the pathname by searching
!! the directories in the environment variable $PATH
!! (LICENSE:PD)
!!
!!##Syntax
!! function which(command) result(pathname)
!!
!! character(len=*),intent(in) :: command
!! character(len=:),allocatable :: pathname
!!
!!##Description
!! Given a command name find the first file with that name in the directories
!! specified by the environment variable $PATH.
!!
!!##options
!! COMMAND the command to search for
!!
!!##Returns
!! PATHNAME the first pathname found in the current user path. Returns blank
!! if the command is not found.
!!
!!##Example
!!
!! Sample program:
!!
!! Checking the error message and counting lines:
!!
!! program demo_which
!! use M_io, only : which
!! implicit none
!! write(*,*)'ls is ',which('ls')
!! write(*,*)'dir is ',which('dir')
!! write(*,*)'install is ',which('install')
!! end program demo_which
!!
function which(command) result(pathname)
character(len=*),intent(in) :: command
character(len=:),allocatable :: pathname, checkon, paths(:), exts(:)
integer :: i, j
pathname=''
call split(get_env('PATH'),paths,delimiters=merge(';',':',separator()=='\'))
SEARCH: do i=1,size(paths)
checkon=trim(join_path(trim(paths(i)),command))
select case(separator())
case('/')
if(exists(checkon))then
pathname=checkon
exit SEARCH
endif
case('\')
if(exists(checkon))then
pathname=checkon
exit SEARCH
endif
if(exists(checkon//'.bat'))then
pathname=checkon//'.bat'
exit SEARCH
endif
if(exists(checkon//'.exe'))then
pathname=checkon//'.exe'
exit SEARCH
endif
call split(get_env('PATHEXT'),exts,delimiters=';')
do j=1,size(exts)
if(exists(checkon//'.'//trim(exts(j))))then
pathname=checkon//'.'//trim(exts(j))
exit SEARCH
endif
enddo
end select
enddo SEARCH
end function which
!>AUTHOR: fpm(1) contributors
!!LICENSE: MIT
!>
!!##Name
!! run(3f) - execute specified system command and selectively echo
!! command and output to a file and/or stdout.
!! (LICENSE:MIT)
!!
!!##Syntax
!! subroutine run(cmd,echo,exitstat,verbose,redirect)
!!
!! character(len=*), intent(in) :: cmd
!! logical,intent(in),optional :: echo
!! integer, intent(out),optional :: exitstat
!! logical, intent(in), optional :: verbose
!! character(*), intent(in), optional :: redirect
!!
!!##Description
!! Execute the specified system command. Optionally
!!
!! + echo the command before execution
!! + return the system exit status of the command.
!! + redirect the output of the command to a file.
!! + echo command output to stdout
!!
!! Calling run(3f) is preferred to direct calls to
!! execute_command_line(3f) in the fpm(1) source to provide a standard
!! interface where output modes can be specified.
!!
!!##Options
!! CMD System command to execute
!! ECHO Whether to echo the command being executed or not
!! Defaults to .TRUE. .
!! VERBOSE Whether to redirect the command output to a null device or not
!! Defaults to .TRUE. .
!! REDIRECT Filename to redirect stdout and stderr of the command into.
!! If generated it is closed before run(3f) returns.
!! EXITSTAT The system exit status of the command when supported by
!! the system. If not present and a non-zero status is
!! generated program termination occurs.
!!
!!##Example
!!
!! Sample program:
!!
!! Checking the error message and counting lines:
!!
!! program demo_run
!! use fpm_filesystem, only : run
!! implicit none
!! logical,parameter :: T=.true., F=.false.
!! integer :: exitstat
!! character(len=:),allocatable :: cmd
!! cmd='ls -ltrasd *.md'
!! call run(cmd)
!! call run(cmd,exitstat=exitstat)
!! call run(cmd,echo=F)
!! call run(cmd,verbose=F)
!! end program demo_run
!!
subroutine run(cmd,echo,exitstat,verbose,redirect)
character(len=*), intent(in) :: cmd
logical,intent(in),optional :: echo
integer, intent(out),optional :: exitstat
logical, intent(in), optional :: verbose
character(*), intent(in), optional :: redirect
integer :: cmdstat
character(len=256) :: cmdmsg, iomsg
logical :: echo_local, verbose_local
character(:), allocatable :: redirect_str
character(:), allocatable :: line
integer :: stat, fh, iostat
if(present(echo))then
echo_local=echo