Skip to content

Commit 74957a1

Browse files
jacobwilliamsjacobwilliams
committed
Merge pull request #197 from jacobwilliams/validate
Validate
2 parents 6d5735a + 7efa7ee commit 74957a1

File tree

2 files changed

+218
-2
lines changed

2 files changed

+218
-2
lines changed

‎src/json_value_module.F90‎

Lines changed: 207 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -520,6 +520,9 @@ module json_value_module
520520
procedure,public :: swap => json_value_swap !! Swap two [[json_value]] pointers
521521
!! in a structure (or two different structures).
522522
procedure,public :: is_child_of => json_value_is_child_of !! Check if a [[json_value]] is a child of another.
523+
procedure,public :: validate => json_value_validate !! Check that a [[json_value]] linked list is valid
524+
!! (i.e., is properly constructed). This may be
525+
!! useful if it has been constructed externally.
523526

524527
!other private routines:
525528
procedure :: name_equal
@@ -788,7 +791,7 @@ function name_equal(json,p,name) result(is_equal)
788791
class(json_core),intent(inout) :: json
789792
type(json_value),intent(in) :: p !! the json object
790793
character(kind=CK,len=*),intent(in) :: name !! the name to check for
791-
logical :: is_equal !! true if the string are lexically equal
794+
logical(LK) :: is_equal !! true if the string are lexically equal
792795

793796
if (allocated(p%name)) then
794797

@@ -1553,10 +1556,12 @@ function json_value_is_child_of(json,p1,p2) result(is_child_of)
15531556
class(json_core),intent(inout) :: json
15541557
type(json_value),pointer :: p1
15551558
type(json_value),pointer :: p2
1556-
logical :: is_child_of
1559+
logical(LK) :: is_child_of
15571560

15581561
is_child_of = .false.
15591562

1563+
if (json%exception_thrown) return
1564+
15601565
if (associated(p1) .and. associated(p2)) then
15611566
if (associated(p1%children)) then
15621567
call json%traverse(p1%children,is_child_of_callback)
@@ -1581,6 +1586,206 @@ end subroutine is_child_of_callback
15811586
end function json_value_is_child_of
15821587
!*****************************************************************************************
15831588

