Skip to content

Commit c9a13e2

Browse files
jacobwilliamsjacobwilliams
committed
added initial version of swap routine.
Also added some additional error checks for malformed JSON linked lists (prevents an infinite loop under some circumstances if the structure is not properly constructed).
1 parent 81ea21f commit c9a13e2

File tree

2 files changed

+386
-5
lines changed

2 files changed

+386
-5
lines changed

‎src/json_value_module.F90

Lines changed: 228 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -491,6 +491,12 @@ module json_value_module
491491
procedure :: json_parse_file
492492
procedure :: MAYBEWRAP(json_parse_string)
493493

494+
!>
495+
! Swap two [[json_value]] pointers in a structure
496+
! (or two different structures).
497+
generic,public :: swap => json_value_swap
498+
procedure :: json_value_swap
499+
494500
!>
495501
! Throw an exception.
496502
generic,public :: throw_exception => MAYBEWRAP(json_throw_exception)
@@ -1148,9 +1154,15 @@ recursive subroutine json_value_destroy(json,me,destroy_next)
11481154
if (associated(me%children)) then
11491155
do while (me%n_children > 0)
11501156
p => me%children
1151-
me%children => me%children%next
1152-
me%n_children = me%n_children - 1
1153-
call json_value_destroy(json,p,.false.)
1157+
if (associated(p)) then
1158+
me%children => me%children%next
1159+
me%n_children = me%n_children - 1
1160+
call json_value_destroy(json,p,.false.)
1161+
else
1162+
call json%throw_exception('Error in json_value_destroy: '&
1163+
'Malformed JSON linked list')
1164+
exit
1165+
end if
11541166
end do
11551167
nullify(me%children)
11561168
nullify(p)
@@ -1203,7 +1215,6 @@ end subroutine json_value_destroy
12031215
!
12041216
!# History
12051217
! * Jacob Williams : 12/28/2014 : added destroy optional argument.
1206-
!
12071218

12081219
subroutine json_value_remove(json,me,destroy)
12091220

@@ -1275,6 +1286,201 @@ subroutine json_value_remove(json,me,destroy)
12751286
end subroutine json_value_remove
12761287
!*****************************************************************************************
12771288

