diff --git a/src/filesystem_utilities.c b/src/filesystem_utilities.c new file mode 100644 index 0000000000..7075f4232b --- /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 diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90 index e9da3c76a2..a9f8c65972 100644 --- a/src/fpm_environment.f90 +++ b/src/fpm_environment.f90 @@ -40,7 +40,16 @@ integer function get_os_type() result(r) 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 @@ integer function get_os_type() result(r) 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 @@ integer function get_os_type() result(r) ! 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 @@ integer function get_os_type() result(r) if (file_exists) then r = OS_LINUX + ret = r return end if @@ -111,6 +129,7 @@ integer function get_os_type() result(r) if (file_exists) then r = OS_MACOS + ret = r return end if @@ -119,6 +138,7 @@ integer function get_os_type() result(r) if (file_exists) then r = OS_FREEBSD + ret = r return end if end function get_os_type diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.F90 similarity index 81% rename from src/fpm_filesystem.f90 rename to src/fpm_filesystem.F90 index 284f558bc1..597ed7b957 100644 --- a/src/fpm_filesystem.f90 +++ b/src/fpm_filesystem.F90 @@ -7,6 +7,7 @@ module fpm_filesystem 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_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer use fpm_error, only : fpm_stop implicit none private @@ -17,6 +18,39 @@ module fpm_filesystem integer, parameter :: LINE_BUFFER_LEN = 1000 +#ifndef FPM_BOOTSTRAP + interface + function c_opendir(dir) result(r) bind(c, name="c_opendir") + import c_char, c_ptr + character(kind=c_char), intent(in) :: dir(*) + type(c_ptr) :: r + end function c_opendir + + function c_readdir(dir) result(r) bind(c, name="c_readdir") + import c_ptr + type(c_ptr), intent(in), value :: dir + type(c_ptr) :: r + end function c_readdir + + function c_closedir(dir) result(r) bind(c, name="closedir") + import c_ptr, c_int + type(c_ptr), intent(in), value :: dir + integer(kind=c_int) :: r + end function c_closedir + + function c_get_d_name(dir) result(r) bind(c, name="get_d_name") + import c_ptr + type(c_ptr), intent(in), value :: dir + type(c_ptr) :: r + end function c_get_d_name + + function c_is_dir(path) result(r) bind(c, name="c_is_dir") + import c_char, c_int + character(kind=c_char), intent(in) :: path(*) + integer(kind=c_int) :: r + end function c_is_dir + end interface +#endif contains @@ -226,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 @@ -311,7 +355,94 @@ subroutine mkdir(dir) end if end subroutine mkdir +#ifndef FPM_BOOTSTRAP +!> Get file & directory names in directory `dir` using iso_c_binding. +!! +!! - File/directory names return are relative to cwd, ie. preprended with `dir` +!! - Includes files starting with `.` except current directory and parent directory +!! +recursive subroutine list_files(dir, files, recurse) + character(len=*), intent(in) :: dir + type(string_t), allocatable, intent(out) :: files(:) + logical, intent(in), optional :: recurse + + integer :: i + type(string_t), allocatable :: dir_files(:) + type(string_t), allocatable :: sub_dir_files(:) + + type(c_ptr) :: dir_handle + type(c_ptr) :: dir_entry_c + character(len=:,kind=c_char), allocatable :: fortran_name + character(len=:), allocatable :: string_fortran + integer, parameter :: N_MAX = 256 + type(string_t) :: files_tmp(N_MAX) + integer(kind=c_int) :: r + + if (c_is_dir(dir(1:len_trim(dir))//c_null_char) .eq. 0) then + allocate (files(0)) + return + end if + + dir_handle = c_opendir(dir(1:len_trim(dir))//c_null_char) + if (.not. c_associated(dir_handle)) then + print *, 'c_opendir() failed' + error stop + end if + + i = 0 + allocate(files(0)) + do + dir_entry_c = c_readdir(dir_handle) + if (.not. c_associated(dir_entry_c)) then + exit + else + string_fortran = f_string(c_get_d_name(dir_entry_c)) + + if ((string_fortran .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 (c_is_dir(files(i)%s//c_null_char) .ne. 0) then + call list_files(files(i)%s, dir_files, recurse=.true.) + sub_dir_files = [sub_dir_files, dir_files] + end if + end do + + files = [files, sub_dir_files] + end if + end if +end subroutine list_files + +#else !> Get file & directory names in directory `dir`. !! !! - File/directory names return are relative to cwd, ie. preprended with `dir` @@ -376,6 +507,8 @@ recursive subroutine list_files(dir, files, recurse) end subroutine list_files +#endif + !> test if pathname already exists logical function exists(filename) result(r) diff --git a/src/fpm_strings.f90 b/src/fpm_strings.f90 index efbf054d01..6ce36cfaaf 100644 --- a/src/fpm_strings.f90 +++ b/src/fpm_strings.f90 @@ -31,6 +31,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 @@ -73,6 +74,10 @@ module fpm_strings 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 @@ -128,6 +133,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