Skip to content

Commit 4275a88

Browse files
jacobwilliamsjacobwilliams
committed
added routines to check for duplicate keys. See #250.
1 parent d1db8ed commit 4275a88

File tree

2 files changed

+330
-22
lines changed

2 files changed

+330
-22
lines changed

‎src/json_value_module.F90

Lines changed: 237 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -671,9 +671,16 @@ module json_value_module
671671
!! list is valid (i.e., is properly
672672
!! constructed). This may be useful
673673
!! if it has been constructed externally.
674+
procedure,public :: check_for_duplicate_keys &
675+
=> json_check_all_for_duplicate_keys !! Check entire JSON structure
676+
!! for duplicate keys (recursively)
677+
procedure,public :: check_children_for_duplicate_keys &
678+
=> json_check_children_for_duplicate_keys !! Check a `json_value` object's
679+
!! children for duplicate keys
674680

675681
!other private routines:
676682
procedure :: name_equal
683+
procedure :: name_strings_equal
677684
procedure :: json_value_print
678685
procedure :: string_to_int
679686
procedure :: string_to_dble
@@ -963,10 +970,13 @@ end subroutine json_initialize
963970

964971
!*****************************************************************************************
965972
!> author: Jacob Williams
966-
! date: 4/30/2016
967973
!
968974
! Returns true if `name` is equal to `p%name`, using the specified
969975
! settings for case sensitivity and trailing whitespace.
976+
!
977+
!### History
978+
! * 4/30/2016 : original version
979+
! * 8/25/2017 : now just a wrapper for [[name_strings_equal]]
970980

971981
function name_equal(json,p,name) result(is_equal)
972982

@@ -975,29 +985,51 @@ function name_equal(json,p,name) result(is_equal)
975985
class(json_core),intent(inout) :: json
976986
type(json_value),intent(in) :: p !! the json object
977987
character(kind=CK,len=*),intent(in) :: name !! the name to check for
978-
logical(LK) :: is_equal !! true if the string are lexically equal
988+
logical(LK) :: is_equal !! true if the string are
989+
!! lexically equal
979990

980991
if (allocated(p%name)) then
992+
! call the low-level routines for the name strings:
993+
is_equal = json%name_strings_equal(p%name,name)
994+
else
995+
is_equal = name == CK_'' ! check a blank name
996+
end if
981997

982-
!must be the same length if we are treating
983-
!trailing spaces as significant, so do a
984-
!quick test of this first:
985-
if (json%trailing_spaces_significant) then
986-
is_equal = len(p%name) == len(name)
987-
if (.not. is_equal) return
988-
end if
998+
end function name_equal
999+
!*****************************************************************************************
9891000

990-
if (json%case_sensitive_keys) then
991-
is_equal = p%name == name
992-
else
993-
is_equal = lowercase_string(p%name) == lowercase_string(name)
994-
end if
1001+
!*****************************************************************************************
1002+
!> author: Jacob Williams
1003+
! date: 8/25/2017
1004+
!
1005+
! Returns true if the name strings `name1` is equal to `name2`, using
1006+
! the specified settings for case sensitivity and trailing whitespace.
1007+
1008+
function name_strings_equal(json,name1,name2) result(is_equal)
1009+
1010+
implicit none
1011+
1012+
class(json_core),intent(inout) :: json
1013+
character(kind=CK,len=*),intent(in) :: name1 !! the name to check
1014+
character(kind=CK,len=*),intent(in) :: name2 !! the name to check
1015+
logical(LK) :: is_equal !! true if the string are
1016+
!! lexically equal
1017+
1018+
!must be the same length if we are treating
1019+
!trailing spaces as significant, so do a
1020+
!quick test of this first:
1021+
if (json%trailing_spaces_significant) then
1022+
is_equal = len(name1) == len(name2)
1023+
if (.not. is_equal) return
1024+
end if
9951025

1026+
if (json%case_sensitive_keys) then
1027+
is_equal = name1 == name2
9961028
else
997-
is_equal = name == CK_'' ! check a blank name
1029+
is_equal = lowercase_string(name1) == lowercase_string(name2)
9981030
end if
9991031

1000-
end function name_equal
1032+
end function name_strings_equal
10011033
!*****************************************************************************************
10021034

