json_value_validate Subroutine

private subroutine json_value_validate(json, p, is_valid, error_msg)

Validate a json_value linked list by checking to make sure all the pointers are properly associated, arrays and objects have the correct number of children, and the correct data is allocated for the variable types.

It recursively traverses the entire structure and checks every element.

History

  • Jacob Williams, 8/26/2017 : added duplicate key check.

Note

It will return on the first error it encounters.

Note

This routine does not check or throw any exceptions. If json is currently in a state of exception, it will remain so after calling this routine.

Type Bound

json_core

Arguments

Type IntentOptional Attributes Name
class(json_core), intent(inout) :: json
type(json_value), intent(in), pointer :: p
logical(kind=LK), intent(out) :: is_valid

True if the structure is valid.
character(kind=CK, len=:), intent(out), allocatable :: error_msg

if not valid, this will contain a description of the problem

Calls

proc~~json_value_validate~~CallsGraph proc~json_value_validate json_core%json_value_validate none~throw_exception json_core%throw_exception proc~json_value_validate->none~throw_exception proc~json_check_all_for_duplicate_keys json_core%json_check_all_for_duplicate_keys proc~json_value_validate->proc~json_check_all_for_duplicate_keys proc~json_check_for_errors json_core%json_check_for_errors proc~json_value_validate->proc~json_check_for_errors proc~json_clear_exceptions json_core%json_clear_exceptions proc~json_value_validate->proc~json_clear_exceptions proc~json_failed json_core%json_failed proc~json_value_validate->proc~json_failed proc~json_throw_exception json_core%json_throw_exception none~throw_exception->proc~json_throw_exception proc~wrap_json_throw_exception json_core%wrap_json_throw_exception none~throw_exception->proc~wrap_json_throw_exception proc~json_traverse json_core%json_traverse proc~json_check_all_for_duplicate_keys->proc~json_traverse proc~json_traverse->none~throw_exception proc~wrap_json_throw_exception->none~throw_exception interface~to_unicode to_unicode proc~wrap_json_throw_exception->interface~to_unicode proc~to_uni to_uni interface~to_unicode->proc~to_uni proc~to_uni_vec to_uni_vec interface~to_unicode->proc~to_uni_vec

