From 7de24a6cf2a8bb13eda0a9921c6c5f9062fe159c Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Tue, 29 Jun 2021 21:15:42 -0300 Subject: Rename fpm_filesystem.f90 to fpm_filesystem.F90: requires preprocessor --- src/fpm_filesystem.F90 | 945 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 945 insertions(+) create mode 100644 src/fpm_filesystem.F90 (limited to 'src/fpm_filesystem.F90') diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 new file mode 100644 index 0000000..d2fcd95 --- /dev/null +++ b/src/fpm_filesystem.F90 @@ -0,0 +1,945 @@ +!> 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 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 + use fpm_strings, only: f_string, replace, string_t, split + use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_int128_t, c_char, c_ptr, c_int, c_loc, c_long, c_short, & + c_null_char, c_associated, c_f_pointer + implicit none + private + public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, & + mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name + public :: fileopen, fileclose, filewrite, warnwrite, parent_dir + public :: which + + integer, parameter :: LINE_BUFFER_LEN = 1000 + +#if (defined(MINGW64)) + type, bind(c) :: stat_t + integer(kind=c_int32_t) :: st_dev + integer(kind=c_int16_t) :: st_ino + integer(kind=c_int16_t) :: st_mode + integer(kind=c_int16_t) :: st_nlink + + integer(kind=c_int16_t) :: st_uid + integer(kind=c_int16_t) :: st_gid + + integer(kind=c_int32_t) :: st_rdev + integer(kind=c_int32_t) :: st_size + + integer(kind=c_int64_t) :: st_atime + integer(kind=c_int64_t) :: st_mtime + integer(kind=c_int64_t) :: st_ctime + end type +#elif (defined(MINGW32)) + type, bind(c) :: stat_t + integer(kind=c_int32_t) :: st_dev + integer(kind=c_int16_t) :: st_ino + integer(kind=c_int16_t) :: st_mode + integer(kind=c_int16_t) :: st_nlink + + integer(kind=c_int16_t) :: st_uid + integer(kind=c_int16_t) :: st_gid + + integer(kind=c_int32_t) :: st_rdev + integer(kind=c_int32_t) :: st_size + + integer(kind=c_int32_t) :: st_atime + integer(kind=c_int32_t) :: st_mtime + integer(kind=c_int32_t) :: st_ctime + end type +#elif (defined(LINUX64)) + type, bind(c) :: stat_t + integer(kind=c_int64_t) :: st_dev + integer(kind=c_int64_t) :: st_ino + integer(kind=c_int64_t) :: st_nlink + integer(kind=c_int32_t) :: st_mode + + integer(kind=c_int32_t) :: st_uid + integer(kind=c_int32_t) :: st_gid + integer(kind=c_int32_t) :: pad0 + + integer(kind=c_int64_t) :: st_rdev + integer(kind=c_int64_t) :: st_size + integer(kind=c_int64_t) :: st_blksize + integer(kind=c_int64_t) :: st_blocks + + integer(kind=c_int128_t) :: st_atime + integer(kind=c_int128_t) :: st_mtime + integer(kind=c_int128_t) :: st_ctime + + integer(kind=c_int64_t) :: glibc_reserved4 + integer(kind=c_int64_t) :: glibc_reserved5 + integer(kind=c_int64_t) :: glibc_reserved6 + end type +#elif (defined(LINUX32)) + type, bind(c) :: stat_t + integer(kind=c_int64_t) :: st_dev + integer(kind=c_int16_t) :: pad1 + integer(kind=c_int32_t) :: st_ino + integer(kind=c_int32_t) :: st_mode + integer(kind=c_int32_t) :: st_nlink + + integer(kind=c_int32_t) :: st_uid + integer(kind=c_int32_t) :: st_gid + integer(kind=c_int64_t) :: st_rdev + integer(kind=c_int16_t) :: pad2 + + integer(kind=c_int32_t) :: st_size + integer(kind=c_int32_t) :: st_blksize + integer(kind=c_int32_t) :: st_blocks + + integer(kind=c_int64_t) :: st_atime + integer(kind=c_int64_t) :: st_mtime + integer(kind=c_int64_t) :: st_ctime + + integer(kind=c_int32_t) :: glibc_reserved4 + integer(kind=c_int32_t) :: glibc_reserved5 + end type +#endif + +#if (defined(MINGW64) || defined(MINGW32)) + type, bind(c) :: dirent + integer(kind=c_long) :: d_ino + integer(kind=c_short) :: d_reclen + integer(kind=c_short) :: d_namlen + character(len=1,kind=c_char) :: d_name(260) + end type +#elif (defined(LINUX64)) + type, bind(c) :: dirent + integer(kind=c_int64_t) :: d_ino + integer(kind=c_int64_t) :: d_off + integer(kind=c_int16_t) :: d_reclen + integer(kind=c_int8_t) :: d_type + character(len=1,kind=c_char) :: d_name(256) + end type +#elif (defined(LINUX32)) + type, bind(c) :: dirent + integer(kind=c_int32_t) :: d_ino + integer(kind=c_int32_t) :: d_off + integer(kind=c_int16_t) :: d_reclen + integer(kind=c_int8_t) :: d_type + character(len=1,kind=c_char) :: d_name(256) + end type +#endif + +#if (defined(MINGW64) || defined(MINGW32) || defined(LINUX64) || defined(LINUX32)) + interface + function c_stat(path, buf) result(r) bind(c, name="stat") + import c_char, c_ptr, c_int + character(kind=c_char), intent(in) :: path(*) + type(c_ptr), value :: buf + integer(kind=c_int) :: r + end function c_stat + + function c_opendir(dir) result(r) bind(c, name="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="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 + end interface +#endif + +contains + + +!> return value of environment variable +subroutine env_variable(var, name) + character(len=:), allocatable, intent(out) :: var + character(len=*), intent(in) :: name + integer :: length, stat + + call get_environment_variable(name, length=length, status=stat) + if (stat /= 0) return + + allocate(character(len=length) :: var) + + if (length > 0) then + call get_environment_variable(name, var, status=stat) + if (stat /= 0) then + deallocate(var) + return + end if + end if + +end subroutine env_variable + + +!> 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 + + if (with_suffix) then + call split(path,file_parts,delimiters='\/') + if(size(file_parts).gt.0)then + base = trim(file_parts(size(file_parts))) + else + base = '' + endif + else + call split(path,file_parts,delimiters='\/.') + if(size(file_parts).ge.2)then + base = trim(file_parts(size(file_parts)-1)) + else + base = '' + endif + end if + +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 :: ii, istart, iend, stat, 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, last + + 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.)) + if (len_trim(dir) == 0) dir = "." + +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 execute_command_line("test -d " // dir , exitstat=stat) + + case (OS_WINDOWS) + call execute_command_line('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', exitstat=stat) + + end select + + is_dir = (stat == 0) + +end function is_dir + + +!> 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 + + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + filesep = '/' + case (OS_WINDOWS) + filesep = '\' + end select + + path = a1 // filesep // a2 + + 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 + character(len=100) :: r + rewind(s) + nrows = 0 + do + read(s, '(A)', iostat=ios) r + 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 +function read_lines(fh) result(lines) + integer, intent(in) :: fh + type(string_t), allocatable :: lines(:) + + integer :: i + character(LINE_BUFFER_LEN) :: line_buffer + + allocate(lines(number_of_rows(fh))) + do i = 1, size(lines) + read(fh, '(A)') line_buffer + lines(i)%s = trim(line_buffer) + end do + +end function read_lines + +!> Create a directory. Create subdirectories as needed +subroutine mkdir(dir) + character(len=*), intent(in) :: dir + 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 execute_command_line('mkdir -p ' // dir, exitstat=stat) + write (*, '(" + ",2a)') 'mkdir -p ' // dir + + case (OS_WINDOWS) + call execute_command_line("mkdir " // windows_path(dir), exitstat=stat) + write (*, '(" + ",2a)') 'mkdir ' // windows_path(dir) + end select + + if (stat /= 0) then + print *, 'execute_command_line() failed' + error stop + end if +end subroutine mkdir + + +#if (defined(MINGW64) || defined(MINGW32) || defined(LINUX64) || defined(LINUX32)) +!> 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 + type(dirent), pointer :: dir_entry_fortran + character(len=:), allocatable :: string_fortran + integer, parameter :: N_MAX = 256 + type(string_t) :: files_tmp(N_MAX) + integer(kind=c_int) :: r + + if (.not. is_dir_c(dir(1:len_trim(dir))//c_null_char)) 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 + call c_f_pointer(dir_entry_c, dir_entry_fortran) + string_fortran = f_string(dir_entry_fortran%d_name) + + if ((string_fortran .eq. '.' .or. string_fortran .eq. '..')) then + cycle + end if + + i = i + 1 + + if (i .gt. 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 .ne. 0) then + print *, 'c_closedir() failed' + error stop + end if + + if (i .gt. 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 (is_dir_c(files(i)%s//c_null_char)) 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 + +function is_dir_c(path) result(r) + character(kind=c_char), intent(in) :: path(*) + logical :: r + type(stat_t), target :: buf + integer(kind=c_int) :: exists + integer(kind=c_int), parameter :: S_IFMT = 61440 + integer(kind=c_int), parameter :: S_IFDIR = 16384 + + exists = c_stat(path, c_loc(buf)) + r = exists .eq. 0 .and. iand(int(buf%st_mode, kind=c_int), S_IFMT) .eq. S_IFDIR +end function is_dir_c + +#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 execute_command_line('ls -A ' // dir // ' > ' // temp_file, & + exitstat=stat) + case (OS_WINDOWS) + call execute_command_line('dir /b ' // windows_path(dir) // ' > ' // temp_file, & + exitstat=stat) + end select + + if (stat /= 0) then + print *, 'execute_command_line() failed' + error stop + end if + + open (newunit=fh, file=temp_file, status='old') + files = read_lines(fh) + close(fh,status="delete") + + 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) +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 + 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,[LINE_BUFFER_LEN]) + + 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 + + +!> read a line of arbitrary length into a CHARACTER variable from the specified LUN +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 + + character(len=LINE_BUFFER_LEN) :: buffer + character(len=LINE_BUFFER_LEN) :: 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))')' ',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.ne.' ')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.ne.0)then + write(stderr,'(*(a:,1x))')& + & ' *filewrite*:',filename,trim(message) + lun=-1 + if(present(ier))then + ier=ios + else + stop 1 + 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.ne.-1)then + close(unit=lun,iostat=ios,iomsg=message) + if(ios.ne.0)then + write(stderr,'(*(a:,1x))')' *filewrite*:',trim(message) + if(present(ier))then + ier=ios + else + stop 2 + 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.ne.-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.ne.0)then + write(stderr,'(*(a:,1x))')& + & ' *filewrite*:',filename,trim(message) + stop 4 + endif + enddo + endif + ! close file + call fileclose(lun) + +end subroutine filewrite + +!> Returns string with special characters replaced with an underscore. +!! For now, only a hyphen is treated as a special character, but this can be +!! expanded to other characters if needed. +pure function to_fortran_name(string) result(res) + character(*), intent(in) :: string + character(len(string)) :: res + character, parameter :: SPECIAL_CHARACTERS(*) = ['-'] + res = replace(string, SPECIAL_CHARACTERS, '_') +end function to_fortran_name + +function which(command) result(pathname) +!> +!!##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 +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain + +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().eq.'\')) + 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 + +end module fpm_filesystem -- cgit v1.2.3 From db869aa38ad7736df9eec5dfb8ac05b4ba45590b Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Wed, 7 Jul 2021 00:38:31 -0300 Subject: Add C wrapper for file listing --- src/fpm_filesystem.F90 | 178 ++++++++++--------------------------------------- 1 file changed, 37 insertions(+), 141 deletions(-) (limited to 'src/fpm_filesystem.F90') diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index d2fcd95..7d21e31 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -7,8 +7,7 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD use fpm_environment, only: separator, get_env use fpm_strings, only: f_string, replace, string_t, split - use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_int128_t, c_char, c_ptr, c_int, c_loc, c_long, c_short, & - c_null_char, c_associated, c_f_pointer + use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer implicit none private public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, & @@ -18,124 +17,8 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, integer, parameter :: LINE_BUFFER_LEN = 1000 -#if (defined(MINGW64)) - type, bind(c) :: stat_t - integer(kind=c_int32_t) :: st_dev - integer(kind=c_int16_t) :: st_ino - integer(kind=c_int16_t) :: st_mode - integer(kind=c_int16_t) :: st_nlink - - integer(kind=c_int16_t) :: st_uid - integer(kind=c_int16_t) :: st_gid - - integer(kind=c_int32_t) :: st_rdev - integer(kind=c_int32_t) :: st_size - - integer(kind=c_int64_t) :: st_atime - integer(kind=c_int64_t) :: st_mtime - integer(kind=c_int64_t) :: st_ctime - end type -#elif (defined(MINGW32)) - type, bind(c) :: stat_t - integer(kind=c_int32_t) :: st_dev - integer(kind=c_int16_t) :: st_ino - integer(kind=c_int16_t) :: st_mode - integer(kind=c_int16_t) :: st_nlink - - integer(kind=c_int16_t) :: st_uid - integer(kind=c_int16_t) :: st_gid - - integer(kind=c_int32_t) :: st_rdev - integer(kind=c_int32_t) :: st_size - - integer(kind=c_int32_t) :: st_atime - integer(kind=c_int32_t) :: st_mtime - integer(kind=c_int32_t) :: st_ctime - end type -#elif (defined(LINUX64)) - type, bind(c) :: stat_t - integer(kind=c_int64_t) :: st_dev - integer(kind=c_int64_t) :: st_ino - integer(kind=c_int64_t) :: st_nlink - integer(kind=c_int32_t) :: st_mode - - integer(kind=c_int32_t) :: st_uid - integer(kind=c_int32_t) :: st_gid - integer(kind=c_int32_t) :: pad0 - - integer(kind=c_int64_t) :: st_rdev - integer(kind=c_int64_t) :: st_size - integer(kind=c_int64_t) :: st_blksize - integer(kind=c_int64_t) :: st_blocks - - integer(kind=c_int128_t) :: st_atime - integer(kind=c_int128_t) :: st_mtime - integer(kind=c_int128_t) :: st_ctime - - integer(kind=c_int64_t) :: glibc_reserved4 - integer(kind=c_int64_t) :: glibc_reserved5 - integer(kind=c_int64_t) :: glibc_reserved6 - end type -#elif (defined(LINUX32)) - type, bind(c) :: stat_t - integer(kind=c_int64_t) :: st_dev - integer(kind=c_int16_t) :: pad1 - integer(kind=c_int32_t) :: st_ino - integer(kind=c_int32_t) :: st_mode - integer(kind=c_int32_t) :: st_nlink - - integer(kind=c_int32_t) :: st_uid - integer(kind=c_int32_t) :: st_gid - integer(kind=c_int64_t) :: st_rdev - integer(kind=c_int16_t) :: pad2 - - integer(kind=c_int32_t) :: st_size - integer(kind=c_int32_t) :: st_blksize - integer(kind=c_int32_t) :: st_blocks - - integer(kind=c_int64_t) :: st_atime - integer(kind=c_int64_t) :: st_mtime - integer(kind=c_int64_t) :: st_ctime - - integer(kind=c_int32_t) :: glibc_reserved4 - integer(kind=c_int32_t) :: glibc_reserved5 - end type -#endif - -#if (defined(MINGW64) || defined(MINGW32)) - type, bind(c) :: dirent - integer(kind=c_long) :: d_ino - integer(kind=c_short) :: d_reclen - integer(kind=c_short) :: d_namlen - character(len=1,kind=c_char) :: d_name(260) - end type -#elif (defined(LINUX64)) - type, bind(c) :: dirent - integer(kind=c_int64_t) :: d_ino - integer(kind=c_int64_t) :: d_off - integer(kind=c_int16_t) :: d_reclen - integer(kind=c_int8_t) :: d_type - character(len=1,kind=c_char) :: d_name(256) - end type -#elif (defined(LINUX32)) - type, bind(c) :: dirent - integer(kind=c_int32_t) :: d_ino - integer(kind=c_int32_t) :: d_off - integer(kind=c_int16_t) :: d_reclen - integer(kind=c_int8_t) :: d_type - character(len=1,kind=c_char) :: d_name(256) - end type -#endif - -#if (defined(MINGW64) || defined(MINGW32) || defined(LINUX64) || defined(LINUX32)) +#ifdef ENABLE_C_WRAPPER interface - function c_stat(path, buf) result(r) bind(c, name="stat") - import c_char, c_ptr, c_int - character(kind=c_char), intent(in) :: path(*) - type(c_ptr), value :: buf - integer(kind=c_int) :: r - end function c_stat - function c_opendir(dir) result(r) bind(c, name="opendir") import c_char, c_ptr character(kind=c_char), intent(in) :: dir(*) @@ -153,6 +36,18 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, 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="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 @@ -450,17 +345,17 @@ subroutine mkdir(dir) end if end subroutine mkdir - -#if (defined(MINGW64) || defined(MINGW32) || defined(LINUX64) || defined(LINUX32)) +#ifdef ENABLE_C_WRAPPER !> 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) +recursive subroutine list_files(dir, files, recurse, separator) character(len=*), intent(in) :: dir type(string_t), allocatable, intent(out) :: files(:) logical, intent(in), optional :: recurse + character(len=1), optional :: separator integer :: i type(string_t), allocatable :: dir_files(:) @@ -468,13 +363,25 @@ recursive subroutine list_files(dir, files, recurse) type(c_ptr) :: dir_handle type(c_ptr) :: dir_entry_c - type(dirent), pointer :: dir_entry_fortran + 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 + character(len=1) :: filesep + + if (present(separator)) then + filesep = separator + else + select case (get_os_type()) + case default + filesep = '/' + case (OS_WINDOWS) + filesep = '\' + end select + end if - if (.not. is_dir_c(dir(1:len_trim(dir))//c_null_char)) then + if (c_is_dir(dir(1:len_trim(dir))//c_null_char) .eq. 0) then allocate (files(0)) return end if @@ -493,8 +400,7 @@ recursive subroutine list_files(dir, files, recurse) if (.not. c_associated(dir_entry_c)) then exit else - call c_f_pointer(dir_entry_c, dir_entry_fortran) - string_fortran = f_string(dir_entry_fortran%d_name) + string_fortran = f_string(c_get_d_name(dir_entry_c)) if ((string_fortran .eq. '.' .or. string_fortran .eq. '..')) then cycle @@ -507,7 +413,7 @@ recursive subroutine list_files(dir, files, recurse) i = 1 end if - files_tmp(i)%s = join_path(dir, string_fortran) + files_tmp(i)%s = dir // filesep // string_fortran end if end do @@ -528,8 +434,8 @@ recursive subroutine list_files(dir, files, recurse) allocate(sub_dir_files(0)) do i=1,size(files) - if (is_dir_c(files(i)%s//c_null_char)) then - call list_files(files(i)%s, dir_files, recurse=.true.) + if (c_is_dir(files(i)%s//c_null_char) .ne. 0) then + call list_files(files(i)%s, dir_files, recurse=.true., separator=filesep) sub_dir_files = [sub_dir_files, dir_files] end if end do @@ -539,18 +445,6 @@ recursive subroutine list_files(dir, files, recurse) end if end subroutine list_files -function is_dir_c(path) result(r) - character(kind=c_char), intent(in) :: path(*) - logical :: r - type(stat_t), target :: buf - integer(kind=c_int) :: exists - integer(kind=c_int), parameter :: S_IFMT = 61440 - integer(kind=c_int), parameter :: S_IFDIR = 16384 - - exists = c_stat(path, c_loc(buf)) - r = exists .eq. 0 .and. iand(int(buf%st_mode, kind=c_int), S_IFMT) .eq. S_IFDIR -end function is_dir_c - #else !> Get file & directory names in directory `dir`. !! @@ -616,8 +510,10 @@ recursive subroutine list_files(dir, files, recurse) end if end subroutine list_files + #endif + !> test if pathname already exists logical function exists(filename) result(r) character(len=*), intent(in) :: filename -- cgit v1.2.3 From 52cb72f02e04786015b2adacd8072bcf2f5e89cb Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Sat, 10 Jul 2021 21:30:35 -0300 Subject: Use C wrapper by default --- src/fpm_filesystem.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/fpm_filesystem.F90') diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index 7d21e31..7b70ebe 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -17,7 +17,7 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, integer, parameter :: LINE_BUFFER_LEN = 1000 -#ifdef ENABLE_C_WRAPPER +#ifndef FPM_BOOTSTRAP interface function c_opendir(dir) result(r) bind(c, name="opendir") import c_char, c_ptr @@ -345,7 +345,7 @@ subroutine mkdir(dir) end if end subroutine mkdir -#ifdef ENABLE_C_WRAPPER +#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` -- cgit v1.2.3 From 619d619bf5754437401c314521fd48ecd557a5a0 Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Sun, 11 Jul 2021 11:05:15 -0300 Subject: Rename C function is_dir to c_is_dir --- src/fpm_filesystem.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/fpm_filesystem.F90') diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index 7b70ebe..9ae95cc 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -43,7 +43,7 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, type(c_ptr) :: r end function c_get_d_name - function c_is_dir(path) result(r) bind(c, name="is_dir") + 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 -- cgit v1.2.3 From 53027990c205eb905ff534544f4752ea92e747d7 Mon Sep 17 00:00:00 2001 From: LKedward Date: Fri, 16 Jul 2021 15:14:22 +0100 Subject: Fix: dirent symbols for OSX. --- src/fpm_filesystem.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/fpm_filesystem.F90') diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index 9ae95cc..2851bfd 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -19,13 +19,13 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, #ifndef FPM_BOOTSTRAP interface - function c_opendir(dir) result(r) bind(c, name="opendir") + 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="readdir") + 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 -- cgit v1.2.3 From 670e273ebb70c7be3615af4649112d75f043246b Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Tue, 20 Jul 2021 00:13:31 -0300 Subject: Use join_path() in list_files() --- src/fpm_filesystem.F90 | 19 +++---------------- 1 file changed, 3 insertions(+), 16 deletions(-) (limited to 'src/fpm_filesystem.F90') diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index e5cfa9d..b589c24 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -351,11 +351,10 @@ end subroutine mkdir !! - 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, separator) +recursive subroutine list_files(dir, files, recurse) character(len=*), intent(in) :: dir type(string_t), allocatable, intent(out) :: files(:) logical, intent(in), optional :: recurse - character(len=1), optional :: separator integer :: i type(string_t), allocatable :: dir_files(:) @@ -368,18 +367,6 @@ recursive subroutine list_files(dir, files, recurse, separator) integer, parameter :: N_MAX = 256 type(string_t) :: files_tmp(N_MAX) integer(kind=c_int) :: r - character(len=1) :: filesep - - if (present(separator)) then - filesep = separator - else - select case (get_os_type()) - case default - filesep = '/' - case (OS_WINDOWS) - filesep = '\' - end select - end if if (c_is_dir(dir(1:len_trim(dir))//c_null_char) .eq. 0) then allocate (files(0)) @@ -413,7 +400,7 @@ recursive subroutine list_files(dir, files, recurse, separator) i = 1 end if - files_tmp(i)%s = dir // filesep // string_fortran + files_tmp(i)%s = join_path(dir, string_fortran) end if end do @@ -435,7 +422,7 @@ recursive subroutine list_files(dir, files, recurse, separator) do i=1,size(files) if (c_is_dir(files(i)%s//c_null_char) .ne. 0) then - call list_files(files(i)%s, dir_files, recurse=.true., separator=filesep) + call list_files(files(i)%s, dir_files, recurse=.true.) sub_dir_files = [sub_dir_files, dir_files] end if end do -- cgit v1.2.3 From bb0c412b4a331166c12f48b90dd0d5397da34e04 Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Tue, 20 Jul 2021 00:48:50 -0300 Subject: Cache `filesep` in `join_path` using the save attribute --- src/fpm_filesystem.F90 | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) (limited to 'src/fpm_filesystem.F90') diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index b589c24..a26af75 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -260,13 +260,23 @@ function join_path(a1,a2,a3,a4,a5) result(path) 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) - select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) - filesep = '/' - case (OS_WINDOWS) - filesep = '\' - end select + 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 path = a1 // filesep // a2 -- cgit v1.2.3