10031035
!*****************************************************************************************
@@ -4681,8 +4713,9 @@ subroutine json_value_get_child_by_name(json, p, name, child, found)
46814713
child => p%children !start with first one
46824714
do i=1, n_children
46834715
if (.not. associated(child)) then
4684-
call json%throw_exception('Error in json_value_get_child_by_name: '//&
4685-
'Malformed JSON linked list')
4716+
call json%throw_exception(&
4717+
'Error in json_value_get_child_by_name: '//&
4718+
'Malformed JSON linked list')
46864719
exit
46874720
end if
46884721
if (allocated(child%name)) then
@@ -4698,14 +4731,16 @@ subroutine json_value_get_child_by_name(json, p, name, child, found)
46984731

46994732
if (error) then
47004733
!did not find anything:
4701-
call json%throw_exception('Error in json_value_get_child_by_name: '//&
4702-
'child variable '//trim(name)//' was not found.')
4734+
call json%throw_exception(&
4735+
'Error in json_value_get_child_by_name: '//&
4736+
'child variable '//trim(name)//' was not found.')
47034737
nullify(child)
47044738
end if
47054739

47064740
else
4707-
call json%throw_exception('Error in json_value_get_child_by_name: '//&
4708-
'pointer is not associated.')
4741+
call json%throw_exception(&
4742+
'Error in json_value_get_child_by_name: '//&
4743+
'pointer is not associated.')
47094744
end if
47104745

47114746
! found output:
@@ -4725,6 +4760,186 @@ subroutine json_value_get_child_by_name(json, p, name, child, found)
47254760
end subroutine json_value_get_child_by_name
47264761
!*****************************************************************************************
47274762

4763+
!*****************************************************************************************
4764+
!> author: Jacob Williams
4765+
! date: 8/25/2017
4766+
!
4767+
! Checks a JSON object for duplicate child names.
4768+
!
4769+
! It uses the specified settings for name matching (see [[name_strings_equal]]).
4770+
!
4771+
!@note This will only check for one duplicate,
4772+
! it will return the first one that it finds.
4773+
4774+
subroutine json_check_children_for_duplicate_keys(json,p,has_duplicate,name,path)
4775+
4776+
implicit none
4777+
4778+
class(json_core),intent(inout) :: json
4779+
type(json_value),pointer,intent(in) :: p !! the object to search. If `p` is
4780+
!! not a `json_object`, then `has_duplicate`
4781+
!! will be false.
4782+
logical(LK),intent(out) :: has_duplicate !! true if there is at least
4783+
!! two children have duplicate
4784+
!! `name` values.
4785+
character(kind=CK,len=:),allocatable,intent(out),optional :: name !! the duplicate name
4786+
!! (unallocated if no
4787+
!! duplicate was found)
4788+
character(kind=CK,len=:),allocatable,intent(out),optional :: path !! the full path to the
4789+
!! duplicate name
4790+
!! (unallocated if no
4791+
!! duplicate was found)
4792+
4793+
integer(IK) :: i !! counter
4794+
integer(IK) :: j !! counter
4795+
type(json_value),pointer :: child !! pointer to a child of `p`
4796+
integer(IK) :: n_children !! number of children of `p`
4797+
logical(LK) :: found !! flag for `get_child`
4798+
4799+
type :: alloc_str
4800+
!! so we can have an array of allocatable strings
4801+
character(kind=CK,len=:),allocatable :: str !! name string
4802+
end type alloc_str
4803+
type(alloc_str),dimension(:),allocatable :: names !! array of all the
4804+
!! child name strings
4805+
4806+
! initialize:
4807+
has_duplicate =.false.
4808+
4809+
if (.not. json%exception_thrown) then
4810+
4811+
if (associated(p)) then
4812+
4813+
if (p%var_type==json_object) then
4814+
4815+
! number of items to check:
4816+
n_children = json%count(p)
4817+
allocate(names(n_children))
4818+
4819+
! first get a list of all the name keys:
4820+
do i=1, n_children
4821+
call json%get_child(p,i,child,found) ! get by index
4822+
if (.not. found) then
4823+
call json%throw_exception(&
4824+
'Error in json_check_children_for_duplicate_keys: '//&
4825+
'Malformed JSON linked list')
4826+
exit
4827+
end if
4828+
if (allocated(child%name)) then
4829+
names(i)%str = child%name
4830+
else
4831+
call json%throw_exception(&
4832+
'Error in json_check_children_for_duplicate_keys: '//&
4833+
'Object child name is not allocated')
4834+
exit
4835+
end if
4836+
end do
4837+
4838+
if (.not. json%exception_thrown) then
4839+
! now check the list for duplicates:
4840+
main: do i=1,n_children
4841+
do j=1,i-1
4842+
if (json%name_strings_equal(names(i)%str,names(j)%str)) then
4843+
has_duplicate = .true.
4844+
if (present(name)) then
4845+
name = names(i)%str
4846+
end if
4847+
if (present(path)) then
4848+
call json%get_child(p,names(i)%str,child,found) ! get by name
4849+
if (found) then
4850+
call json%get_path(child,path,found)
4851+
if (.not. found) then
4852+
! should never happen since we know it is there
4853+
call json%throw_exception(&
4854+
'Error in json_check_children_for_duplicate_keys: '//&
4855+
'Could not get path')
4856+
end if
4857+
else
4858+
! should never happen since we know it is there
4859+
call json%throw_exception(&
4860+
'Error in json_check_children_for_duplicate_keys: '//&
4861+
'Could not get child: '//trim(names(i)%str))
4862+
end if
4863+
end if
4864+
exit main
4865+
end if
4866+
end do
4867+
end do main
4868+
end if
4869+
4870+
! cleanup
4871+
do i=1,n_children
4872+
if (allocated(names(i)%str)) deallocate(names(i)%str)
4873+
end do
4874+
if (allocated(names)) deallocate(names)
4875+
4876+
end if
4877+
4878+
end if
4879+
4880+
end if
4881+
4882+
end subroutine json_check_children_for_duplicate_keys
4883+
!*****************************************************************************************
4884+
4885+
!*****************************************************************************************
4886+
!> author: Jacob Williams
4887+
! date: 8/25/2017
4888+
!
4889+
! Checks a JSON structure for duplicate child names.
4890+
! This one recursively traverses the entire structure
4891+
! (calling [[json_check_children_for_duplicate_keys]]
4892+
! recursively for each element).
4893+
!
4894+
!@note This will only check for one duplicate,
4895+
! it will return the first one that it finds.
4896+
4897+
subroutine json_check_all_for_duplicate_keys(json,p,has_duplicate,name,path)
4898+
4899+
implicit none
4900+
4901+
class(json_core),intent(inout) :: json
4902+
type(json_value),pointer,intent(in) :: p !! the object to search. If `p` is
4903+
!! not a `json_object`, then `has_duplicate`
4904+
!! will be false.
4905+
logical(LK),intent(out) :: has_duplicate !! true if there is at least
4906+
!! one duplicate `name` key anywhere
4907+
!! in the structure.
4908+
character(kind=CK,len=:),allocatable,intent(out),optional :: name !! the duplicate name
4909+
!! (unallocated if no
4910+
!! duplicates were found)
4911+
character(kind=CK,len=:),allocatable,intent(out),optional :: path !! the full path to the
4912+
!! duplicate name
4913+
!! (unallocated if no
4914+
!! duplicate was found)
4915+
4916+
has_duplicate = .false.
4917+
if (.not. json%exception_thrown) then
4918+
call json%traverse(p,duplicate_key_func)
4919+
end if
4920+
4921+
contains
4922+
4923+
subroutine duplicate_key_func(json,p,finished)
4924+
4925+
!! Callback function to check each element
4926+
!! for duplicate child names.
4927+
4928+
implicit none
4929+
4930+
class(json_core),intent(inout) :: json
4931+
type(json_value),pointer,intent(in) :: p
4932+
logical(LK),intent(out) :: finished
4933+
4934+
call json%check_children_for_duplicate_keys(p,has_duplicate,name,path)
4935+
4936+
finished = has_duplicate .or. json%exception_thrown
4937+
4938+
end subroutine duplicate_key_func
4939+
4940+
end subroutine json_check_all_for_duplicate_keys
4941+
!*****************************************************************************************
4942+
47284943
!*****************************************************************************************
47294944
!>
47304945
! Alternate version of [[json_value_get_child_by_name]] where `name` is kind=CDK.

0 commit comments

Comments
 (0)