path: root/common/utilities.F90

! Copyright (c) 2021 Approximatrix, LLC <support@approximatrix.com>
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! The Software shall be used for Good, not Evil.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module utilities

#ifdef WINDOWS
    character, parameter::dir_sep = '\'
#else
    character, parameter::dir_sep = '/'
#endif

    integer, parameter::DIR_LIST_STRING_LENGTH = 128

    interface replace_field
        module procedure replace_field_text
        module procedure replace_field_int
    end interface

contains

    function is_absolute_path(path)
    implicit none
    
        logical::is_absolute_path
        character(len=*), intent(in)::path
        
        is_absolute_path = .false.
        if(path(1:1) == dir_sep) then
            is_absolute_path = .true.
        else
#ifdef WINDOWS
            if(path(2:2) == ":") then
                is_absolute_path = .true.
            end if
#endif
        end if
        
    end function is_absolute_path
        
    subroutine combine_paths(first, second, res)
    implicit none
    
        character(len=*), intent(in)::first, second
        character(len=*), intent(out)::res
    
        integer::i
        
        i = len_trim(first)
    
        if(first(i:i) == dir_sep) then
            res = trim(first)//trim(second)
        else
            res = trim(first)//dir_sep//trim(second)
        end if
        
    end subroutine combine_paths
    
    subroutine write_date_and_time(unit_number, values)
    implicit none
    
        integer, intent(in)::unit_number
        integer, intent(in), dimension(8)::values

        write(unit_number, '(I4, A1, I0.2, A1, I0.2, 1X, I2, A1, I0.2, A1, I0.2)') &
            values(1), "-", &
            values(2), "-", &
            values(3),  &
            values(5), ":", &
            values(6), ":", &
            values(7)

    end subroutine write_date_and_time
    
    function remove_directory(absolute_dir, and_files)
    implicit none
    
        character(*), intent(in)::absolute_dir
        logical, intent(in), optional::and_files
        logical::remove_directory
        
        character(len=8)::cmd, flags
        integer::retval
        
#ifdef WINDOWS        
        flags = " "
        cmd = "rmdir"
#else
        flags = "-rf"
        cmd = "rm"
#endif

        if(present(and_files)) then
            if(and_files) then
#ifdef WINDOWS
                flags = "/S /Q"
#else
                flags = "-rf"
#endif
            end if
        end if
        
        call execute_command_line(trim(cmd)//" "//trim(flags)//" "//trim(absolute_dir), &
                                  wait=.true., exitstat=retval)
            
        remove_directory = (retval == 0)
        
    end function remove_directory
    
    function read_into_buffer(unit_number, buffer)
    implicit none
    
        integer, intent(in)::unit_number
        character, dimension(:), intent(out)::buffer
        integer::read_into_buffer
        
        integer::i, ierr
        
        ierr = 0
        i = 0
        do while(ierr == 0 .and. i < size(buffer))
            i = i + 1
            read(unit_number, iostat=ierr) buffer(i)
        end do
            
        if(ierr /= 0) then
            i = i - 1
        end if
        
        read_into_buffer = i
    
    end function read_into_buffer
    
    function generate_temporary_filename() result(fullpath)
    use iso_c_binding
    implicit none
    
        character(len=:), pointer::fullpath
        type(c_ptr)::tmp_name
        character(kind=c_char), dimension(:), pointer::cfullpath
        integer(kind=c_size_t)::clength
        integer::i
        
        interface
            function c_strlen(p) bind(c, name='strlen')
            use iso_c_binding
            type(c_ptr), value::p
            integer(kind=c_size_t)::strlen
            end function c_strlen
            
            function c_malloc(x) bind(c, name='malloc')
            use iso_c_binding
            type(c_ptr)::c_malloc
            integer(kind=c_size_t), value::x
            end function c_malloc
            
            subroutine c_free(p) bind(c, name='free')
            use iso_c_binding
            type(c_ptr), value::p
            end subroutine c_free
            
        end interface

