Merge pull request #144 from jacobwilliams/traverse

New routine to traverse all nodes of a JSON structure. Fixes #140

Author: jacobwilliams

src/json_module.F90

@@ -456,17 +456,25 @@ module json_module
     !*************************************************************************************
 
     !*************************************************************************************
-    !>
-    !  Array element callback function.  Used by [[json_get_array]].
-
     abstract interface
+    
         subroutine array_callback_func(element, i, count)
+            !! Array element callback function.  Used by [[json_get_array]]
             import :: json_value,IK
             implicit none
             type(json_value), pointer,intent(in) :: element
             integer(IK),intent(in) :: i        !index
             integer(IK),intent(in) :: count    !size of array
         end subroutine array_callback_func
+        
+        subroutine traverse_callback_func(p,finished)
+            !! Callback function used by [[json_traverse]]
+            import :: json_value,LK
+            implicit none
+            type(json_value),pointer,intent(in) :: p
+            logical(LK),intent(out)             :: finished
+        end subroutine traverse_callback_func
+       
     end interface
     !*************************************************************************************
 
@@ -827,6 +835,7 @@ end subroutine array_callback_func
     public :: json_remove                ! remove from a JSON structure
     public :: json_remove_if_present     ! remove from a JSON structure (if it is present)
     public :: json_update                ! update a value in a JSON structure
+    public :: json_traverse              ! to traverse all elements of a JSON structure
     public :: json_print_error_message   !
     public :: to_unicode                 ! Function to convert from 'DEFAULT' to 'ISO_10646' strings
 
@@ -4959,6 +4968,50 @@ subroutine json_get_array(me, array_callback)
     end subroutine json_get_array
 !*****************************************************************************************
 
+!*****************************************************************************************
+!> author: Jacob Williams
+!  date: 09/02/2015
+!
+!  Traverse a JSON structure.
+!  This routine calls the user-specified [[traverse_callback_func]] 
+!  for each element of the structure.
+!
+    recursive subroutine json_traverse(me,traverse_callback)
+
+    implicit none
+
+    type(json_value),pointer,intent(in) :: me
+    procedure(traverse_callback_func)   :: traverse_callback
+
+    type(json_value),pointer :: element  !! a child element
+    integer(IK) :: i        !! counter
+    integer(IK) :: icount   !! number of children
+    logical(LK) :: finished !! can be used to stop the process
+
+    if (exception_thrown) return
+
+    call traverse_callback(me,finished) ! first call for this object
+    if (finished) return
+
+    !for arrays and objects, have to also call for all children:
+    if (me%var_type==json_array .or. me%var_type==json_object) then
+
+        icount = json_count(me) ! number of children
+        if (icount>0) then
+            element => me%children  ! first one
+            do i = 1, icount        ! call for each child
+                call json_traverse(element,traverse_callback)
+                if (finished) exit
+                element => element%next
+            end do
+        end if
+        nullify(element)
+
+    end if
+
+    end subroutine json_traverse
+!*****************************************************************************************
+
 !*****************************************************************************************
 !>
 !  This routine calls the user-supplied array_callback subroutine

src/tests/jf_test_14.f90

@@ -0,0 +1,121 @@
+!*****************************************************************************************
+!> author: Jacob Williams
+!  date: 09/02/2015
+!
+! Module for the 14th unit test.
+
+module jf_test_14_mod
+
+    use json_module
+    use, intrinsic :: iso_fortran_env , only: error_unit,output_unit
+
+    implicit none
+    
+    character(len=*),parameter :: dir = '../files/inputs/'  !! working directory
+    character(len=*),parameter :: filename1 = 'test1.json'  !! the file to read
+    integer :: icount = 0  !! a count of the number of "name" variables found
+
+contains
+
+    subroutine test_14(error_cnt)
+    
+    !! Tests the traversal of a JSON structure
+    !!
+    !! It traverses the structure, looks for all "name" variables, and changes the name.
+    
+    implicit none
+
+    integer,intent(out) :: error_cnt !! report number of errors to caller
+    
+    type(json_value),pointer  :: json
+        
+    write(error_unit,'(A)') ''
+    write(error_unit,'(A)') '================================='
+    write(error_unit,'(A)') '   TEST 14'
+    write(error_unit,'(A)') '================================='
+    write(error_unit,'(A)') ''
+
+    error_cnt = 0
+    icount = 0 !number of name changes (should be 2)
+        
+    call json_initialize() !initialize the module
+    
+    call json_parse(dir//filename1,json)  !read the file
+    if (json_failed()) then
+        call json_print_error_message(error_unit)
+        error_cnt = error_cnt + 1
+    end if
+    
+    call json_traverse(json,rename) !traverse all nodes in the structure
+    if (json_failed()) then
+        call json_print_error_message(error_unit)
+        error_cnt = error_cnt + 1
+    end if
+
+    if (icount/=2) then
+        write(error_unit,'(A)') 'Error: should be 2 "name" variables in this file: '//filename1
+        error_cnt = error_cnt + 1
+    end if 
+    
+    if (error_cnt==0) then
+        write(error_unit,'(A)') ''
+        write(error_unit,'(A)') ' All names changed to Fred:'
+        write(error_unit,'(A)') ''
+        call json_print(json,output_unit)
+        write(error_unit,'(A)') ''
+    end if
+    
+    call json_destroy(json)  !clean up
+    if (json_failed()) then
+        call json_print_error_message(error_unit)
+        error_cnt = error_cnt + 1
+    end if
+        
+    end subroutine test_14
+    
+    subroutine rename(p,finished)  !! change all "name" variable values to "Fred"
+    
+    implicit none
+    
+    type(json_value),pointer,intent(in) :: p
+    logical,intent(out) :: finished
+    
+    integer :: var_type
+    character(kind=CK,len=:),allocatable :: str
+    logical :: found
+    
+    !get info about this variable:
+    call json_info(p,var_type=var_type,name=str)
+    
+    !it must be a string named "name":
+    if (var_type==json_string .and. str=='name') then
+        call json_get(p,'@',str)             ! get original name
+        call json_update(p,'@','Fred',found) !change it
+        write(error_unit,'(A)') str//' name changed'
+        icount = icount + 1
+    end if
+    
+    !cleanup:
+    if (allocated(str)) deallocate(str)
+    
+    !always false, since we want to traverse all nodes:
+    finished = .false.
+   
+    end subroutine rename
+
+end module jf_test_14_mod
+!*****************************************************************************************
+
+!*****************************************************************************************
+program jf_test_14
+
+    !! 14th unit test.
+    
+    use jf_test_14_mod, only: test_14
+    implicit none
+    integer :: n_errors
+    call test_14(n_errors)
+    if ( n_errors /= 0) stop 1
+    
+end program jf_test_14
+!*****************************************************************************************