1289+
!*****************************************************************************************
1290+
!> author: Jacob Williams
1291+
! date: 4/26/2016
1292+
!
1293+
! Swap two elements in a JSON structure.
1294+
! All of the children are carried along as well.
1295+
!
1296+
!@note If both are not associated, then an error is thrown.
1297+
!
1298+
!@note The assumption here is that both variables are part of a valid
1299+
! [[json_value]] linked list (so the normal `parent`, `previous`,
1300+
! `next`, etc. pointers are properly associated if necessary).
1301+
!
1302+
!@warning This should not be used to swap an element with one of its
1303+
! direct children (along the first in the lists), since that would
1304+
! produce a circular linkage. A check should be added for this...
1305+
! Only the simple cases where p1/p2 or p2/p1 are parent/child
1306+
! are currently checked.
1307+
!
1308+
!@warning This is a work-in-progress and has not yet been fully validated.
1309+
1310+
subroutine json_value_swap(json,p1,p2)
1311+
1312+
implicit none
1313+
1314+
class(json_core),intent(inout) :: json
1315+
type(json_value),pointer :: p1
1316+
type(json_value),pointer :: p2
1317+
1318+
logical :: same_parent,first_last
1319+
type(json_value),pointer :: p1_par_first,p1_par_last,p2_par_first,p2_par_last
1320+
type(json_value),pointer :: a,b
1321+
logical :: adjacent
1322+
1323+
if (json%exception_thrown) return
1324+
1325+
!both have to be associated:
1326+
if (associated(p1) .and. associated(p2)) then
1327+
1328+
!simple check to make sure that they both
1329+
!aren't pointing to the same thing:
1330+
if (.not. associated(p1,p2)) then
1331+
1332+
!TODO Need to check *all* the `children` pointers, so make sure
1333+
! cases like p1%child%...%child => p2 don't occur...
1334+
! .... or is that case OK? ....
1335+
if (associated(p1%parent,p2) .or. associated(p2%parent,p1)) then
1336+
call json%throw_exception('Error in json_value_swap: '//&
1337+
'cannot swap a parent/child pair')
1338+
else
1339+
1340+
same_parent = ( associated(p1%parent) .and. &
1341+
associated(p2%parent) .and. &
1342+
associated(p1%parent,p2%parent) )
1343+
if (same_parent) then
1344+
first_last = (associated(p1%parent%children,p1) .and. &
1345+
associated(p2%parent%tail,p2)) .or. &
1346+
(associated(p1%parent%tail,p1) .and. &
1347+
associated(p2%parent%children,p2))
1348+
else
1349+
first_last = .false.
1350+
end if
1351+
1352+
!first, we fix children,tail pointers:
1353+
1354+
if (same_parent .and. first_last) then
1355+
1356+
!this is all we have to do for the parent in this case:
1357+
call swap_pointers(p1%parent%children,p2%parent%tail)
1358+
1359+
elseif (same_parent .and. .not. first_last) then
1360+
1361+
if (associated(p1%parent%children,p1)) then
1362+
! if p1 is the first child of its parent:
1363+
p1%parent%children => p2
1364+
elseif (associated(p1%parent%children,p2)) then
1365+
! if p2 is the first child of its parent:
1366+
p1%parent%children => p1
1367+
end if
1368+
if (associated(p1%parent%tail,p1)) then
1369+
! if p1 is the last child of its parent:
1370+
p1%parent%tail => p2
1371+
elseif (associated(p1%parent%tail,p2)) then
1372+
p1%parent%tail => p1
1373+
end if
1374+
1375+
else ! general case: different parents
1376+
1377+
!... see if we can clean this up ...
1378+
1379+
p1_par_first => null()
1380+
p1_par_last => null()
1381+
p2_par_first => null()
1382+
p2_par_last => null()
1383+
if (associated(p1%parent)) then
1384+
if (associated(p1%parent%children,p1)) then
1385+
! if p1 is the first child of its parent:
1386+
p1_par_first => p2
1387+
else
1388+
p1_par_first => p1%parent%children !no change
1389+
end if
1390+
if (associated(p1%parent%tail,p1)) then
1391+
! if p1 is the last child of its parent:
1392+
p1_par_last => p2
1393+
else
1394+
p1_par_last => p1%parent%tail ! no change
1395+
end if
1396+
end if
1397+
if (associated(p2%parent)) then
1398+
if (associated(p2%parent%children,p2)) then
1399+
! if p2 is the first child of its parent:
1400+
p2_par_first => p1
1401+
else
1402+
p2_par_first => p2%parent%children !no change
1403+
end if
1404+
if (associated(p2%parent%tail,p2)) then
1405+
! if p2 is the last child of its parent:
1406+
p2_par_last => p1
1407+
else
1408+
p2_par_last => p2%parent%tail !no change
1409+
end if
1410+
end if
1411+
if (associated(p1%parent)) then
1412+
p1%parent%children => p1_par_first
1413+
p1%parent%tail => p1_par_last
1414+
end if
1415+
if (associated(p2%parent)) then
1416+
p2%parent%children => p2_par_first
1417+
p2%parent%tail => p2_par_last
1418+
end if
1419+
1420+
call swap_pointers(p1%parent, p2%parent)
1421+
1422+
end if
1423+
1424+
!now, have to fix previous,next pointers:
1425+
1426+
!first, see if they are adjacent:
1427+
adjacent = associated(p1%next,p2) .or. &
1428+
associated(p2%next,p1)
1429+
if (associated(p2%next,p1)) then !p2,p1
1430+
a => p2
1431+
b => p1
1432+
else !p1,p2 (or not adjacent)
1433+
a => p1
1434+
b => p2
1435+
end if
1436+
if (associated(a%previous)) a%previous%next => b
1437+
if (associated(b%next)) b%next%previous => a
1438+
1439+
if (adjacent) then
1440+
!a comes before b in the original list
1441+
b%previous => a%previous
1442+
a%next => b%next
1443+
a%previous => b
1444+
b%next => a
1445+
else
1446+
if (associated(a%next)) a%next%previous => b
1447+
if (associated(b%previous)) b%previous%next => a
1448+
call swap_pointers(a%previous,b%previous)
1449+
call swap_pointers(a%next, b%next)
1450+
end if
1451+
1452+
end if
1453+
1454+
else
1455+
call json%throw_exception('Error in json_value_swap: '//&
1456+
'both pointers must be associated')
1457+
end if
1458+
1459+
end if
1460+
1461+
contains
1462+
1463+
pure subroutine swap_pointers(s1,s2)
1464+
1465+
implicit none
1466+
1467+
type(json_value),pointer,intent(inout) :: s1
1468+
type(json_value),pointer,intent(inout) :: s2
1469+
1470+
type(json_value),pointer :: tmp !! temporary pointer
1471+
1472+
if (.not. associated(s1,s2)) then
1473+
tmp => s1
1474+
s1 => s2
1475+
s2 => tmp
1476+
nullify(tmp)
1477+
end if
1478+
1479+
end subroutine swap_pointers
1480+
1481+
end subroutine json_value_swap
1482+
!*****************************************************************************************
1483+
12781484
!*****************************************************************************************
12791485
!> author: Jacob Williams
12801486
! date: 12/6/2014
@@ -2305,7 +2511,7 @@ subroutine json_value_get_by_index(json, me, idx, p)
23052511
p => p%next
23062512
else
23072513
call json%throw_exception('Error in json_value_get_by_index:'//&
2308-
' p%next is not associated.')
2514+
' p%next is not associated.')
23092515
nullify(p)
23102516
return
23112517
end if
@@ -2357,6 +2563,11 @@ subroutine json_value_get_by_name_chars(json, me, name, p)
23572563
n_children = json%count(me)
23582564
p => me%children !start with first one
23592565
do i=1, n_children
2566+
if (.not. associated(p)) then
2567+
call json%throw_exception('Error in json_value_get_by_name_chars: '&
2568+
'Malformed JSON linked list')
2569+
return
2570+
end if
23602571
if (allocated(p%name)) then
23612572
if (p%name == name) return
23622573
end if
@@ -2565,6 +2776,12 @@ recursive subroutine json_value_print(json,me,iunit,str,indent,need_comma,colon,
25652776
element => me%children
25662777
do i = 1, count
25672778

2779+
if (.not. associated(element)) then
2780+
call json%throw_exception('Error in json_value_print: '//&
2781+
'Malformed JSON linked list')
2782+
return
2783+
end if
2784+
25682785
! print the name
25692786
if (allocated(element%name)) then
25702787
call write_it(repeat(space, spaces)//quotation_mark//&
@@ -2609,6 +2826,12 @@ recursive subroutine json_value_print(json,me,iunit,str,indent,need_comma,colon,
26092826
element => me%children
26102827
do i = 1, count
26112828

2829+
if (.not. associated(element)) then
2830+
call json%throw_exception('Error in json_value_print: '//&
2831+
'Malformed JSON linked list')
2832+
return
2833+
end if
2834+
26122835
! recursive print of the element
26132836
call json%json_value_print(element, iunit=iunit, indent=tab,&
26142837
need_comma=i<count, is_array_element=.true., str=str)

0 commit comments

Comments
 (0)