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.

Arguments

Type IntentOptional AttributesName
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


Contents

Source Code


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 :: 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_double)
                if (.not. allocated(p%dbl_value)) then
                    error_msg = 'dbl_value should be allocated for json_double 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_double 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, 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