path: root/src/cepis_strings.f90

!> String helpers shared by the parsers and the HTTP layer.
!>
!> Every routine here works with `character(len=:), allocatable` values rather
!> than fixed-length buffers. A fixed buffer truncates silently, and a truncated
!> `logradouro` is a wrong answer that looks like a right one.
module cepis_strings
    use, intrinsic :: iso_c_binding
    use, intrinsic :: iso_fortran_env, only: real64, int64
    implicit none
    private

    public :: string_buffer
    public :: strip
    public :: lower
    public :: starts_with
    public :: is_digits
    public :: parse_real
    public :: parse_integer
    public :: from_integer
    public :: from_real
    public :: url_encode
    public :: to_c_chars
    public :: from_c_string
    public :: utf8_encode

    integer, parameter :: SCAN_LIMIT = 1073741823

    !> A growing character buffer.
    !>
    !> Capacity doubles, so appending a response chunk by chunk stays linear
    !> instead of copying the whole body on every append.
    type :: string_buffer
        character(len=:), allocatable, private :: store
        integer, private :: used = 0
    contains
        !> Append a chunk.
        procedure :: append => buffer_append
        !> The contents so far, exactly `size()` characters long.
        procedure :: text => buffer_text
        !> How many characters are held.
        procedure :: size => buffer_size
        !> Drop the contents, keeping the capacity.
        procedure :: reset => buffer_reset
    end type string_buffer