#ifdef WINDOWS
        interface
            function GetTempPath(n, b) bind(c, name='GetTempPathA')
            use iso_c_binding
            integer(kind=c_int32_t)::GetTempPath
            integer(kind=c_int32_t), value::n
            type(c_ptr), value::b
            end function GetTempPath
        
            function GetTempFileName(pn, prefix, unique, b) bind(c, name='GetTempFileNameA')
            use iso_c_binding
            integer(kind=c_int)::GetTempFileName
            integer(kind=c_int), value::unique
            type(c_ptr), value::pn, prefix, b
            end function GetTempFileName
        end interface
        
        type(c_ptr)::tmp_path
        integer::res
        
        tmp_path = c_malloc(int(1024, kind=c_size_t))
        res = GetTempPath(1023, tmp_path)
        
        tmp_name = c_malloc(int(1024, kind=c_size_t))
        res = GetTempFileName(tmp_path, c_null_ptr, 0, tmp_name)
        
        call c_free(tmp_path)
        
        ! Convert the C Ptr to a Fortran object
        clength = c_strlen(tmp_name)
        if(clength == 0) then
            stop
        end if
        call c_f_pointer(tmp_name, cfullpath, (/ clength /))
        allocate(character(len=clength)::fullpath)
        do i = 1, clength
            fullpath(i:i) = cfullpath(i)
        end do
        
        cfullpath => null()
        call c_free(tmp_name)
        
