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

    character(len=:), pointer::temporary_directory

contains

    subroutine set_temporary_directory(d)
#ifdef WINDOWS    
    use iso_c_binding, only: c_null_char
#endif
    implicit none
        
        character(*), intent(in)::d
        
        if(len_trim(d) > 0) then
        
#ifdef WINDOWS
            allocate(character(len=(len_trim(d)+1)) :: temporary_directory)
            temporary_directory = d//c_null_char
#else
            allocate(character(len=(len_trim(d))) :: temporary_directory)
            temporary_directory = d
#endif
        
        end if
        
    end subroutine set_temporary_directory

    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 path_from_file(file, path)
    implicit none
    
        character(*), intent(in)::file
        character(*), intent(out)::path
        integer::i
        
        i = index(file, '/', back=.true.)
        if(i <= 0) then
            i = index(file, '\', back=.true.)
        end if
        
        if(i <= 0) then
            path = '.'
        else
            path = file(1:i)
        end if
    
    end subroutine path_from_file
    
    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)::c_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, tmp_prefix
        integer::res
        character(len=4, kind=c_char), target::prefix
        
        tmp_path = c_malloc(int(1024, kind=c_size_t))
        if(.not. associated(temporary_directory)) then
            res = GetTempPath(1023, tmp_path)
        else
            tmp_path = c_loc(temporary_directory)
        end if
        
        tmp_name = c_malloc(int(1024, kind=c_size_t))
        prefix = "lev"//c_null_char
        res = GetTempFileName(tmp_path, c_loc(prefix), 0, tmp_name)
        
        if(.not.associated(temporary_directory)) then
            call c_free(tmp_path)
        end if
        
        ! 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)
        if(associated(temporary_directory)) then
            if(temporary_directory(len(temporary_directory):len(temporary_directory)) == "/") then
                fullpath = temporary_directory//"lv."//trim(adjustl(num_text))//".tmp"
            else 
                fullpath = temporary_directory//"/lv."//trim(adjustl(num_text))//".tmp"
            end if
        else
            fullpath = "/tmp/lv."//trim(adjustl(num_text))//".tmp"
        end if
    
        !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
        logical::skip_first
        
        tempfile => generate_temporary_filename()
        res => null()

        skip_first = .FALSE.
        
#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.
            else if(line(1:6) == "total ") then
                skip_first = .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
            if(skip_first) then
                j = 1
            else
                j = 0
            end if
            
            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
    
    subroutine get_one_line_output_shell_command(cmd, output, retcode)
    implicit none
    
        character(*), intent(in)::cmd
        character(*), intent(out)::output
        integer, intent(out), optional::retcode
        
        integer::internal_retcode, ierr, unum
        character(len=:), pointer::tempfilename
        
        tempfilename => generate_temporary_filename()
        call execute_command_line(trim(cmd)//" > "//trim(tempfilename), &
                                  wait=.true., &
                                  exitstat=internal_retcode)
        
        if(present(retcode)) then
            retcode = internal_retcode
        end if
        
        open(newunit=unum, file=tempfilename, status="old", iostat=ierr)
        if(ierr == 0) then
            read(unum, '(A)') output
            close(unum)
        end if
        
        call unlink(tempfilename)
        deallocate(tempfilename)
    
    end subroutine get_one_line_output_shell_command
    
    subroutine toupper(str)
    implicit none
    
        character(*), intent(inout)::str
        integer::i
        
        interface
            function toupper_c(c) bind(c, name="toupper")
            use iso_c_binding
            integer(kind=c_int), value::c
            integer(kind=c_int)::toupper_c
            end function toupper_c
        end interface
        
        do i=1, len_trim(str)
            str(i:i) = char(toupper_c(IACHAR(str(i:i))))
        end do
        
    end subroutine toupper
    
    subroutine echo_file_stdout(filename)
    implicit none
    
        character(*), intent(in)::filename
        
#ifdef WINDOWS
        call execute_command_line("type "//trim(filename), wait=.true.)
#else
        call execute_command_line("cat "//trim(filename), wait=.true.)
#endif

    end subroutine echo_file_stdout
    
    function build_date()
    implicit none
    
        character(64)::build_date
        
        build_date = __DATE__
        
    end function build_date
    
end module utilities