Initial import

1 files changed, 347 insertions, 0 deletions

diff --git a/src/cepis_strings.f90 b/src/cepis_strings.f90
new file mode 100644
index 0000000..33b21dc
--- /dev/null
+++ b/src/cepis_strings.f90
@@ -0,0 +1,347 @@
+!> 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