From 868212e4174fdf48672f4bb2e36efd3f7fda41d2 Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Tue, 29 Jun 2021 21:10:57 -0300 Subject: Optimize the file listing routine. --- src/fpm_filesystem.f90 | 242 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 241 insertions(+), 1 deletion(-) diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.f90 index e6226b4..d2fcd95 100644 --- a/src/fpm_filesystem.f90 +++ b/src/fpm_filesystem.f90 @@ -7,6 +7,8 @@ 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 implicit none private public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, & @@ -16,6 +18,143 @@ 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)) + 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 @@ -312,6 +451,107 @@ subroutine mkdir(dir) 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` @@ -376,7 +616,7 @@ 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) -- cgit v1.2.3 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 +++++++++++++++++++++++++++++++++++++++++++++++++ src/fpm_filesystem.f90 | 945 ------------------------------------------------- 2 files changed, 945 insertions(+), 945 deletions(-) create mode 100644 src/fpm_filesystem.F90 delete mode 100644 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 diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.f90 deleted file mode 100644 index d2fcd95..0000000 --- a/src/fpm_filesystem.f90 +++ /dev/null @@ -1,945 +0,0 @@ -!> 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/c.c | 22 ++++++ src/fpm_filesystem.F90 | 178 ++++++++++--------------------------------------- src/fpm_strings.f90 | 32 +++++++++ 3 files changed, 91 insertions(+), 141 deletions(-) create mode 100644 src/c.c diff --git a/src/c.c b/src/c.c new file mode 100644 index 0000000..8cfbd20 --- /dev/null +++ b/src/c.c @@ -0,0 +1,22 @@ +/* FIXME: fpm --flag '-DENABLE_C_WRAPPER' currently doesn't work with .c files. Use #if..#endif below for the time being. */ +#if ((defined(_WIN32) && (defined(__MINGW32__) || defined(__MINGW64__))) || defined(__linux__) || defined(__APPLE__) || defined(__OpenBSD__)) +#define ENABLE_C_WRAPPER +#endif + +#ifdef ENABLE_C_WRAPPER +#include +#include + +int is_dir(const char *path) +{ + struct stat m; + int r = stat(path, &m); + return r == 0 && S_ISDIR(m.st_mode); +} + +const char *get_d_name(struct dirent *d) +{ + return (const char *) d->d_name; +} + +#endif 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 diff --git a/src/fpm_strings.f90 b/src/fpm_strings.f90 index 3d7d7b1..5a47311 100644 --- a/src/fpm_strings.f90 +++ b/src/fpm_strings.f90 @@ -29,6 +29,7 @@ module fpm_strings use iso_fortran_env, only: int64 +use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer, c_size_t implicit none private @@ -70,6 +71,10 @@ interface string_t module procedure new_string_t end interface string_t +interface f_string + module procedure f_string, f_string_cptr, f_string_cptr_n +end interface f_string + contains !> test if a CHARACTER string ends with a specified suffix @@ -125,6 +130,33 @@ function f_string(c_string) end function f_string +!> return Fortran character variable when given a null-terminated c_ptr +function f_string_cptr(cptr) result(s) + type(c_ptr), intent(in), value :: cptr + character(len=:,kind=c_char), allocatable :: s + + interface + function c_strlen(s) result(r) bind(c, name="strlen") + import c_size_t, c_ptr + type(c_ptr), intent(in), value :: s + integer(kind=c_size_t) :: r + end function + end interface + + s = f_string_cptr_n(cptr, c_strlen(cptr)) +end function + +!> return Fortran character variable when given a null-terminated c_ptr and its length +function f_string_cptr_n(cptr, n) result(s) + type(c_ptr), intent(in), value :: cptr + integer(kind=c_size_t), intent(in) :: n + character(len=n,kind=c_char) :: s + character(len=n,kind=c_char), pointer :: sptr + + call c_f_pointer(cptr, sptr) + s = sptr +end function + !> Hash a character(*) string of default kind pure function fnv_1a_char(input, seed) result(hash) character(*), intent(in) :: input -- 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/c.c | 8 -------- src/fpm_filesystem.F90 | 4 ++-- 2 files changed, 2 insertions(+), 10 deletions(-) diff --git a/src/c.c b/src/c.c index 8cfbd20..c54469a 100644 --- a/src/c.c +++ b/src/c.c @@ -1,9 +1,3 @@ -/* FIXME: fpm --flag '-DENABLE_C_WRAPPER' currently doesn't work with .c files. Use #if..#endif below for the time being. */ -#if ((defined(_WIN32) && (defined(__MINGW32__) || defined(__MINGW64__))) || defined(__linux__) || defined(__APPLE__) || defined(__OpenBSD__)) -#define ENABLE_C_WRAPPER -#endif - -#ifdef ENABLE_C_WRAPPER #include #include @@ -18,5 +12,3 @@ const char *get_d_name(struct dirent *d) { return (const char *) d->d_name; } - -#endif 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/c.c | 2 +- src/fpm_filesystem.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/c.c b/src/c.c index c54469a..d9048a9 100644 --- a/src/c.c +++ b/src/c.c @@ -1,7 +1,7 @@ #include #include -int is_dir(const char *path) +int c_is_dir(const char *path) { struct stat m; int r = stat(path, &m); 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/c.c | 27 +++++++++++++++++++++++++++ src/fpm_filesystem.F90 | 4 ++-- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/src/c.c b/src/c.c index d9048a9..7075f42 100644 --- a/src/c.c +++ b/src/c.c @@ -1,6 +1,11 @@ #include #include +#ifdef __APPLE__ +DIR * opendir$INODE64( const char * dirName ); +struct dirent * readdir$INODE64( DIR * dir ); +#endif + int c_is_dir(const char *path) { struct stat m; @@ -12,3 +17,25 @@ const char *get_d_name(struct dirent *d) { return (const char *) d->d_name; } + + + +DIR *c_opendir(const char *dirname){ + +#ifdef __APPLE__ + return opendir$INODE64(dirname); +#else + return opendir(dirname); +#endif + +} + +struct dirent *c_readdir(DIR *dirp){ + +#ifdef __APPLE__ + return readdir$INODE64(dirp); +#else + return readdir(dirp); +#endif + +} \ No newline at end of file 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 e18017d155c7edb31a503203187c5d0bab20b846 Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Fri, 16 Jul 2021 21:15:47 -0300 Subject: Rename src\c.c => src\filesystem_utilities.c --- src/c.c | 41 ----------------------------------------- src/filesystem_utilities.c | 41 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+), 41 deletions(-) delete mode 100644 src/c.c create mode 100644 src/filesystem_utilities.c diff --git a/src/c.c b/src/c.c deleted file mode 100644 index 7075f42..0000000 --- a/src/c.c +++ /dev/null @@ -1,41 +0,0 @@ -#include -#include - -#ifdef __APPLE__ -DIR * opendir$INODE64( const char * dirName ); -struct dirent * readdir$INODE64( DIR * dir ); -#endif - -int c_is_dir(const char *path) -{ - struct stat m; - int r = stat(path, &m); - return r == 0 && S_ISDIR(m.st_mode); -} - -const char *get_d_name(struct dirent *d) -{ - return (const char *) d->d_name; -} - - - -DIR *c_opendir(const char *dirname){ - -#ifdef __APPLE__ - return opendir$INODE64(dirname); -#else - return opendir(dirname); -#endif - -} - -struct dirent *c_readdir(DIR *dirp){ - -#ifdef __APPLE__ - return readdir$INODE64(dirp); -#else - return readdir(dirp); -#endif - -} \ No newline at end of file diff --git a/src/filesystem_utilities.c b/src/filesystem_utilities.c new file mode 100644 index 0000000..7075f42 --- /dev/null +++ b/src/filesystem_utilities.c @@ -0,0 +1,41 @@ +#include +#include + +#ifdef __APPLE__ +DIR * opendir$INODE64( const char * dirName ); +struct dirent * readdir$INODE64( DIR * dir ); +#endif + +int c_is_dir(const char *path) +{ + struct stat m; + int r = stat(path, &m); + return r == 0 && S_ISDIR(m.st_mode); +} + +const char *get_d_name(struct dirent *d) +{ + return (const char *) d->d_name; +} + + + +DIR *c_opendir(const char *dirname){ + +#ifdef __APPLE__ + return opendir$INODE64(dirname); +#else + return opendir(dirname); +#endif + +} + +struct dirent *c_readdir(DIR *dirp){ + +#ifdef __APPLE__ + return readdir$INODE64(dirp); +#else + return readdir(dirp); +#endif + +} \ No newline at end of file -- cgit v1.2.3 From 1c6673c62523d7a3cf8bfa37e8997da8e76b7f9c Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Tue, 20 Jul 2021 00:00:51 -0300 Subject: Cache get_os_type() return value using the save attribute --- src/fpm_environment.f90 | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90 index e9da3c7..a9f8c65 100644 --- a/src/fpm_environment.f90 +++ b/src/fpm_environment.f90 @@ -40,7 +40,16 @@ contains character(len=32) :: val integer :: length, rc logical :: file_exists + logical, save :: first_run = .true. + integer, save :: ret = OS_UNKNOWN + !omp threadprivate(ret, first_run) + if (.not. first_run) then + r = ret + return + end if + + first_run = .false. r = OS_UNKNOWN ! Check environment variable `OS`. @@ -48,6 +57,7 @@ contains if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then r = OS_WINDOWS + ret = r return end if @@ -58,42 +68,49 @@ contains ! Linux if (index(val, 'linux') > 0) then r = OS_LINUX + ret = r return end if ! macOS if (index(val, 'darwin') > 0) then r = OS_MACOS + ret = r return end if ! Windows, MSYS, MinGW, Git Bash if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then r = OS_WINDOWS + ret = r return end if ! Cygwin if (index(val, 'cygwin') > 0) then r = OS_CYGWIN + ret = r return end if ! Solaris, OpenIndiana, ... if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then r = OS_SOLARIS + ret = r return end if ! FreeBSD if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then r = OS_FREEBSD + ret = r return end if ! OpenBSD if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then r = OS_OPENBSD + ret = r return end if end if @@ -103,6 +120,7 @@ contains if (file_exists) then r = OS_LINUX + ret = r return end if @@ -111,6 +129,7 @@ contains if (file_exists) then r = OS_MACOS + ret = r return end if @@ -119,6 +138,7 @@ contains if (file_exists) then r = OS_FREEBSD + ret = r return end if end function get_os_type -- 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(-) 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(-) 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