Skip to content

Commit f28c72a

Browse files
jacobwilliamsjacobwilliams
committed
added validate routine. Fixes #196 
1 parent 6d5735a commit f28c72a

File tree

1 file changed

+203
-0
lines changed

1 file changed

+203
-0
lines changed

‎src/json_value_module.F90‎

Lines changed: 203 additions & 0 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
@@ -1581,6 +1584,206 @@ end subroutine is_child_of_callback
15811584
end function json_value_is_child_of
15821585
!*****************************************************************************************
15831586

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

0 commit comments

Comments
 (0)