fpm_filesystem.F90 Source File


Source Code

!> This module contains general routines for interacting with the file system
!!
module fpm_filesystem
    use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
    use,intrinsic :: iso_c_binding, only: c_new_line
    use fpm_environment, only: get_os_type, &
                               OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
                               OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
    use fpm_environment, only: separator, get_env, os_is_unix
    use fpm_strings, only: f_string, replace, string_t, split, split_first_last, dilate, str_begins_with_str
    use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer
    use fpm_error, only : fpm_stop, error_t, fatal_error
    implicit none
    private
    public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, get_local_prefix, &
            mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, fileopen, fileclose, &
            filewrite, warnwrite, parent_dir, is_hidden_file, read_lines, read_lines_expanded, which, run, &
            os_delete_dir, is_absolute_path, get_home, execute_and_read_output, get_dos_path

#ifndef FPM_BOOTSTRAP
    interface
        function c_opendir(dir) result(r) bind(c, name="c_opendir")
            import c_char, c_ptr
            character(kind=c_char), intent(in) :: dir(*)
            type(c_ptr) :: r
        end function c_opendir

        function c_readdir(dir) result(r) bind(c, name="c_readdir")
            import c_ptr
            type(c_ptr), intent(in), value :: dir
            type(c_ptr) :: r
        end function c_readdir

        function c_closedir(dir) result(r) bind(c, name="closedir")
            import c_ptr, c_int
            type(c_ptr), intent(in), value :: dir
            integer(kind=c_int) :: r
        end function c_closedir

        function c_get_d_name(dir) result(r) bind(c, name="get_d_name")
            import c_ptr
            type(c_ptr), intent(in), value :: dir
            type(c_ptr) :: r
        end function c_get_d_name

        function c_is_dir(path) result(r) bind(c, name="c_is_dir")
            import c_char, c_int
            character(kind=c_char), intent(in) :: path(*)
            integer(kind=c_int) :: r
        end function c_is_dir
    end interface
#endif

    character(*), parameter :: eol = new_line('a')    !! End of line

contains

!> Extract filename from path with/without suffix
function basename(path,suffix) result (base)

    character(*), intent(In) :: path
    logical, intent(in), optional :: suffix
    character(:), allocatable :: base

    character(:), allocatable :: file_parts(:)
    logical :: with_suffix

    if (.not.present(suffix)) then
        with_suffix = .true.
    else
        with_suffix = suffix
    end if

    call split(path,file_parts,delimiters='\/')
    if(size(file_parts)>0)then
       base = trim(file_parts(size(file_parts)))
    else
       base = ''
    endif
    if(.not.with_suffix)then
        call split(base,file_parts,delimiters='.')
        if(size(file_parts)>=2)then
           base = trim(file_parts(size(file_parts)-1))
        endif
    endif

end function basename


!> Canonicalize path for comparison
!! * Handles path string redundancies
!! * Does not test existence of path
!!
!! To be replaced by realpath/_fullname in stdlib_os
!!
!! FIXME: Lot's of ugly hacks following here
function canon_path(path)
    character(len=*), intent(in) :: path
    character(len=:), allocatable :: canon_path
    character(len=:), allocatable :: nixpath

    integer :: istart, iend, nn, last
    logical :: is_path, absolute

    nixpath = unix_path(path)

    istart = 0
    nn = 0
    iend = 0
    absolute = nixpath(1:1) == "/"
    if (absolute) then
        canon_path = "/"
    else
        canon_path = ""
    end if

    do while(iend < len(nixpath))
        call next(nixpath, istart, iend, is_path)
        if (is_path) then
            select case(nixpath(istart:iend))
            case(".", "") ! always drop empty paths
            case("..")
                if (nn > 0) then
                    last = scan(canon_path(:len(canon_path)-1), "/", back=.true.)
                    canon_path = canon_path(:last)
                    nn = nn - 1
                else
                    if (.not. absolute) then
                        canon_path = canon_path // nixpath(istart:iend) // "/"
                    end if
                end if
            case default
                nn = nn + 1
                canon_path = canon_path // nixpath(istart:iend) // "/"
            end select
        end if
    end do

    if (len(canon_path) == 0) canon_path = "."
    if (len(canon_path) > 1 .and. canon_path(len(canon_path):) == "/") then
        canon_path = canon_path(:len(canon_path)-1)
    end if