Source Code

    subroutine json_value_validate(json,p,is_valid,error_msg)

    implicit none

    class(json_core),intent(inout)      :: json
    type(json_value),pointer,intent(in) :: p
    logical(LK),intent(out)             :: is_valid  !! True if the structure is valid.
    character(kind=CK,len=:),allocatable,intent(out) :: error_msg !! if not valid, this will contain
                                                                  !! a description of the problem

    logical(LK) :: has_duplicate !! to check for duplicate keys
    character(kind=CK,len=:),allocatable :: path  !! path to duplicate key
    logical(LK) :: status_ok !! to check for existing exception
    character(kind=CK,len=:),allocatable :: exception_msg  !! error message for an existing exception
    character(kind=CK,len=:),allocatable :: exception_msg2  !! error message for a new exception

    if (associated(p)) then

        is_valid = .true.
        call check_if_valid(p,require_parent=associated(p%parent))

        if (is_valid .and. .not. json%allow_duplicate_keys) then
            ! if no errors so far, also check the
            ! entire structure for duplicate keys:

            ! note: check_for_duplicate_keys does call routines
            ! that check and throw exceptions, so let's clear any
            ! first. (save message for later)
            call json%check_for_errors(status_ok, exception_msg)
            call json%clear_exceptions()

            call json%check_for_duplicate_keys(p,has_duplicate,path=path)
            if (json%failed()) then
                ! if an exception was thrown during this call,
                ! then clear it but make that the error message
                ! returned by this routine. Normally this should
                ! never actually occur since we have already
                ! validated the structure.
                call json%check_for_errors(is_valid, exception_msg2)
                error_msg = exception_msg2
                call json%clear_exceptions()
                is_valid = .false.
            else
                if (has_duplicate) then
                    error_msg = 'duplicate key found: '//path
                    is_valid  = .false.
                end if
            end if

            if (.not. status_ok) then
                ! restore any existing exception if necessary
                call json%throw_exception(exception_msg)
            end if

            ! cleanup:
            if (allocated(path))           deallocate(path)
            if (allocated(exception_msg))  deallocate(exception_msg)
            if (allocated(exception_msg2)) deallocate(exception_msg2)

        end if

    else
        error_msg = 'The pointer is not associated'
        is_valid = .false.
    end if

    contains

    recursive subroutine check_if_valid(p,require_parent)

        implicit none

        type(json_value),pointer,intent(in) :: p
        logical,intent(in) :: require_parent !! the first one may be a root (so no parent),
                                             !! but all descendants must have a parent.

        integer(IK) :: i !! counter
        type(json_value),pointer :: element
        type(json_value),pointer :: previous

        if (is_valid .and. associated(p)) then

            ! data type:
            select case (p%var_type)
            case(json_null,json_object,json_array)
                if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
                    allocated(p%dbl_value) .or. allocated(p%str_value)) then
                    error_msg = 'incorrect data allocated for '//&
                                'json_null, json_object, or json_array variable type'
                    is_valid = .false.
                    return
                end if
            case(json_logical)
                if (.not. allocated(p%log_value)) then
                    error_msg = 'log_value should be allocated for json_logical variable type'
                    is_valid = .false.
                    return
                else if (allocated(p%int_value) .or. &
                    allocated(p%dbl_value) .or. allocated(p%str_value)) then
                    error_msg = 'incorrect data allocated for json_logical variable type'
                    is_valid = .false.
                    return
                end if
            case(json_integer)
                if (.not. allocated(p%int_value)) then
                    error_msg = 'int_value should be allocated for json_integer variable type'
                    is_valid = .false.
                    return
                else if (allocated(p%log_value) .or. &
                    allocated(p%dbl_value) .or. allocated(p%str_value)) then
                    error_msg = 'incorrect data allocated for json_integer variable type'
                    is_valid = .false.
                    return
                end if
            case(json_real)
                if (.not. allocated(p%dbl_value)) then
                    error_msg = 'dbl_value should be allocated for json_real variable type'
                    is_valid = .false.
                    return
                else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
                    allocated(p%str_value)) then
                    error_msg = 'incorrect data allocated for json_real variable type'
                    is_valid = .false.
                    return
                end if
            case(json_string)
                if (.not. allocated(p%str_value)) then
                    error_msg = 'str_value should be allocated for json_string variable type'
                    is_valid = .false.
                    return
                else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
                    allocated(p%dbl_value)) then
                    error_msg = 'incorrect data allocated for json_string variable type'
                    is_valid = .false.
                    return
                end if
            case default
                error_msg = 'invalid JSON variable type'
                is_valid = .false.
                return
            end select

            if (require_parent .and. .not. associated(p%parent)) then
                error_msg = 'parent pointer is not associated'
                is_valid = .false.
                return
            end if

            if (.not. allocated(p%name)) then
                if (associated(p%parent)) then
                    if (p%parent%var_type/=json_array) then
                        error_msg = 'JSON variable must have a name if not an '//&
                                    'array element or the root'
                        is_valid = .false.
                        return
                    end if
                end if
            end if

            if (associated(p%children) .neqv. associated(p%tail)) then
                error_msg = 'both children and tail pointers must be associated'
                is_valid = .false.
                return
            end if

            ! now, check next one:
            if (associated(p%next)) then
                if (associated(p,p%next)) then
                    error_msg = 'circular linked list'
                    is_valid = .false.
                    return
                else
                    ! if it's an element in an
                    ! array, then require a parent:
                    call check_if_valid(p%next,require_parent=.true.)
                end if
            end if

            if (associated(p%children)) then

                if (p%var_type/=json_array .and. p%var_type/=json_object) then
                    error_msg = 'only arrays and objects can have children'
                    is_valid = .false.
                    return
                end if

                ! first validate children pointers:

                previous => null()
                element => p%children
                do i = 1_IK, p%n_children
                    if (.not. associated(element%parent,p)) then
                        error_msg = 'child''s parent pointer not properly associated'
                        is_valid = .false.
                        return
                    end if
                    if (i==1 .and. associated(element%previous)) then
                        error_msg = 'first child shouldn''t have a previous'
                        is_valid = .false.
                        return
                    end if
                    if (i<p%n_children .and. .not. associated(element%next)) then
                        error_msg = 'not enough children'
                        is_valid = .false.
                        return
                    end if
                    if (i==p%n_children .and. associated(element%next)) then
                        error_msg = 'too many children'
                        is_valid = .false.
                        return
                    end if
                    if (i>1) then
                        if (.not. associated(previous,element%previous)) then
                            error_msg = 'previous pointer not properly associated'
                            is_valid = .false.
                            return
                        end if
                    end if
                    if (i==p%n_children .and. &
                        .not. associated(element%parent%tail,element)) then
                        error_msg = 'parent''s tail pointer not properly associated'
                        is_valid = .false.
                        return
                    end if
                    if (i<p%n_children) then
                        !setup next case:
                        previous => element
                        element => element%next
                    end if
                end do

                !now check all the children:
                call check_if_valid(p%children,require_parent=.true.)

            end if

        end if

    end subroutine check_if_valid

    end subroutine json_value_validate