module std_mkdir

use, intrinsic:: iso_c_binding, only: c_int, c_char, C_NULL_CHAR

use, intrinsic:: iso_fortran_env, only: stderr=>error_unit

implicit none

private

!> This interface connects to C stdlib functions present on any system.

interface

integer(c_int) function mkdir_c(path, mask) bind (C, name='mkdir')

import c_int, c_char

character(kind=c_char), intent(in) :: path(*)

integer(c_int), value, intent(in) :: mask

end function mkdir_c

end interface

public :: mkdir, is_directory, copyfile

contains

integer function copyfile(source, dest) result(istat)

character(*), intent(in) :: source, dest

character(len(source)) :: src

character(len(dest)) :: dst

logical :: exists

#ifdef _WIN32

character(6), parameter :: CMD='copy '

src = filesep_swap(source)

dst = filesep_swap(dest)

#else

character(6), parameter :: CMD='cp -r '

src = source

dst = dest

#endif

inquire(file=src, exist=exists)

if (.not.exists) then

write(stderr, *) src // ' source file does not exist.'

error stop

endif

call execute_command_line(CMD//src//' '//dst, exitstat=istat)

if (istat /= 0) write(stderr,*) 'error copying ',src, ' => ',dst

end function copyfile

function filesep_swap(path) result(swapped)

! swaps '/' to '\' for Windows systems

character(*), intent(in) :: path

character(len(path)) :: swapped

integer :: i

swapped = path

do

i = index(swapped, '/')

if (i == 0) exit

swapped(i:i) = char(92)

end do

end function filesep_swap

integer(c_int) function mkdir(path) result(ret)

!! Fortran standard compliant mkdir().

!! mkdir() is a GNU extension, not standard Fortran.

!! create a directory, with parents if needed

!! file separator is forward slash "/" only!

!!

!!

!! Tested on Linux and Windows

!! Michael Hirsch, Ph.D.

integer :: i,i0, ilast

character(len=*), intent(in) :: path

character(kind=c_char, len=:), allocatable :: buf

!! must use allocatable buffer, not direct substring to C

ret=0 !< in case directory already exists

buf = trim(path)

if (len(buf) == 0) then

write(stderr,*) 'must specify directory to create'

stop 1

endif

if(is_directory(buf)) then

print *, buf//' already exists'

return

endif

!> single relative directory

i = index(buf, '/')

if (i==0) then

ret = mkdir_c(buf//C_NULL_CHAR, int(o'755', c_int))

return

endif

!> handles parents

!> Note: auto-allocation also auto-reallocates--no deallocate() needed.

i=-1

i0=1

do while( i /= 0 )

i = index(path(i0:), '/')

if(i /= 0) then !< i0 skips last used separator

i0 = i0 + i

ilast = i0 - 1

else !< last path segment

i0 = len_trim(path)

ilast = i0

endif

!> allocated string buffer necessary for C interface

buf = path(1:ilast) !< don't include separator for Windows compatibility

if(is_directory(buf)) cycle

! print *,'i:',i,'i0:',i0,'ilast:',ilast,buf, len(buf)

ret = mkdir_c(buf//C_NULL_CHAR, int(o'755', c_int))

if (ret /= 0) then

write(stderr,*) 'error creating '//buf

return

endif

enddo

end function mkdir

logical function is_directory(path)

character(*), intent(in) :: path

#ifdef __INTEL_COMPILER

inquire(directory=path, exist=is_directory)

#else

inquire(file=path, exist=is_directory)

#endif

end function is_directory

end module std_mkdir