Swap two elements in a JSON structure. All of the children are carried along as well.
If both are not associated, then an error is thrown.
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).
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.
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.
If p1 and p2 have a common parent, it is always safe to swap them.
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| class(json_core), | intent(inout) | :: | json | |||
| type(json_value), | pointer | :: | p1 | |||
| type(json_value), | pointer | :: | p2 |
subroutine json_value_swap(json,p1,p2)
implicit none
class(json_core),intent(inout) :: json
type(json_value),pointer :: p1
type(json_value),pointer :: p2
logical :: same_parent,first_last,adjacent
type(json_value),pointer :: a,b
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
!if p1,p2 are the first,last or last,first
!children of a common parent
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