contains

    subroutine next(string, istart, iend, is_path)
        character(len=*), intent(in) :: string
        integer, intent(inout) :: istart
        integer, intent(inout) :: iend
        logical, intent(inout) :: is_path

        integer :: ii, nn
        character :: tok

        nn = len(string)

        if (iend >= nn) then
            istart = nn
            iend = nn
            return
        end if

        ii = min(iend + 1, nn)
        tok = string(ii:ii)

        is_path = tok /= '/'

        if (.not.is_path) then
            is_path = .false.
            istart = ii
            iend = ii
            return
        end if

        istart = ii
        do ii = min(iend + 1, nn), nn
            tok = string(ii:ii)
            select case(tok)
            case('/')
                exit
            case default
                iend = ii
                cycle
            end select
        end do

    end subroutine next
end function canon_path


!> Extract dirname from path
function dirname(path) result (dir)
    character(*), intent(in) :: path
    character(:), allocatable :: dir

    dir = path(1:scan(path,'/\',back=.true.))

end function dirname

!> Extract dirname from path
function parent_dir(path) result (dir)
    character(*), intent(in) :: path
    character(:), allocatable :: dir

    dir = path(1:scan(path,'/\',back=.true.)-1)

end function parent_dir


!> test if a name matches an existing directory path
logical function is_dir(dir)
    character(*), intent(in) :: dir
    integer :: stat

    select case (get_os_type())

    case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
        call run( "test -d " // dir , &
                & exitstat=stat,echo=.false.,verbose=.false.)

    case (OS_WINDOWS)
        call run('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', &
                & exitstat=stat,echo=.false.,verbose=.false.)

    end select

    is_dir = (stat == 0)

end function is_dir

!> test if a file is hidden
logical function is_hidden_file(file_basename) result(r)
    character(*), intent(in) :: file_basename
    if (len(file_basename) <= 2) then
        r = .false.
    else
        r = str_begins_with_str(file_basename, '.')
    end if
end function is_hidden_file

!> Construct path by joining strings with os file separator
function join_path(a1,a2,a3,a4,a5) result(path)

    character(len=*), intent(in)           :: a1, a2
    character(len=*), intent(in), optional :: a3, a4, a5
    character(len=:), allocatable          :: path
    character(len=1)                       :: filesep
    logical, save                          :: has_cache = .false.
    character(len=1), save                 :: cache = '/'
    !$omp threadprivate(has_cache, cache)

    if (has_cache) then
        filesep = cache
    else
        select case (get_os_type())
            case default
                filesep = '/'
            case (OS_WINDOWS)
                filesep = '\'
        end select

        cache = filesep
        has_cache = .true.
    end if

    if (a1 == "") then
        path = a2
    else
        path = a1 // filesep // a2
    end if

    if (present(a3)) then
        path = path // filesep // a3
    else
        return
    end if

    if (present(a4)) then
        path = path // filesep // a4
    else
        return
    end if

    if (present(a5)) then
        path = path // filesep // a5
    else
        return
    end if

end function join_path


!> Determine number or rows in a file given a LUN
integer function number_of_rows(s) result(nrows)
    integer,intent(in)::s
    integer :: ios
    rewind(s)
    nrows = 0
    do
        read(s, *, iostat=ios)
        if (ios /= 0) exit
        nrows = nrows + 1
    end do
    rewind(s)
end function number_of_rows

!> read lines into an array of TYPE(STRING_T) variables expanding tabs
function read_lines_expanded(filename) result(lines)
    character(len=*), intent(in) :: filename
    type(string_t), allocatable :: lines(:)

    integer :: i
    character(len=:), allocatable :: content
    integer, allocatable :: first(:), last(:)

    content = read_text_file(filename)
    if (len(content) == 0) then
        allocate (lines(0))
        return
    end if

    call split_first_last(content, eol, first, last)  ! TODO: \r (< macOS X), \n (>=macOS X/Linux/Unix), \r\n (Windows)

    ! allocate lines from file content string
    allocate (lines(size(first)))
    do i = 1, size(first)
        allocate(lines(i)%s, source=dilate(content(first(i):last(i))))
    end do

end function read_lines_expanded

!> read lines into an array of TYPE(STRING_T) variables
function read_lines(filename) result(lines)
    character(len=*), intent(in) :: filename
    type(string_t), allocatable :: lines(:)

    integer :: i
    character(len=:), allocatable :: content
    integer, allocatable :: first(:), last(:)

    content = read_text_file(filename)
    if (len(content) == 0) then
        allocate (lines(0))
        return
    end if

    call split_first_last(content, eol, first, last)  ! TODO: \r (< macOS X), \n (>=macOS X/Linux/Unix), \r\n (Windows)

    ! allocate lines from file content string
    allocate (lines(size(first)))
    do i = 1, size(first)
        allocate(lines(i)%s, source=content(first(i):last(i)))
    end do

end function read_lines

!> read text file into a string
function read_text_file(filename) result(string)
    character(len=*), intent(in) :: filename
    character(len=:), allocatable :: string
    integer :: fh, length

    open (newunit=fh, file=filename, status='old', action='read', &
            access='stream', form='unformatted')
    inquire (fh, size=length)
    allocate (character(len=length) :: string)
    if (length == 0) return
    read (fh) string
    close (fh)

end function read_text_file

!> Create a directory. Create subdirectories as needed
subroutine mkdir(dir, echo)
    character(len=*), intent(in) :: dir
    logical, intent(in), optional :: echo

    integer :: stat

    if (is_dir(dir)) return

    select case (get_os_type())
        case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
            call run('mkdir -p ' // dir, exitstat=stat,echo=echo,verbose=.false.)

        case (OS_WINDOWS)
            call run("mkdir " // windows_path(dir), &
                    & echo=echo, exitstat=stat,verbose=.false.)

    end select

    if (stat /= 0) then
        call fpm_stop(1, '*mkdir*:directory creation failed')
    end if
end subroutine mkdir

#ifndef FPM_BOOTSTRAP
!> Get file & directory names in directory `dir` using iso_c_binding.
!!
!!  - File/directory names return are relative to cwd, ie. preprended with `dir`
!!  - Includes files starting with `.` except current directory and parent directory
!!
recursive subroutine list_files(dir, files, recurse)
    character(len=*), intent(in) :: dir
    type(string_t), allocatable, intent(out) :: files(:)
    logical, intent(in), optional :: recurse

    integer :: i
    type(string_t), allocatable :: dir_files(:)
    type(string_t), allocatable :: sub_dir_files(:)

    type(c_ptr) :: dir_handle
    type(c_ptr) :: dir_entry_c
    character(len=:,kind=c_char), allocatable :: fortran_name
    character(len=:), allocatable :: string_fortran
    integer, parameter :: N_MAX = 256
    type(string_t) :: files_tmp(N_MAX)
    integer(kind=c_int) :: r

    if (c_is_dir(dir(1:len_trim(dir))//c_null_char) == 0) then
        allocate (files(0))
        return
    end if

    dir_handle = c_opendir(dir(1:len_trim(dir))//c_null_char)
    if (.not. c_associated(dir_handle)) then
        print *, 'c_opendir() failed'
        error stop
    end if

    i = 0
    allocate(files(0))

    do
        dir_entry_c = c_readdir(dir_handle)
        if (.not. c_associated(dir_entry_c)) then
            exit
        else
            string_fortran = f_string(c_get_d_name(dir_entry_c))

            if ((string_fortran == '.' .or. string_fortran == '..')) then
                cycle
            end if

            i = i + 1

            if (i > N_MAX) then
                files = [files, files_tmp]
                i = 1
            end if

            files_tmp(i)%s = join_path(dir, string_fortran)
        end if
    end do

    r = c_closedir(dir_handle)

    if (r /= 0) then
        print *, 'c_closedir() failed'
        error stop
    end if

    if (i > 0) then
        files = [files, files_tmp(1:i)]
    end if

    if (present(recurse)) then
        if (recurse) then

            allocate(sub_dir_files(0))

            do i=1,size(files)
                if (c_is_dir(files(i)%s//c_null_char) /= 0) then
                    call list_files(files(i)%s, dir_files, recurse=.true.)
                    sub_dir_files = [sub_dir_files, dir_files]
                end if
            end do

            files = [files, sub_dir_files]
        end if
    end if
end subroutine list_files

#else
!> Get file & directory names in directory `dir`.
!!
!!  - File/directory names return are relative to cwd, ie. preprended with `dir`
!!  - Includes files starting with `.` except current directory and parent directory
!!
recursive subroutine list_files(dir, files, recurse)
    character(len=*), intent(in) :: dir
    type(string_t), allocatable, intent(out) :: files(:)
    logical, intent(in), optional :: recurse

    integer :: stat, fh, i
    character(:), allocatable :: temp_file
    type(string_t), allocatable :: dir_files(:)
    type(string_t), allocatable :: sub_dir_files(:)

    if (.not. is_dir(dir)) then
        allocate (files(0))
        return
    end if

    allocate (temp_file, source=get_temp_filename())

    select case (get_os_type())
        case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
            call run('ls -A ' // dir , &
                    & redirect=temp_file, exitstat=stat,echo=.false.,verbose=.false.)
        case (OS_WINDOWS)
            call run('dir /b ' // windows_path(dir), &
                    & redirect=temp_file, exitstat=stat,echo=.false.,verbose=.false.)
    end select

    if (stat /= 0) then
        call fpm_stop(2,'*list_files*:directory listing failed')
    end if

    files = read_lines(temp_file)
    call delete_file(temp_file)

    do i=1,size(files)
        files(i)%s = join_path(dir,files(i)%s)
    end do

    if (present(recurse)) then
        if (recurse) then

            allocate(sub_dir_files(0))

            do i=1,size(files)
                if (is_dir(files(i)%s)) then

                    call list_files(files(i)%s, dir_files, recurse=.true.)
                    sub_dir_files = [sub_dir_files, dir_files]

                end if
            end do

            files = [files, sub_dir_files]

        end if
    end if

end subroutine list_files

#endif


!> test if pathname already exists
logical function exists(filename) result(r)
    character(len=*), intent(in) :: filename
    inquire(file=filename, exist=r)

    !> Directories are not files for the Intel compilers. If so, also use this compiler-dependent extension
#if defined(__INTEL_COMPILER)
    if (.not.r) inquire(directory=filename, exist=r)
#endif

end function


!> Get a unused temporary filename
!!  Calls posix 'tempnam' - not recommended, but
!!   we have no security concerns for this application
!!   and use here is temporary.
!! Works with MinGW
function get_temp_filename() result(tempfile)
    !
    use iso_c_binding, only: c_ptr, C_NULL_PTR, c_f_pointer
    integer, parameter :: MAX_FILENAME_LENGTH = 32768
    character(:), allocatable :: tempfile

    type(c_ptr) :: c_tempfile_ptr
    character(len=1), pointer :: c_tempfile(:)

    interface

        function c_tempnam(dir,pfx) result(tmp) bind(c,name="tempnam")
            import
            type(c_ptr), intent(in), value :: dir
            type(c_ptr), intent(in), value :: pfx
            type(c_ptr) :: tmp
        end function c_tempnam

        subroutine c_free(ptr) BIND(C,name="free")
            import
            type(c_ptr), value :: ptr
        end subroutine c_free

    end interface

    c_tempfile_ptr = c_tempnam(C_NULL_PTR, C_NULL_PTR)
    call c_f_pointer(c_tempfile_ptr,c_tempfile,[MAX_FILENAME_LENGTH])

    tempfile = f_string(c_tempfile)

    call c_free(c_tempfile_ptr)

end function get_temp_filename


!> Replace file system separators for windows
function windows_path(path) result(winpath)

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

    integer :: idx

    winpath = path

    idx = index(winpath,'/')
    do while(idx > 0)
        winpath(idx:idx) = '\'
        idx = index(winpath,'/')
    end do

end function windows_path


!> Replace file system separators for unix
function unix_path(path) result(nixpath)

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

    integer :: idx

    nixpath = path

    idx = index(nixpath,'\')
    do while(idx > 0)
        nixpath(idx:idx) = '/'
        idx = index(nixpath,'\')
    end do

end function unix_path

!>AUTHOR: fpm(1) contributors
!!LICENSE: MIT
!>
!!##NAME
!!     getline(3f) - [M_io:READ] read a line of arbintrary length from specified
!!     LUN into allocatable string (up to system line length limit)
!!    (LICENSE:PD)
!!
!!##SYNTAX
!!   subroutine getline(unit,line,iostat,iomsg)
!!
!!    integer,intent(in)                       :: unit
!!    character(len=:),allocatable,intent(out) :: line
!!    integer,intent(out)                      :: iostat
!!    character(len=:), allocatable, optional  :: iomsg
!!
!!##DESCRIPTION
!!    Read a line of any length up to programming environment maximum
!!    line length. Requires Fortran 2003+.
!!
!!    It is primarily expected to be used when reading input which will
!!    then be parsed or echoed.
!!
!!    The input file must have a PAD attribute of YES for the function
!!    to work properly, which is typically true.
!!
!!    The simple use of a loop that repeatedly re-allocates a character
!!    variable in addition to reading the input file one buffer at a
!!    time could (depending on the programming environment used) be
!!    inefficient, as it could reallocate and allocate memory used for
!!    the output string with each buffer read.
!!
!!##OPTIONS
!!    LINE    The line read when IOSTAT returns as zero.
!!    LUN     LUN (Fortran logical I/O unit) number of file open and ready
!!            to read.
!!    IOSTAT  status returned by READ(IOSTAT=IOS). If not zero, an error
!!            occurred or an end-of-file or end-of-record was encountered.
!!    IOMSG   error message returned by system when IOSTAT is not zero.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_getline
!!    use,intrinsic :: iso_fortran_env, only : stdin=>input_unit
!!    use,intrinsic :: iso_fortran_env, only : iostat_end
!!    use FPM_filesystem, only : getline
!!    implicit none
!!    integer :: iostat
!!    character(len=:),allocatable :: line, iomsg
!!       open(unit=stdin,pad='yes')
!!       INFINITE: do
!!          call getline(stdin,line,iostat,iomsg)
!!          if(iostat /= 0) exit INFINITE
!!          write(*,'(a)')'['//line//']'
!!       enddo INFINITE
!!       if(iostat /= iostat_end)then
!!          write(*,*)'error reading input:',iomsg
!!       endif
!!    end program demo_getline
!!
subroutine getline(unit, line, iostat, iomsg)

    !> Formatted IO unit
    integer, intent(in) :: unit

    !> Line to read
    character(len=:), allocatable, intent(out) :: line

    !> Status of operation
    integer, intent(out) :: iostat

    !> Error message
    character(len=:), allocatable, optional :: iomsg

    integer, parameter :: BUFFER_SIZE = 1024
    character(len=BUFFER_SIZE)       :: buffer
    character(len=256)               :: msg
    integer :: size
    integer :: stat

    allocate(character(len=0) :: line)
    do
        read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) &
            & buffer
        if (stat > 0) exit
        line = line // buffer(:size)
        if (stat < 0) then
            if (is_iostat_eor(stat)) then
                stat = 0
            end if
            exit
        end if
    end do

    if (stat /= 0) then
        if (present(iomsg)) iomsg = trim(msg)
    end if
    iostat = stat

end subroutine getline


!> delete a file by filename
subroutine delete_file(file)
    character(len=*), intent(in) :: file
    logical :: exist
    integer :: unit
    inquire(file=file, exist=exist)
    if (exist) then
        open(file=file, newunit=unit)
        close(unit, status="delete")
    end if
end subroutine delete_file

!> write trimmed character data to a file if it does not exist
subroutine warnwrite(fname,data)
character(len=*),intent(in) :: fname
character(len=*),intent(in) :: data(:)

    if(.not.exists(fname))then
        call filewrite(fname,data)
    else
        write(stderr,'(*(g0,1x))')'<INFO>  ',fname,&
        & 'already exists. Not overwriting'
    endif

end subroutine warnwrite

!> procedure to open filename as a sequential "text" file
subroutine fileopen(filename,lun,ier)

character(len=*),intent(in)   :: filename
integer,intent(out)           :: lun
integer,intent(out),optional  :: ier
integer                       :: ios
character(len=256)            :: message

    message=' '
    ios=0
    if(filename/=' ')then
        open(file=filename, &
        & newunit=lun, &
        & form='formatted', &    ! FORM    = FORMATTED | UNFORMATTED
        & access='sequential', & ! ACCESS  = SEQUENTIAL| DIRECT | STREAM
        & action='write', &      ! ACTION  = READ|WRITE| READWRITE
        & position='rewind', &   ! POSITION= ASIS      | REWIND | APPEND
        & status='new', &        ! STATUS  = NEW| REPLACE| OLD| SCRATCH| UNKNOWN
        & iostat=ios, &
        & iomsg=message)
    else
        lun=stdout
        ios=0
    endif
    if(ios/=0)then
        lun=-1
        if(present(ier))then
           ier=ios
        else
           call fpm_stop(3,'*fileopen*:'//filename//':'//trim(message))
        endif
    endif

end subroutine fileopen

!> simple close of a LUN.  On error show message and stop (by default)
subroutine fileclose(lun,ier)
integer,intent(in)    :: lun
integer,intent(out),optional :: ier
character(len=256)    :: message
integer               :: ios
    if(lun/=-1)then
        close(unit=lun,iostat=ios,iomsg=message)
        if(ios/=0)then
            if(present(ier))then
               ier=ios
            else
               call fpm_stop(4,'*fileclose*:'//trim(message))
            endif
        endif
    endif
end subroutine fileclose

!> procedure to write filedata to file filename
subroutine filewrite(filename,filedata)

character(len=*),intent(in)           :: filename
character(len=*),intent(in)           :: filedata(:)
integer                               :: lun, i, ios
character(len=256)                    :: message
    call fileopen(filename,lun)
    if(lun/=-1)then ! program currently stops on error on open, but might
                      ! want it to continue so -1 (unallowed LUN) indicates error
       ! write file
       do i=1,size(filedata)
           write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i))
           if(ios/=0)then
               call fpm_stop(5,'*filewrite*:'//filename//':'//trim(message))
           endif
       enddo
    endif
    ! close file
    call fileclose(lun)

end subroutine filewrite

!>AUTHOR: John S. Urban
!!LICENSE: Public Domain
!>
!!##Name
!!     which(3f) - [M_io:ENVIRONMENT] given a command name find the pathname by searching
!!                 the directories in the environment variable $PATH
!!     (LICENSE:PD)
!!
!!##Syntax
!!   function which(command) result(pathname)
!!
!!    character(len=*),intent(in)  :: command
!!    character(len=:),allocatable :: pathname
!!
!!##Description
!!    Given a command name find the first file with that name in the directories
!!    specified by the environment variable $PATH.
!!
!!##options
!!    COMMAND   the command to search for
!!
!!##Returns
!!    PATHNAME  the first pathname found in the current user path. Returns blank
!!              if the command is not found.
!!
!!##Example
!!
!!   Sample program:
!!
!!   Checking the error message and counting lines:
!!
!!     program demo_which
!!     use M_io, only : which
!!     implicit none
!!        write(*,*)'ls is ',which('ls')
!!        write(*,*)'dir is ',which('dir')
!!        write(*,*)'install is ',which('install')
!!     end program demo_which
!!
function which(command) result(pathname)
character(len=*),intent(in)     :: command
character(len=:),allocatable    :: pathname, checkon, paths(:), exts(:)
integer                         :: i, j
   pathname=''
   call split(get_env('PATH'),paths,delimiters=merge(';',':',separator()=='\'))
   SEARCH: do i=1,size(paths)
      checkon=trim(join_path(trim(paths(i)),command))
      select case(separator())
      case('/')
         if(exists(checkon))then
            pathname=checkon
            exit SEARCH
         endif
      case('\')
         if(exists(checkon))then
            pathname=checkon
            exit SEARCH
         endif
         if(exists(checkon//'.bat'))then
            pathname=checkon//'.bat'
            exit SEARCH
         endif
         if(exists(checkon//'.exe'))then
            pathname=checkon//'.exe'
            exit SEARCH
         endif
         call split(get_env('PATHEXT'),exts,delimiters=';')
         do j=1,size(exts)
            if(exists(checkon//'.'//trim(exts(j))))then
               pathname=checkon//'.'//trim(exts(j))
               exit SEARCH
            endif
         enddo
      end select
   enddo SEARCH
end function which

!>AUTHOR: fpm(1) contributors
!!LICENSE: MIT
!>
!!##Name
!!    run(3f) -  execute specified system command and selectively echo
!!    command and output to a file and/or stdout.
!!    (LICENSE:MIT)
!!
!!##Syntax
!!    subroutine run(cmd,echo,exitstat,verbose,redirect)
!!
!!     character(len=*), intent(in)       :: cmd
!!     logical,intent(in),optional        :: echo
!!     integer, intent(out),optional      :: exitstat
!!     logical, intent(in), optional      :: verbose
!!     character(*), intent(in), optional :: redirect
!!
!!##Description
!!   Execute the specified system command. Optionally
!!
!!   +  echo the command before execution
!!   +  return the system exit status of the command.
!!   +  redirect the output of the command to a file.
!!   +  echo command output to stdout
!!
!!   Calling run(3f) is preferred to direct calls to
!!   execute_command_line(3f) in the fpm(1) source to provide a standard
!!   interface where output modes can be specified.
!!
!!##Options
!!    CMD       System command to execute
!!    ECHO      Whether to echo the command being executed or not
!!              Defaults to .TRUE. .
!!    VERBOSE   Whether to redirect the command output to a null device or not
!!              Defaults to .TRUE. .
!!    REDIRECT  Filename to redirect stdout and stderr of the command into.
!!              If generated it is closed before run(3f) returns.
!!    EXITSTAT  The system exit status of the command when supported by
!!              the system. If not present and a non-zero status is
!!              generated program termination occurs.
!!
!!##Example
!!
!!   Sample program:
!!
!!   Checking the error message and counting lines:
!!
!!     program demo_run
!!     use fpm_filesystem, only : run
!!     implicit none
!!     logical,parameter :: T=.true., F=.false.
!!     integer :: exitstat
!!     character(len=:),allocatable :: cmd
!!        cmd='ls -ltrasd *.md'
!!        call run(cmd)
!!        call run(cmd,exitstat=exitstat)
!!        call run(cmd,echo=F)
!!        call run(cmd,verbose=F)
!!     end program demo_run
!!
subroutine run(cmd,echo,exitstat,verbose,redirect)
    character(len=*), intent(in) :: cmd
    logical,intent(in),optional  :: echo
    integer, intent(out),optional :: exitstat
    logical, intent(in), optional :: verbose
    character(*), intent(in), optional :: redirect

    integer            :: cmdstat
    character(len=256) :: cmdmsg, iomsg
    logical :: echo_local, verbose_local
    character(:), allocatable :: redirect_str
    character(:), allocatable :: line
    integer :: stat, fh, iostat

    if(present(echo))then
       echo_local=echo
    else
       echo_local=.true.
    end if

    if(present(verbose))then
        verbose_local=verbose
    else
        verbose_local=.true.
    end if

    if (present(redirect)) then
        if(redirect /= '')then
           redirect_str =  ">"//redirect//" 2>&1"
        else
           redirect_str = "" 
        endif
    else
        if(verbose_local)then
            ! No redirection but verbose output
            redirect_str = ""
        else
            ! No redirection and non-verbose output
            if (os_is_unix()) then
                redirect_str = " >/dev/null 2>&1"
            else
                redirect_str = " >NUL 2>&1"
            end if
        end if
    end if

    if(echo_local) print *, '+ ', cmd !//redirect_str

    call execute_command_line(cmd//redirect_str, exitstat=stat,cmdstat=cmdstat,cmdmsg=cmdmsg)
    if(cmdstat /= 0)then
        write(*,'(a)')'<ERROR>:failed command '//cmd//redirect_str
        call fpm_stop(1,'*run*:'//trim(cmdmsg))
    endif

    if (verbose_local.and.present(redirect)) then

        open(newunit=fh,file=redirect,status='old',iostat=iostat,iomsg=iomsg)
        if(iostat == 0)then
           do
               call getline(fh, line, iostat)
               if (iostat /= 0) exit
               write(*,'(A)') trim(line)
           end do
        else
           write(*,'(A)') trim(iomsg)
        endif

        close(fh)

    end if

    if (present(exitstat)) then
        exitstat = stat
    elseif (stat /= 0) then
        call fpm_stop(stat,'*run*: Command '//cmd//redirect_str//' returned a non-zero status code')
    end if

end subroutine run

!> Delete directory using system OS remove directory commands
subroutine os_delete_dir(is_unix, dir, echo)
    logical, intent(in) :: is_unix
    character(len=*), intent(in) :: dir
    logical, intent(in), optional :: echo

    if (is_unix) then
        call run('rm -rf ' // dir, echo=echo,verbose=.false.)
    else
        call run('rmdir /s/q ' // dir, echo=echo,verbose=.false.)
    end if

end subroutine os_delete_dir

    !> Determine the path prefix to the local folder. Used for installation, registry etc.
    function get_local_prefix(os) result(prefix)
        !> Installation prefix
        character(len=:), allocatable :: prefix
        !> Platform identifier
        integer, intent(in), optional :: os

        !> Default installation prefix on Unix platforms
        character(len=*), parameter :: default_prefix_unix = "/usr/local"
        !> Default installation prefix on Windows platforms
        character(len=*), parameter :: default_prefix_win = "C:\"

        character(len=:), allocatable :: home

        if (os_is_unix(os)) then
            home=get_env('HOME','')
            if (home /= '' ) then
                prefix = join_path(home, ".local")
            else
                prefix = default_prefix_unix
            end if
        else
            home=get_env('APPDATA','')
            if (home /= '' ) then
                prefix = join_path(home, "local")
            else
                prefix = default_prefix_win
            end if
        end if

    end function get_local_prefix

    !> Returns .true. if provided path is absolute.
    !>
    !> `~` not treated as absolute.
    logical function is_absolute_path(path, is_unix)
        character(len=*), intent(in) :: path
        logical, optional, intent(in):: is_unix
        character(len=*), parameter :: letters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
        logical :: is_unix_os

        if (present(is_unix)) then
            is_unix_os = is_unix
        else
            is_unix_os = os_is_unix()
        end if

        if (is_unix_os) then
            is_absolute_path = path(1:1) == '/'
        else
            if (len(path) < 2) then
                is_absolute_path = .false.
                return
            end if

            is_absolute_path = index(letters, path(1:1)) /= 0 .and. path(2:2) == ':'
        end if

    end function is_absolute_path

    !> Get the HOME directory on Unix and the %USERPROFILE% directory on Windows.
    subroutine get_home(home, error)
        character(len=:), allocatable, intent(out) :: home
        type(error_t), allocatable, intent(out) :: error

        if (os_is_unix()) then
            home=get_env('HOME','')
            if ( home == '' ) then
                call fatal_error(error, "Couldn't retrieve 'HOME' variable")
                return
            end if
        else
            home=get_env('USERPROFILE','')
            if ( home == '' ) then
                call fatal_error(error, "Couldn't retrieve '%USERPROFILE%' variable")
                return
            end if
        end if
    end subroutine get_home

    !> Execute command line and return output as a string.
    subroutine execute_and_read_output(cmd, output, error, verbose)
        !> Command to execute.
        character(len=*), intent(in) :: cmd
        !> Command line output.
        character(len=:), allocatable, intent(out) :: output
        !> Error to handle.
        type(error_t), allocatable, intent(out) :: error
        !> Print additional information if true.
        logical, intent(in), optional :: verbose

        integer :: exitstat, unit, stat
        character(len=:), allocatable :: cmdmsg, tmp_file, output_line
        logical :: is_verbose

        if (present(verbose)) then
          is_verbose = verbose
        else
          is_verbose = .false.
        end if

        tmp_file = get_temp_filename()

        call run(cmd//' > '//tmp_file, exitstat=exitstat, echo=is_verbose)
        if (exitstat /= 0) call fatal_error(error, '*run*: '//"Command failed: '"//cmd//"'. Message: '"//trim(cmdmsg)//"'.")

        open(newunit=unit, file=tmp_file, action='read', status='old')
        output = ''
        do
           call getline(unit, output_line, stat)
           if (stat /= 0) exit
           output = output//output_line//' '
        end do
        if (is_verbose) print *, output
        close(unit, status='delete')
    end

    !> Ensure a windows path is converted to an 8.3 DOS path if it contains spaces
    function get_dos_path(path,error)
        character(len=*), intent(in) :: path
        type(error_t), allocatable, intent(out) :: error
        character(len=:), allocatable :: get_dos_path

        character(:), allocatable :: redirect,screen_output,line
        integer :: stat,cmdstat,iunit,last

        ! Non-Windows OS
        if (get_os_type()/=OS_WINDOWS) then
            get_dos_path = path
            return
        end if

        ! Trim path first
        get_dos_path = trim(path)

        !> No need to convert if there are no spaces
        has_spaces: if (scan(get_dos_path,' ')>0) then

            redirect = get_temp_filename()
            call execute_command_line('cmd /c for %A in ("'//path//'") do @echo %~sA >'//redirect//' 2>&1',&
                                      exitstat=stat,cmdstat=cmdstat)

            !> Read screen output
            command_OK: if (cmdstat==0 .and. stat==0) then

                allocate(character(len=0) :: screen_output)
                open(newunit=iunit,file=redirect,status='old',iostat=stat)
                if (stat == 0)then

                   do
                       call getline(iunit, line, stat)
                       if (stat /= 0) exit
                       screen_output = screen_output//line//' '
                   end do

                   ! Close and delete file
                   close(iunit,status='delete')

                else
                   call fatal_error(error,'cannot read temporary file from successful DOS path evaluation')
                   return
                endif

            else command_OK

                call fatal_error(error,'unsuccessful Windows->DOS path command')
                return

            end if command_OK

            get_dos_path = trim(adjustl(screen_output))

        endif has_spaces

        !> Ensure there are no trailing slashes
        last = len_trim(get_dos_path)
        if (last>1 .and. get_dos_path(last:last)=='/' .or. get_dos_path(last:last)=='\') get_dos_path = get_dos_path(1:last-1)

    end function get_dos_path

end module fpm_filesystem