diff options
Diffstat (limited to 'src/cepis_json.f90')
| -rw-r--r-- | src/cepis_json.f90 | 635 |
1 files changed, 635 insertions, 0 deletions
diff --git a/src/cepis_json.f90 b/src/cepis_json.f90 new file mode 100644 index 0000000..b7be02e --- /dev/null +++ b/src/cepis_json.f90 @@ -0,0 +1,635 @@ +!> A small, strict JSON reader. +!> +!> Fortran ships no JSON parser, so this is hand-written. It is a complete +!> RFC 8259 reader for the shapes the API produces: objects, arrays, strings +!> with `\u` escapes and surrogate pairs, numbers, `true`, `false` and `null`. +!> +!> Values live in one growable array inside a `json_document` and are referred +!> to by integer index. That keeps the type free of recursive allocatable +!> components, and it means no reference into the document can dangle when the +!> array grows during parsing. +module cepis_json + use, intrinsic :: iso_fortran_env, only: real64, int64 + use cepis_strings, only: string_buffer, from_real, from_integer, parse_real, utf8_encode + implicit none + private + + character, parameter :: BACKSLASH = char(92) + + integer, parameter, public :: JSON_NULL = 0 + integer, parameter, public :: JSON_BOOL = 1 + integer, parameter, public :: JSON_NUMBER = 2 + integer, parameter, public :: JSON_STRING = 3 + integer, parameter, public :: JSON_ARRAY = 4 + integer, parameter, public :: JSON_OBJECT = 5 + + !> One `"name": value` pair of an object. + type, public :: json_member + character(len=:), allocatable :: name + integer :: node = 0 + end type json_member + + !> One JSON value. + type, public :: json_node + integer :: kind = JSON_NULL + character(len=:), allocatable :: text + real(real64) :: number = 0.0_real64 + logical :: truth = .false. + type(json_member), allocatable :: members(:) + integer, allocatable :: items(:) + end type json_node + + !> A parsed document. `root` indexes the top-level value. + type, public :: json_document + type(json_node), allocatable :: nodes(:) + integer :: used = 0 + integer :: root = 0 + contains + !> The kind of a node; `JSON_NULL` for an index of zero. + procedure :: kind_of + !> Index of the value of `name` inside object `node`, or zero. + procedure :: member + !> `.true.` when object `node` carries `name`. + procedure :: has + !> A node as text. Numbers and booleans are rendered; other kinds and + !> a zero index give the empty string, never a failure. + procedure :: text_of + !> A node as a floating-point value; zero when it is not a number. + procedure :: number_of + !> A node as an integer; zero when it is not a number. + procedure :: integer_of + !> `text_of` applied to a named member of an object. + procedure :: field_text + !> `number_of` applied to a named member of an object. + procedure :: field_number + !> `integer_of` applied to a named member of an object. + procedure :: field_integer + end type json_document + + public :: json_parse + +contains + + !> Parse `text`. On failure `ok` is `.false.` and `message` says why. + subroutine json_parse(text, doc, ok, message) + character(len=*), intent(in) :: text + type(json_document), intent(out) :: doc + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + integer :: pos + + message = '' + pos = 1 + call skip_space(text, pos) + call parse_value(doc, text, pos, doc%root, ok, message) + if (.not. ok) return + call skip_space(text, pos) + if (pos <= len(text)) then + ok = .false. + message = 'trailing characters after the JSON value' + end if + end subroutine json_parse + + pure function kind_of(self, node) result(kind) + class(json_document), intent(in) :: self + integer, intent(in) :: node + integer :: kind + + if (node <= 0 .or. node > self%used) then + kind = JSON_NULL + else + kind = self%nodes(node)%kind + end if + end function kind_of + + pure function member(self, node, name) result(index) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + integer :: index, i + + index = 0 + if (self%kind_of(node) /= JSON_OBJECT) return + if (.not. allocated(self%nodes(node)%members)) return + do i = 1, size(self%nodes(node)%members) + if (self%nodes(node)%members(i)%name == name) then + index = self%nodes(node)%members(i)%node + return + end if + end do + end function member + + pure function has(self, node, name) result(yes) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + logical :: yes + + yes = self%member(node, name) /= 0 + end function has + + pure function text_of(self, node) result(text) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=:), allocatable :: text + + text = '' + select case (self%kind_of(node)) + case (JSON_STRING) + if (allocated(self%nodes(node)%text)) text = self%nodes(node)%text + case (JSON_NUMBER) + if (abs(self%nodes(node)%number - aint(self%nodes(node)%number)) < & + 1.0e-9_real64 .and. abs(self%nodes(node)%number) < 1.0e15_real64) then + text = from_integer(int(self%nodes(node)%number, int64)) + else + text = from_real(self%nodes(node)%number) + end if + case (JSON_BOOL) + if (self%nodes(node)%truth) then + text = 'true' + else + text = 'false' + end if + end select + end function text_of + + pure function number_of(self, node) result(value) + class(json_document), intent(in) :: self + integer, intent(in) :: node + real(real64) :: value + + value = 0.0_real64 + if (self%kind_of(node) == JSON_NUMBER) value = self%nodes(node)%number + end function number_of + + pure function integer_of(self, node) result(value) + class(json_document), intent(in) :: self + integer, intent(in) :: node + integer(int64) :: value + + value = 0_int64 + if (self%kind_of(node) == JSON_NUMBER) then + value = int(self%nodes(node)%number, int64) + end if + end function integer_of + + pure function field_text(self, node, name) result(text) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + character(len=:), allocatable :: text + + text = self%text_of(self%member(node, name)) + end function field_text + + pure function field_number(self, node, name) result(value) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + real(real64) :: value + + value = self%number_of(self%member(node, name)) + end function field_number + + pure function field_integer(self, node, name) result(value) + class(json_document), intent(in) :: self + integer, intent(in) :: node + character(len=*), intent(in) :: name + integer(int64) :: value + + value = self%integer_of(self%member(node, name)) + end function field_integer + + subroutine new_node(doc, index) + type(json_document), intent(inout) :: doc + integer, intent(out) :: index + type(json_node), allocatable :: bigger(:) + + if (.not. allocated(doc%nodes)) allocate (doc%nodes(16)) + if (doc%used >= size(doc%nodes)) then + allocate (bigger(2*size(doc%nodes))) + bigger(1:doc%used) = doc%nodes(1:doc%used) + call move_alloc(bigger, doc%nodes) + end if + doc%used = doc%used + 1 + index = doc%used + end subroutine new_node + + pure subroutine skip_space(text, pos) + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + + do while (pos <= len(text)) + select case (text(pos:pos)) + case (' ', char(9), char(10), char(13)) + pos = pos + 1 + case default + return + end select + end do + end subroutine skip_space + + recursive subroutine parse_value(doc, text, pos, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + + node = 0 + ok = .false. + message = '' + + call skip_space(text, pos) + if (pos > len(text)) then + message = 'unexpected end of input' + return + end if + + select case (text(pos:pos)) + case ('{') + call parse_object(doc, text, pos, node, ok, message) + case ('[') + call parse_array(doc, text, pos, node, ok, message) + case ('"') + block + character(len=:), allocatable :: value + call parse_string(text, pos, value, ok, message) + if (.not. ok) return + call new_node(doc, node) + doc%nodes(node)%kind = JSON_STRING + doc%nodes(node)%text = value + end block + case ('t') + call parse_literal(doc, text, pos, 'true', node, ok, message) + case ('f') + call parse_literal(doc, text, pos, 'false', node, ok, message) + case ('n') + call parse_literal(doc, text, pos, 'null', node, ok, message) + case default + call parse_number(doc, text, pos, node, ok, message) + end select + end subroutine parse_value + + subroutine parse_literal(doc, text, pos, word, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + character(len=*), intent(in) :: word + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + + node = 0 + ok = .false. + message = '' + if (pos + len(word) - 1 > len(text)) then + message = 'truncated literal' + return + end if + if (text(pos:pos + len(word) - 1) /= word) then + message = 'unknown literal at position '//from_integer(int(pos, int64)) + return + end if + pos = pos + len(word) + + call new_node(doc, node) + select case (word) + case ('true') + doc%nodes(node)%kind = JSON_BOOL + doc%nodes(node)%truth = .true. + case ('false') + doc%nodes(node)%kind = JSON_BOOL + doc%nodes(node)%truth = .false. + case default + doc%nodes(node)%kind = JSON_NULL + end select + ok = .true. + end subroutine parse_literal + + subroutine parse_number(doc, text, pos, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + integer :: first + real(real64) :: value + + node = 0 + ok = .false. + message = '' + first = pos + + if (text(pos:pos) == '-') pos = pos + 1 + do while (pos <= len(text)) + select case (text(pos:pos)) + case ('0':'9', '.', 'e', 'E', '+', '-') + pos = pos + 1 + case default + exit + end select + end do + + if (pos == first) then + message = 'unexpected character '''//text(pos:pos)//'''' + return + end if + + call parse_real(text(first:pos - 1), value, ok) + if (.not. ok) then + message = 'malformed number '''//text(first:pos - 1)//'''' + return + end if + + call new_node(doc, node) + doc%nodes(node)%kind = JSON_NUMBER + doc%nodes(node)%number = value + end subroutine parse_number + + subroutine parse_string(text, pos, value, ok, message) + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + character(len=:), allocatable, intent(out) :: value + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + type(string_buffer) :: out + integer :: code, low + logical :: got + + value = '' + ok = .false. + message = '' + pos = pos + 1 + + do + if (pos > len(text)) then + message = 'unterminated string' + return + end if + + if (text(pos:pos) == '"') then + pos = pos + 1 + value = out%text() + ok = .true. + return + else if (text(pos:pos) /= BACKSLASH) then + call out%append(text(pos:pos)) + pos = pos + 1 + cycle + end if + + pos = pos + 1 + if (pos > len(text)) then + message = 'unterminated escape' + return + end if + + select case (text(pos:pos)) + case ('"') + call out%append('"') + case (BACKSLASH) + call out%append(BACKSLASH) + case ('/') + call out%append('/') + case ('b') + call out%append(char(8)) + case ('f') + call out%append(char(12)) + case ('n') + call out%append(char(10)) + case ('r') + call out%append(char(13)) + case ('t') + call out%append(char(9)) + case ('u') + call read_hex4(text, pos + 1, code, got) + if (.not. got) then + message = 'malformed unicode escape' + return + end if + pos = pos + 4 + if (code >= 55296 .and. code <= 56319) then + if (pos + 6 <= len(text)) then + if (text(pos + 1:pos + 1) == BACKSLASH .and. & + text(pos + 2:pos + 2) == 'u') then + call read_hex4(text, pos + 3, low, got) + if (got .and. low >= 56320 .and. low <= 57343) then + code = 65536 + (code - 55296)*1024 + & + (low - 56320) + pos = pos + 6 + end if + end if + end if + end if + call out%append(utf8_encode(code)) + case default + message = 'unknown escape sequence' + return + end select + pos = pos + 1 + end do + end subroutine parse_string + + pure subroutine read_hex4(text, at, code, ok) + character(len=*), intent(in) :: text + integer, intent(in) :: at + integer, intent(out) :: code + logical, intent(out) :: ok + integer :: i, digit + + code = 0 + ok = .false. + if (at + 3 > len(text)) return + do i = at, at + 3 + select case (text(i:i)) + case ('0':'9') + digit = iachar(text(i:i)) - 48 + case ('a':'f') + digit = iachar(text(i:i)) - 87 + case ('A':'F') + digit = iachar(text(i:i)) - 55 + case default + return + end select + code = code*16 + digit + end do + ok = .true. + end subroutine read_hex4 + + recursive subroutine parse_array(doc, text, pos, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + integer, allocatable :: items(:), bigger(:) + integer :: count, child + + node = 0 + ok = .false. + message = '' + allocate (items(8)) + count = 0 + pos = pos + 1 + + call skip_space(text, pos) + if (pos <= len(text)) then + if (text(pos:pos) == ']') then + pos = pos + 1 + call finish_array(doc, items, count, node) + ok = .true. + return + end if + end if + + do + call parse_value(doc, text, pos, child, ok, message) + if (.not. ok) return + if (count >= size(items)) then + allocate (bigger(2*size(items))) + bigger(1:count) = items(1:count) + call move_alloc(bigger, items) + end if + count = count + 1 + items(count) = child + + call skip_space(text, pos) + if (pos > len(text)) then + ok = .false. + message = 'unterminated array' + return + end if + if (text(pos:pos) == ',') then + pos = pos + 1 + cycle + else if (text(pos:pos) == ']') then + pos = pos + 1 + call finish_array(doc, items, count, node) + ok = .true. + return + else + ok = .false. + message = 'expected '','' or '']'' in array' + return + end if + end do + end subroutine parse_array + + subroutine finish_array(doc, items, count, node) + type(json_document), intent(inout) :: doc + integer, intent(in) :: items(:) + integer, intent(in) :: count + integer, intent(out) :: node + + call new_node(doc, node) + doc%nodes(node)%kind = JSON_ARRAY + allocate (doc%nodes(node)%items(count)) + if (count > 0) doc%nodes(node)%items = items(1:count) + end subroutine finish_array + + recursive subroutine parse_object(doc, text, pos, node, ok, message) + type(json_document), intent(inout) :: doc + character(len=*), intent(in) :: text + integer, intent(inout) :: pos + integer, intent(out) :: node + logical, intent(out) :: ok + character(len=:), allocatable, intent(out) :: message + type(json_member), allocatable :: members(:), bigger(:) + character(len=:), allocatable :: name + integer :: count, child + + node = 0 + ok = .false. + message = '' + allocate (members(8)) + count = 0 + pos = pos + 1 + + call skip_space(text, pos) + if (pos <= len(text)) then + if (text(pos:pos) == '}') then + pos = pos + 1 + call finish_object(doc, members, count, node) + ok = .true. + return + end if + end if + + do + call skip_space(text, pos) + if (pos > len(text)) then + message = 'unterminated object' + return + end if + if (text(pos:pos) /= '"') then + message = 'expected a string key in object' + return + end if + + call parse_string(text, pos, name, ok, message) + if (.not. ok) return + + call skip_space(text, pos) + if (pos > len(text)) then + ok = .false. + message = 'unterminated object' + return + end if + if (text(pos:pos) /= ':') then + ok = .false. + message = 'expected '':'' after key '''//name//'''' + return + end if + pos = pos + 1 + + call parse_value(doc, text, pos, child, ok, message) + if (.not. ok) return + + if (count >= size(members)) then + allocate (bigger(2*size(members))) + bigger(1:count) = members(1:count) + call move_alloc(bigger, members) + end if + count = count + 1 + members(count)%name = name + members(count)%node = child + + call skip_space(text, pos) + if (pos > len(text)) then + ok = .false. + message = 'unterminated object' + return + end if + if (text(pos:pos) == ',') then + pos = pos + 1 + cycle + else if (text(pos:pos) == '}') then + pos = pos + 1 + call finish_object(doc, members, count, node) + ok = .true. + return + else + ok = .false. + message = 'expected '','' or ''}'' in object' + return + end if + end do + end subroutine parse_object + + subroutine finish_object(doc, members, count, node) + type(json_document), intent(inout) :: doc + type(json_member), intent(in) :: members(:) + integer, intent(in) :: count + integer, intent(out) :: node + + call new_node(doc, node) + doc%nodes(node)%kind = JSON_OBJECT + allocate (doc%nodes(node)%members(count)) + if (count > 0) doc%nodes(node)%members = members(1:count) + end subroutine finish_object + +end module cepis_json |