1589+
!*****************************************************************************************
1590+
!> author: Jacob Williams
1591+
! date: 5/2/2016
1592+
!
1593+
! Validate a [[json_value]] linked list by checking to make sure
1594+
! all the pointers are properly associated, arrays and objects
1595+
! have the correct number of children, and the correct data is
1596+
! allocated for the variable types.
1597+
!
1598+
! It recursively traverses the entire structure and checks every element.
1599+
!
1600+
!@note This routine does not check or throw any exceptions.
1601+
1602+
subroutine json_value_validate(json,p,is_valid,error_msg)
1603+
1604+
implicit none
1605+
1606+
class(json_core),intent(inout) :: json
1607+
type(json_value),pointer,intent(in) :: p
1608+
logical(LK),intent(out) :: is_valid !! True if the structure is valid.
1609+
character(kind=CK,len=:),allocatable :: error_msg !! if not valid, this will contain
1610+
!! a description of the problem
1611+
1612+
if (associated(p)) then
1613+
is_valid = .true.
1614+
call check_if_valid(p,require_parent=associated(p%parent))
1615+
else
1616+
error_msg = 'The pointer is not associated'
1617+
is_valid = .false.
1618+
end if
1619+
1620+
contains
1621+
1622+
recursive subroutine check_if_valid(p,require_parent)
1623+
1624+
implicit none
1625+
1626+
type(json_value),pointer,intent(in) :: p
1627+
logical,intent(in) :: require_parent !! the first one may be a root (so no parent),
1628+
!! but all descendants must have a parent.
1629+
1630+
integer :: i !! counter
1631+
type(json_value),pointer :: element
1632+
type(json_value),pointer :: previous
1633+
1634+
if (is_valid .and. associated(p)) then
1635+
1636+
! data type:
1637+
select case (p%var_type)
1638+
case(json_null,json_object,json_array)
1639+
if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
1640+
allocated(p%dbl_value) .or. allocated(p%str_value)) then
1641+
error_msg = 'incorrect data allocated for '//&
1642+
'json_null, json_object, or json_array variable type'
1643+
is_valid = .false.
1644+
return
1645+
end if
1646+
case(json_logical)
1647+
if (.not. allocated(p%log_value)) then
1648+
error_msg = 'log_value should be allocated for json_logical variable type'
1649+
is_valid = .false.
1650+
return
1651+
else if (allocated(p%int_value) .or. &
1652+
allocated(p%dbl_value) .or. allocated(p%str_value)) then
1653+
error_msg = 'incorrect data allocated for json_logical variable type'
1654+
is_valid = .false.
1655+
return
1656+
end if
1657+
case(json_integer)
1658+
if (.not. allocated(p%int_value)) then
1659+
error_msg = 'int_value should be allocated for json_integer variable type'
1660+
is_valid = .false.
1661+
return
1662+
else if (allocated(p%log_value) .or. &
1663+
allocated(p%dbl_value) .or. allocated(p%str_value)) then
1664+
error_msg = 'incorrect data allocated for json_integer variable type'
1665+
is_valid = .false.
1666+
return
1667+
end if
1668+
case(json_double)
1669+
if (.not. allocated(p%dbl_value)) then
1670+
error_msg = 'dbl_value should be allocated for json_double variable type'
1671+
is_valid = .false.
1672+
return
1673+
else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
1674+
allocated(p%str_value)) then
1675+
error_msg = 'incorrect data allocated for json_double variable type'
1676+
is_valid = .false.
1677+
return
1678+
end if
1679+
case(json_string)
1680+
if (.not. allocated(p%str_value)) then
1681+
error_msg = 'str_value should be allocated for json_string variable type'
1682+
is_valid = .false.
1683+
return
1684+
else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
1685+
allocated(p%dbl_value)) then
1686+
error_msg = 'incorrect data allocated for json_string variable type'
1687+
is_valid = .false.
1688+
return
1689+
end if
1690+
case default
1691+
error_msg = 'invalid JSON variable type'
1692+
is_valid = .false.
1693+
return
1694+
end select
1695+
1696+
if (require_parent .and. .not. associated(p%parent)) then
1697+
error_msg = 'parent pointer is not associated'
1698+
is_valid = .false.
1699+
return
1700+
end if
1701+
1702+
if (.not. allocated(p%name)) then
1703+
if (associated(p%parent)) then
1704+
if (p%parent%var_type/=json_array) then
1705+
error_msg = 'JSON variable must have a name if not an '//&
1706+
'array element or the root'
1707+
is_valid = .false.
1708+
return
1709+
end if
1710+
end if
1711+
end if
1712+
1713+
if (associated(p%children) .neqv. associated(p%tail)) then
1714+
error_msg = 'both children and tail pointers must be associated'
1715+
is_valid = .false.
1716+
return
1717+
end if
1718+
1719+
! now, check next one:
1720+
if (associated(p%next)) then
1721+
call check_if_valid(p%next,require_parent=require_parent)
1722+
end if
1723+
1724+
if (associated(p%children)) then
1725+
1726+
if (p%var_type/=json_array .and. p%var_type/=json_object) then
1727+
error_msg = 'only arrays and objects can have children'
1728+
is_valid = .false.
1729+
return
1730+
end if
1731+
1732+
! first validate children pointers:
1733+
1734+
previous => null()
1735+
element => p%children
1736+
do i = 1, p%n_children
1737+
if (.not. associated(element%parent,p)) then
1738+
error_msg = 'child''s parent pointer not properly associated'
1739+
is_valid = .false.
1740+
return
1741+
end if
1742+
if (i==1 .and. associated(element%previous)) then
1743+
error_msg = 'first child shouldn''t have a previous'
1744+
is_valid = .false.
1745+
return
1746+
end if
1747+
if (i<p%n_children .and. .not. associated(element%next)) then
1748+
error_msg = 'not enough children'
1749+
is_valid = .false.
1750+
return
1751+
end if
1752+
if (i==p%n_children .and. associated(element%next)) then
1753+
error_msg = 'too many children'
1754+
is_valid = .false.
1755+
return
1756+
end if
1757+
if (i>1) then
1758+
if (.not. associated(previous,element%previous)) then
1759+
error_msg = 'previous pointer not properly associated'
1760+
is_valid = .false.
1761+
return
1762+
end if
1763+
end if
1764+
if (i==p%n_children .and. &
1765+
.not. associated(element%parent%tail,element)) then
1766+
error_msg = 'parent''s tail pointer not properly associated'
1767+
is_valid = .false.
1768+
return
1769+
end if
1770+
if (i<p%n_children) then
1771+
!setup next case:
1772+
previous => element
1773+
element => element%next
1774+
end if
1775+
end do
1776+
1777+
!now check all the children:
1778+
call check_if_valid(p%children,require_parent=.true.)
1779+
1780+
end if
1781+
1782+
end if
1783+
1784+
end subroutine check_if_valid
1785+
1786+
end subroutine json_value_validate
1787+
!*****************************************************************************************
1788+
15841789
!*****************************************************************************************
15851790
!> author: Jacob Williams
15861791
! date: 12/6/2014

‎src/tests/jf_test_2.f90‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,8 @@ subroutine test_2(error_cnt)
3232
character(kind=json_CK,len=:),allocatable :: name
3333
integer :: ival,ival_clone
3434
logical :: found
35+
logical :: is_valid
36+
character(kind=json_CK,len=:),allocatable :: error_msg
3537

3638
write(error_unit,'(A)') ''
3739
write(error_unit,'(A)') '================================='
@@ -142,6 +144,15 @@ subroutine test_2(error_cnt)
142144
call add_variables_to_input(json, traj, 'Vz', 'km/s', 'J2000', 'EARTH', [3.0e-3_wp, 30.0e-3_wp, 40.0e-3_wp], error_cnt )
143145
nullify(traj)
144146

147+
!validate it:
148+
write(error_unit,'(A)') ''
149+
write(error_unit,'(A)') 'validating...'
150+
call json%validate(p,is_valid,error_msg)
151+
if (.not. is_valid) then
152+
write(error_unit,'(A)') 'Error: p is not a valid JSON linked list: '//error_msg
153+
error_cnt = error_cnt + 1
154+
end if
155+
145156
write(error_unit,'(A)') ''
146157
write(error_unit,'(A)') 'writing file '//trim(dir//filename2)//'...'
147158

0 commit comments

Comments
 (0)