#else
        character(32)::num_text
        real::rnum
        
        allocate(character(len=1024) :: fullpath)
        
        call random_number(rnum)
        write(num_text, *) abs(rnum)
        fullpath = "/tmp/lv."//trim(adjustl(num_text))//".tmp"
    
        !call write_log("My temp filename is: '"//trim(fullpath)//"'")
#endif
        
    end function generate_temporary_filename
    
    subroutine delete_file(filename)
    implicit none
    
        character(*), intent(in)::filename
        
#ifdef GNU
        call unlink(filename)
#else
        ! Not implemented...
#endif

    end subroutine delete_file
    
    subroutine replace_field_text(str, field, val)
    implicit none
    
        character(*), intent(inout)::str
        character(*), intent(in)::field
        character(*), intent(in)::val
    
        character(len=:), allocatable::holding
        integer::length_estimate
        integer::field_location, i
        
        ! This is too big, but close enough
        length_estimate = len_trim(str) + len_trim(val)
        allocate(character(len=length_estimate) :: holding)
        holding = " "

        ! Find the field
        field_location = index(str, "{"//trim(field)//"}")
        if(field_location > 0) then

            i = field_location + len_trim(field) + 2
            holding = str(1:field_location-1)//trim(val)//str(i:len_trim(str))

            ! Put the results back now
            str = holding
            
        end if

        deallocate(holding)
    
    end subroutine replace_field_text

    subroutine replace_field_int(str, field, val)
    implicit none
    
        character(*), intent(inout)::str
        character(*), intent(in)::field
        integer, intent(in)::val
        
        character(16)::int_text
        
        write(int_text, *) val
        
        call replace_field_text(str, field, trim(adjustl(int_text)))
        
    end subroutine replace_field_int
    
    function get_line_count_in_file(filename) result(res)
    implicit none
        
        character(*)::filename
        integer::res
        
        integer::unum, ierr
        character(1024)::line
    
        open(newunit=unum, file=filename, action='read')
        res = 0
    
        read(unum, '(A)', iostat=ierr) line
        do while(ierr == 0)
            res = res + 1
            read(unum, '(A)', iostat=ierr) line
        end do
        
        close(unum)
    
    end function get_line_count_in_file
    
    function get_directories_in_directory(directory) result(res)
    implicit none
    
        character(*), intent(in)::directory
        character(DIR_LIST_STRING_LENGTH), dimension(:), pointer::res
        character(80)::line
        character(len=:), pointer::tempfile
        integer::dcount, unum, ierr, i
        
        tempfile => generate_temporary_filename()
        res => null()

#ifdef WINDOWS
        call execute_command_line("dir /b/ad-h"//trim(directory)//" > "//trim(tempfile), &
                                  wait=.true.)
#else
        call execute_command_line("ls -l "//trim(directory)//" > "//trim(tempfile), &
                                  wait=.true.)
#endif
    
        open(newunit=unum, file=tempfile, action='read')

#ifndef WINDOWS
        ! First line is "total ###"
        read(unum, '(A)', iostat=ierr) line
#endif

        dcount = 0
        read(unum, '(A)', iostat=ierr) line
        do while(ierr == 0)

#ifdef WINDOWS
            if(len_trim(line) > 0) then
                dcount = dcount + 1
            end if
#else
            if(line(1:1) == 'd') then
                dcount = dcount + 1
            end if
#endif

            read(unum, '(A)', iostat=ierr) line
        end do
        
        close(unum)
        
        if(dcount > 0) then
            allocate(res(dcount))
            
            ! Windows is all set, don't call anything
#ifndef WINDOWS
            ! Now call ls, but group directories first
            call execute_command_line("ls --group-directories-first "//trim(directory)//" > "//trim(tempfile), &
                                      wait=.true.)
#endif

            open(newunit=unum, file=tempfile, action='read')
            i = 0
            read(unum, '(A)', iostat=ierr) line
            do while(ierr == 0 .and. i < dcount)
                i = i + 1
                res(i) = trim(line)
                read(unum, '(A)', iostat=ierr) line
            end do
            
            close(unum)
        end if
        
        call unlink(tempfile)
        
    end function get_directories_in_directory
    
    function get_files_in_directory(directory) result(res)
    implicit none
    
        character(*), intent(in)::directory
        character(DIR_LIST_STRING_LENGTH), dimension(:), pointer::res
        character(80)::line
        character(len=:), pointer::tempfile
        
        logical, dimension(:), allocatable::is_real_file
        
        integer::unum, ierr, i, n, j
        
        tempfile => generate_temporary_filename()
        res => null()

#ifdef WINDOWS
        call execute_command_line("dir /b/a-d-h"//trim(directory)//" > "//trim(tempfile), &
                                  wait=.true.)
#else
        call execute_command_line("ls -l "//trim(directory)//" > "//trim(tempfile), &
                                  wait=.true.)
#endif
                                
        n = get_line_count_in_file(tempfile)
        allocate(is_real_file(n))
        is_real_file = .FALSE.
                                
        open(newunit=unum, file=tempfile, action='read')
        
#ifndef WINDOWS
        ! Count directories first
        i = 0
        read(unum, '(A)', iostat=ierr) line
        do while(ierr == 0)

            i = i + 1
            if(len_trim(line) > 0 .and. line(1:1) == '-' .and. line(1:6) /= "total ") then
                is_real_file(i) = .TRUE.
            end if            
            read(unum, '(A)', iostat=ierr) line
        end do
        
        n = count(is_real_file)
        close(unum)
        
        call execute_command_line("ls "//trim(directory)//" > "//trim(tempfile), &
                                  wait=.true.)
                                  
        open(newunit=unum, file=tempfile, action='read')
#else
        is_real_file = .TRUE.
#endif

        if(n > 0) then
            allocate(res(n))
                
            ! Now we can read files
            i = 0
            j = 0
            read(unum, '(A)', iostat=ierr) line
            do while(ierr == 0 .and. i < n)
                j = j + 1
                if(is_real_file(j)) then
                    i = i + 1
                    res(i) = trim(line)
                end if
                
                read(unum, '(A)', iostat=ierr) line
            end do
        end if
        
        close(unum)
        
        call unlink(tempfile)
    
    end function get_files_in_directory
    
end module utilities