diff options
Diffstat (limited to 'src/cepis_strings.f90')
| -rw-r--r-- | src/cepis_strings.f90 | 347 |
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 |