diff --git a/src/sourcery/sourcery_string_m.f90 b/src/sourcery/sourcery_string_m.f90 index 34c4ab9d..0c3b0b3f 100644 --- a/src/sourcery/sourcery_string_m.f90 +++ b/src/sourcery/sourcery_string_m.f90 @@ -1,16 +1,25 @@ module sourcery_string_m + use assert_m, only : characterizable_t implicit none private public :: string_t public :: array_of_strings - type string_t + type, extends(characterizable_t) :: string_t private character(len=:), allocatable :: string_ contains - procedure :: string + procedure :: as_character + generic :: string => as_character procedure :: is_allocated + procedure :: get_json_key + procedure, private :: & + get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real + generic :: get_json_value => & + get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real + procedure, private :: equivalent + generic :: operator(==) => equivalent end type interface string_t @@ -25,7 +34,7 @@ elemental module function construct(string) result(new_string) interface - pure module function string(self) result(raw_string) + pure module function as_character(self) result(raw_string) implicit none class(string_t), intent(in) :: self character(len=:), allocatable :: raw_string @@ -43,6 +52,52 @@ elemental module function is_allocated(self) result(string_allocated) logical string_allocated end function + elemental module function get_json_key(self) result(unquoted_key) + implicit none + class(string_t), intent(in) :: self + type(string_t) unquoted_key + end function + + elemental module function get_json_real(self, key, mold) result(value_) + implicit none + class(string_t), intent(in) :: self, key + real, intent(in) :: mold + real value_ + end function + + elemental module function get_json_string(self, key, mold) result(value_) + implicit none + class(string_t), intent(in) :: self, key, mold + type(string_t) :: value_ + end function + + elemental module function get_json_integer(self, key, mold) result(value_) + implicit none + class(string_t), intent(in) :: self, key + integer, intent(in) :: mold + integer value_ + end function + + elemental module function get_json_logical(self, key, mold) result(value_) + implicit none + class(string_t), intent(in) :: self, key + logical, intent(in) :: mold + logical value_ + end function + + pure module function get_json_integer_array(self, key, mold) result(value_) + implicit none + class(string_t), intent(in) :: self, key + integer, intent(in) :: mold(:) + integer, allocatable :: value_(:) + end function + + elemental module function equivalent(lhs, rhs) result(lhs_eqv_rhs) + implicit none + class(string_t), intent(in) :: lhs, rhs + logical lhs_eqv_rhs + end function + end interface end module sourcery_string_m diff --git a/src/sourcery/sourcery_string_s.f90 b/src/sourcery/sourcery_string_s.f90 index dc7dcfc2..c72f263c 100644 --- a/src/sourcery/sourcery_string_s.f90 +++ b/src/sourcery/sourcery_string_s.f90 @@ -1,4 +1,6 @@ submodule(sourcery_string_m) sourcery_string_s + use assert_m, only : assert + use sourcery_m, only : csv implicit none contains @@ -7,7 +9,7 @@ new_string%string_ = string end procedure - module procedure string + module procedure as_character raw_string = self%string_ end procedure @@ -37,4 +39,124 @@ end procedure + module procedure get_json_key + character(len=:), allocatable :: raw_line + + raw_line = self%string() + associate(opening_key_quotes => index(raw_line, '"'), separator => index(raw_line, ':')) + associate(closing_key_quotes => opening_key_quotes + index(raw_line(opening_key_quotes+1:), '"')) + unquoted_key = string_t(trim(raw_line(opening_key_quotes+1:closing_key_quotes-1))) + end associate + end associate + + end procedure + + module procedure get_json_real + character(len=:), allocatable :: raw_line, string_value + + call assert(key==self%get_json_key(), "string_s(get_json_real): key==self%get_json_key()", key) + + raw_line = self%string() + associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) + associate(trailing_comma => index(text_after_colon, ',')) + if (trailing_comma == 0) then + string_value = trim(adjustl((text_after_colon))) + else + string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) + end if + read(string_value, fmt=*) value_ + end associate + end associate + + end procedure + + module procedure get_json_string + + character(len=:), allocatable :: raw_line + + call assert(key==self%get_json_key(), "key==self%get_string_json()", key) + + raw_line = self%string() + associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) + associate(opening_value_quotes => index(text_after_colon, '"')) + associate(closing_value_quotes => opening_value_quotes + index(text_after_colon(opening_value_quotes+1:), '"')) + if (any([opening_value_quotes, closing_value_quotes] == 0)) then + value_ = string_t(trim(adjustl((text_after_colon)))) + else + value_ = string_t(text_after_colon(opening_value_quotes+1:closing_value_quotes-1)) + end if + end associate + end associate + end associate + + end procedure + + module procedure get_json_logical + character(len=:), allocatable :: raw_line, string_value + + call assert(key==self%get_json_key(), "string_s(get_json_logical): key==self%get_json_key()", key) + + raw_line = self%string() + associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) + associate(trailing_comma => index(text_after_colon, ',')) + if (trailing_comma == 0) then + string_value = trim(adjustl((text_after_colon))) + else + string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) + end if + call assert(string_value=="true" .or. string_value=="false", & + 'string_s(get_json_logical): string_value=="true" .or. string_value="false"', string_value) + value_ = string_value == "true" + end associate + end associate + + end procedure + + module procedure get_json_integer + character(len=:), allocatable :: raw_line, string_value + + call assert(key==self%get_json_key(), "string_s(get_json_logical): key==self%get_json_key()", key) + + raw_line = self%string() + associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) + associate(trailing_comma => index(text_after_colon, ',')) + if (trailing_comma == 0) then + string_value = trim(adjustl((text_after_colon))) + else + string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) + end if + read(string_value, fmt=*) value_ + end associate + end associate + + end procedure + + module procedure get_json_integer_array + character(len=:), allocatable :: raw_line + real, allocatable :: real_array(:) + integer i + + call assert(key==self%get_json_key(), "string_s(get_json_integer_array): key==self%get_json_key()", key) + + raw_line = self%string() + associate(colon => index(raw_line, ":")) + associate(opening_bracket => colon + index(raw_line(colon+1:), "[")) + associate(closing_bracket => opening_bracket + index(raw_line(opening_bracket+1:), "]")) + associate(commas => count("," == [(raw_line(i:i), i=opening_bracket+1,closing_bracket-1)])) + associate(num_inputs => commas + 1) + allocate(real_array(num_inputs)) + read(raw_line(opening_bracket+1:closing_bracket-1), fmt=*) real_array + value_ = int(real_array) + end associate + end associate + end associate + end associate + end associate + + end procedure + + module procedure equivalent + lhs_eqv_rhs = lhs%string() == rhs%string() + end procedure + end submodule sourcery_string_s diff --git a/test/string_test.f90 b/test/string_test.f90 index 0d78037e..763e7127 100644 --- a/test/string_test.f90 +++ b/test/string_test.f90 @@ -2,6 +2,7 @@ module string_test_m use sourcery_m, only : test_t, test_result_t, string_t implicit none + private public :: string_test_t @@ -22,7 +23,13 @@ function results() result(test_results) type(test_result_t), allocatable :: test_results(:) test_results = [ & - test_result_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation()) & + test_result_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation()), & + test_result_t("extracting a key string from a colon-separated key/value pair", extracts_key()), & + test_result_t("extracting a real value from a colon-separated key/value pair", extracts_real_value()), & + test_result_t("extracting a string value from a colon-separated key/value pair", extracts_string_value()), & + test_result_t("extracting a logical value from a colon-separated key/value pair", extracts_logical_value()), & + test_result_t("extracting an integer array value from a colon-separated key/value pair", extracts_integer_array_value()), & + test_result_t("extracting an integer value from a colon-separated key/value pair", extracts_integer_value()) & ] end function @@ -36,4 +43,64 @@ pure function check_allocation() result(passed) (all([scalar_allocated%is_allocated(), array_allocated%is_allocated()])) end function + function extracts_key() result(passed) + logical passed + + associate(line => string_t('"foo" : "bar"')) + passed = line%get_json_key() == string_t("foo") + end associate + end function + + function extracts_real_value() result(passed) + logical passed + + associate(line => string_t('"pi" : 3.14159')) + passed = line%get_json_value(key=string_t("pi"), mold=2.71828) == 3.14159 + end associate + end function + + function extracts_string_value() result(passed) + logical passed + + associate(line => string_t('"foo" : "bar"')) + passed = line%get_json_value(key=string_t("foo"), mold=string_t("")) == string_t("bar") + end associate + end function + + function extracts_integer_value() result(passed) + logical passed + + associate(line => string_t('"an integer" : 99')) + passed = line%get_json_value(key=string_t("an integer"), mold=0) == 99 + end associate + end function + + function extracts_logical_value() result(passed) + logical passed + + associate( & + key_true_pair => string_t('"yada yada" : true'), & + key_false_pair => string_t('"blah blah" : false'), & + trailing_comma => string_t('"trailing comma" : true,') & + ) + associate( & + true => key_true_pair%get_json_value(key=string_t("yada yada"), mold=.true.), & + false => key_false_pair%get_json_value(key=string_t("blah blah"), mold=.true.), & + true_too => trailing_comma%get_json_value(key=string_t("trailing comma"), mold=.true.) & + ) + passed = true .and. true_too .and. .not. false + end associate + end associate + end function + + function extracts_integer_array_value() result(passed) + logical passed + + associate(key_integer_array_pair => string_t('"some key" : [1, 2, 3],')) + associate(integer_array => key_integer_array_pair%get_json_value(key=string_t("some key"), mold=[integer::])) + passed = all(integer_array == [1, 2, 3]) + end associate + end associate + end function + end module string_test_m