json_value_swap Subroutine

private subroutine json_value_swap(json, p1, p2)

Swap two elements in a JSON structure. All of the children are carried along as well.

Note

If both are not associated, then an error is thrown.

Note

The assumption here is that both variables are part of a valid json_value linked list (so the normal parent, previous, next, etc. pointers are properly associated if necessary).

Warning

This cannot be used to swap a parent/child pair, since that could lead to a circular linkage. An exception is thrown if this is tried.

Warning

There are also other situations where using this routine may produce a malformed JSON structure, such as moving an array element outside of an array. This is not checked for.

Note

If p1 and p2 have a common parent, it is always safe to swap them.

Type Bound

json_core

Arguments

Type IntentOptional Attributes Name
class(json_core), intent(inout) :: json
type(json_value), pointer :: p1

swap with p2
type(json_value), pointer :: p2

swap with p1

Calls

proc~~json_value_swap~~CallsGraph proc~json_value_swap json_value_module::json_core%json_value_swap none~throw_exception json_value_module::json_core%throw_exception proc~json_value_swap->none~throw_exception proc~json_value_is_child_of json_value_module::json_core%json_value_is_child_of proc~json_value_swap->proc~json_value_is_child_of proc~json_throw_exception json_value_module::json_core%json_throw_exception none~throw_exception->proc~json_throw_exception proc~json_traverse json_value_module::json_core%json_traverse proc~json_value_is_child_of->proc~json_traverse proc~json_traverse->none~throw_exception

Source Code

    subroutine json_value_swap(json,p1,p2)

    implicit none

    class(json_core),intent(inout) :: json
    type(json_value),pointer       :: p1  !! swap with `p2`
    type(json_value),pointer       :: p2  !! swap with `p1`

    logical                  :: same_parent !! if `p1` and `p2` have the same parent
    logical                  :: first_last  !! if `p1` and `p2` are the first,last or
                                            !! last,first children of a common parent
    logical                  :: adjacent    !! if `p1` and `p2` are adjacent
                                            !! elements in an array
    type(json_value),pointer :: a           !! temporary variable
    type(json_value),pointer :: b           !! temporary variable

    if (json%exception_thrown) return

    !both have to be associated:
    if (associated(p1) .and. associated(p2)) then

        !simple check to make sure that they both
        !aren't pointing to the same thing:
        if (.not. associated(p1,p2)) then

            !we will not allow swapping an item with one of its descendants:
            if (json%is_child_of(p1,p2) .or. json%is_child_of(p2,p1)) then
                call json%throw_exception('Error in json_value_swap: '//&
                                          'cannot swap an item with one of its descendants')
            else

                same_parent = ( associated(p1%parent) .and. &
                                associated(p2%parent) .and. &
                                associated(p1%parent,p2%parent) )
                if (same_parent) then
                    first_last = (associated(p1%parent%children,p1) .and. &
                                  associated(p2%parent%tail,p2)) .or. &
                                 (associated(p1%parent%tail,p1) .and. &
                                  associated(p2%parent%children,p2))
                else
                    first_last = .false.
                end if

                !first, we fix children,tail pointers:

                if (same_parent .and. first_last) then

                    !this is all we have to do for the parent in this case:
                    call swap_pointers(p1%parent%children,p2%parent%tail)

                else if (same_parent .and. .not. first_last) then

                    if (associated(p1%parent%children,p1)) then
                        p1%parent%children => p2 ! p1 is the first child of the parent
                    else if (associated(p1%parent%children,p2)) then
                        p1%parent%children => p1 ! p2 is the first child of the parent
                    end if
                    if (associated(p1%parent%tail,p1)) then
                        p1%parent%tail => p2 ! p1 is the last child of the parent
                    else if (associated(p1%parent%tail,p2)) then
                        p1%parent%tail => p1 ! p2 is the last child of the parent
                    end if

                else ! general case: different parents

                    if (associated(p1%parent)) then
                        if (associated(p1%parent%children,p1)) p1%parent%children => p2
                        if (associated(p1%parent%tail,p1))     p1%parent%tail     => p2
                    end if
                    if (associated(p2%parent)) then
                        if (associated(p2%parent%children,p2)) p2%parent%children => p1
                        if (associated(p2%parent%tail,p2))     p2%parent%tail     => p1
                    end if
                    call swap_pointers(p1%parent, p2%parent)

                end if

                !now, have to fix previous,next pointers:

                !first, see if they are adjacent:
                adjacent = associated(p1%next,p2) .or. &
                           associated(p2%next,p1)
                if (associated(p2%next,p1)) then    !p2,p1
                    a => p2
                    b => p1
                else    !p1,p2 (or not adjacent)
                    a => p1
                    b => p2
                end if
                if (associated(a%previous)) a%previous%next => b
                if (associated(b%next))     b%next%previous => a

                if (adjacent) then
                    !a comes before b in the original list
                    b%previous => a%previous
                    a%next     => b%next
                    a%previous => b
                    b%next     => a
                else
                    if (associated(a%next))       a%next%previous => b
                    if (associated(b%previous))   b%previous%next => a
                    call swap_pointers(a%previous,b%previous)
                    call swap_pointers(a%next,    b%next)
                end if

            end if

        else
            call json%throw_exception('Error in json_value_swap: '//&
                                      'both pointers must be associated')
        end if

    end if

    contains

        pure subroutine swap_pointers(s1,s2)

        implicit none

        type(json_value),pointer,intent(inout) :: s1
        type(json_value),pointer,intent(inout) :: s2

        type(json_value),pointer :: tmp  !! temporary pointer

        if (.not. associated(s1,s2)) then
            tmp => s1
            s1  => s2
            s2  => tmp
        end if

        end subroutine swap_pointers

    end subroutine json_value_swap