contains

    subroutine buffer_append(self, chunk)
        class(string_buffer), intent(inout) :: self
        character(len=*), intent(in) :: chunk
        character(len=:), allocatable :: bigger
        integer :: needed, capacity

        if (len(chunk) == 0) return
        if (.not. allocated(self%store)) then
            allocate (character(len=max(128, len(chunk))) :: self%store)
            self%used = 0
        end if

        needed = self%used + len(chunk)
        if (needed > len(self%store)) then
            capacity = max(2*len(self%store), needed)
            allocate (character(len=capacity) :: bigger)
            if (self%used > 0) bigger(1:self%used) = self%store(1:self%used)
            call move_alloc(bigger, self%store)
        end if

        self%store(self%used + 1:needed) = chunk
        self%used = needed
    end subroutine buffer_append

    pure function buffer_text(self) result(text)
        class(string_buffer), intent(in) :: self
        character(len=:), allocatable :: text

        if (.not. allocated(self%store) .or. self%used <= 0) then
            text = ''
        else
            text = self%store(1:self%used)
        end if
    end function buffer_text

    pure function buffer_size(self) result(n)
        class(string_buffer), intent(in) :: self
        integer :: n

        n = self%used
    end function buffer_size

    subroutine buffer_reset(self)
        class(string_buffer), intent(inout) :: self

        self%used = 0
    end subroutine buffer_reset

    !> Remove leading and trailing blanks, tabs, carriage returns and newlines.
    pure function strip(text) result(out)
        character(len=*), intent(in) :: text
        character(len=:), allocatable :: out
        integer :: first, last

        first = 1
        last = len(text)
        do while (first <= last)
            if (.not. is_space(text(first:first))) exit
            first = first + 1
        end do
        do while (last >= first)
            if (.not. is_space(text(last:last))) exit
            last = last - 1
        end do

        if (first > last) then
            out = ''
        else
            out = text(first:last)
        end if
    end function strip

    pure function is_space(ch) result(yes)
        character, intent(in) :: ch
        logical :: yes

        yes = ch == ' ' .or. ch == char(9) .or. ch == char(10) .or. &
              ch == char(13) .or. ch == char(11) .or. ch == char(12)
    end function is_space

    !> ASCII lowercase. The values in the API are UTF-8 and are left alone;
    !> this is only used on header names, which are ASCII by RFC 9110.
    pure function lower(text) result(out)
        character(len=*), intent(in) :: text
        character(len=:), allocatable :: out
        integer :: i, code

        out = text
        do i = 1, len(out)
            code = iachar(out(i:i))
            if (code >= 65 .and. code <= 90) out(i:i) = achar(code + 32)
        end do
    end function lower

    !> `.true.` when `text` begins with `prefix`.
    pure function starts_with(text, prefix) result(yes)
        character(len=*), intent(in) :: text
        character(len=*), intent(in) :: prefix
        logical :: yes

        yes = len(text) >= len(prefix)
        if (yes) yes = text(1:len(prefix)) == prefix
    end function starts_with

    !> `.true.` when `text` is one or more ASCII digits and nothing else.
    pure function is_digits(text) result(yes)
        character(len=*), intent(in) :: text
        logical :: yes
        integer :: i, code

        yes = len(text) > 0
        do i = 1, len(text)
            code = iachar(text(i:i))
            if (code < 48 .or. code > 57) then
                yes = .false.
                return
            end if
        end do
    end function is_digits

    !> Read a decimal number. `ok` is `.false.` when `text` is not one.
    subroutine parse_real(text, value, ok)
        character(len=*), intent(in) :: text
        real(real64), intent(out) :: value
        logical, intent(out) :: ok
        character(len=:), allocatable :: token
        integer :: ios, i, code
        logical :: seen_digit

        value = 0.0_real64
        ok = .false.
        token = strip(text)
        if (len(token) == 0) return

        seen_digit = .false.
        do i = 1, len(token)
            code = iachar(token(i:i))
            if (code >= 48 .and. code <= 57) then
                seen_digit = .true.
            else if (token(i:i) == '+' .or. token(i:i) == '-' .or. &
                     token(i:i) == '.' .or. token(i:i) == 'e' .or. &
                     token(i:i) == 'E') then
                cycle
            else
                return
            end if
        end do
        if (.not. seen_digit) return

        read (token, *, iostat=ios) value
        ok = ios == 0
        if (.not. ok) value = 0.0_real64
    end subroutine parse_real

    !> Read a decimal integer. `ok` is `.false.` when `text` is not one.
    subroutine parse_integer(text, value, ok)
        character(len=*), intent(in) :: text
        integer(int64), intent(out) :: value
        logical, intent(out) :: ok
        character(len=:), allocatable :: token
        integer :: ios

        value = 0_int64
        ok = .false.
        token = strip(text)
        if (len(token) == 0) return
        if (token(1:1) == '+' .or. token(1:1) == '-') then
            if (.not. is_digits(token(2:))) return
        else if (.not. is_digits(token)) then
            return
        end if

        read (token, *, iostat=ios) value
        ok = ios == 0
        if (.not. ok) value = 0_int64
    end subroutine parse_integer

    !> Decimal text for an integer, without the padding `write` would leave.
    pure function from_integer(value) result(text)
        integer(int64), intent(in) :: value
        character(len=:), allocatable :: text
        character(len=32) :: scratch

        write (scratch, '(I0)') value
        text = trim(scratch)
    end function from_integer

    !> Decimal text for a floating-point value, trailing zeros removed.
    pure function from_real(value) result(text)
        real(real64), intent(in) :: value
        character(len=:), allocatable :: text
        character(len=32) :: scratch
        integer :: i

        write (scratch, '(F0.6)') value
        text = trim(scratch)
        if (index(text, '.') > 0) then
            i = len(text)
            do while (i > 1)
                if (text(i:i) /= '0') exit
                i = i - 1
            end do
            if (text(i:i) == '.') i = i - 1
            text = text(1:i)
        end if
        if (starts_with(text, '.')) text = '0'//text
        if (starts_with(text, '-.')) text = '-0'//text(2:)
    end function from_real

    !> Percent-encode everything outside the RFC 3986 unreserved set.
    pure function url_encode(text) result(out)
        character(len=*), intent(in) :: text
        character(len=:), allocatable :: out
        character(len=*), parameter :: hex = '0123456789ABCDEF'
        integer :: i, code

        out = ''
        do i = 1, len(text)
            code = iachar(text(i:i))
            if ((code >= 48 .and. code <= 57) .or. &
                (code >= 65 .and. code <= 90) .or. &
                (code >= 97 .and. code <= 122) .or. &
                text(i:i) == '-' .or. text(i:i) == '_' .or. &
                text(i:i) == '.' .or. text(i:i) == '~') then
                out = out//text(i:i)
            else
                out = out//'%'//hex(code/16 + 1:code/16 + 1)// &
                      hex(mod(code, 16) + 1:mod(code, 16) + 1)
            end if
        end do
    end function url_encode

    !> A NUL-terminated `c_char` array, suitable for `c_loc` and libcurl.
    !>
    !> An array rather than a deferred-length scalar because `c_loc` rejects
    !> anything carrying a length type parameter.
    pure function to_c_chars(text) result(out)
        character(len=*), intent(in) :: text
        character(kind=c_char), allocatable :: out(:)
        integer :: i

        allocate (out(len(text) + 1))
        do i = 1, len(text)
            out(i) = text(i:i)
        end do
        out(len(text) + 1) = c_null_char
    end function to_c_chars

    !> Copy a C string into a Fortran string. An empty string for `NULL`.
    function from_c_string(ptr) result(text)
        type(c_ptr), intent(in) :: ptr
        character(len=:), allocatable :: text
        character(kind=c_char), pointer :: chars(:)
        integer :: n

        text = ''
        if (.not. c_associated(ptr)) return
        call c_f_pointer(ptr, chars, [SCAN_LIMIT])
        n = 0
        do while (chars(n + 1) /= c_null_char)
            n = n + 1
            if (n >= SCAN_LIMIT - 1) exit
        end do
        if (n == 0) return
        allocate (character(len=n) :: text)
        block
            integer :: i
            do i = 1, n
                text(i:i) = chars(i)
            end do
        end block
    end function from_c_string

    !> Encode one Unicode code point as UTF-8 bytes.
    !>
    !> Used by the JSON reader for `\uXXXX` escapes. The API sends UTF-8
    !> directly, but a proxy or a re-encoder in the middle may not.
    pure function utf8_encode(code) result(bytes)
        integer, intent(in) :: code
        character(len=:), allocatable :: bytes

        if (code < 0 .or. code > 1114111) then
            bytes = char(239)//char(191)//char(189)
        else if (code < 128) then
            bytes = char(code)
        else if (code < 2048) then
            bytes = char(192 + code/64)//char(128 + mod(code, 64))
        else if (code < 65536) then
            bytes = char(224 + code/4096)// &
                    char(128 + mod(code/64, 64))// &
                    char(128 + mod(code, 64))
        else
            bytes = char(240 + code/262144)// &
                    char(128 + mod(code/4096, 64))// &
                    char(128 + mod(code/64, 64))// &
                    char(128 + mod(code, 64))
        end if
    end function utf8_encode

end module cepis_strings