Merge pull request #349 from jacobwilliams/346-circular-destroy

Destroy a malformed JSON structure

Author: jacobwilliams

src/json_value_module.F90

@@ -99,6 +99,10 @@ module json_value_module
     !      "value": 0.1E+1
     !    }
     !````
+    !
+    !@warning Pointers of this type should only be allocated
+    !         using the methods from [[json_core(type)]].
+
     type,public :: json_value
 
         !force the constituents to be stored contiguously
@@ -2027,6 +2031,17 @@ end subroutine json_value_create
 !@note The original FSON version of this
 !      routine was not properly freeing the memory.
 !      It was rewritten.
+!
+!@note This routine destroys this variable, it's children, and
+!      (if `destroy_next` is true) the subsequent elements in
+!      an object or array. It does not destroy the parent or
+!      previous elements.
+!
+!@Note There is some protection here to enable destruction of
+!      improperly-created linked lists. However, likely there
+!      are cases not handled. Use the [[json_value_validate]]
+!      method to validate a JSON structure that was manually
+!      created using [[json_value]] pointers.
 
     recursive subroutine json_value_destroy(json,p,destroy_next)
 
@@ -2037,8 +2052,9 @@ recursive subroutine json_value_destroy(json,p,destroy_next)
     logical(LK),intent(in),optional :: destroy_next !! if true, then `p%next`
                                                     !! is also destroyed (default is true)
 
-    logical(LK) :: des_next
-    type(json_value), pointer :: child
+    logical(LK) :: des_next  !! local copy of `destroy_next` optional argument
+    type(json_value), pointer :: child  !! for getting child elements
+    logical :: circular  !! to check to malformed linked lists
 
     if (associated(p)) then
 
@@ -2052,16 +2068,26 @@ recursive subroutine json_value_destroy(json,p,destroy_next)
 
         call destroy_json_data(p)
 
+        if (associated(p%next)) then
+            ! check for circular references:
+            if (associated(p, p%next)) nullify(p%next)
+        end if
+
         if (associated(p%children)) then
             do while (p%n_children > 0)
                 child => p%children
                 if (associated(child)) then
                     p%children => p%children%next
                     p%n_children = p%n_children - 1
-                    call json%destroy(child,.false.)
+                    ! check children for circular references:
+                    circular = (associated(p%children) .and. &
+                                associated(p%children,child))
+                    call json%destroy(child,destroy_next=.false.)
+                    if (circular) exit
                 else
-                    call json%throw_exception('Error in json_value_destroy: '//&
-                                              'Malformed JSON linked list')
+                    ! it is a malformed JSON object. But, we will
+                    ! press ahead with the destroy process, since
+                    ! otherwise, there would be no way to destroy it.
                     exit
                 end if
             end do
@@ -2075,7 +2101,7 @@ recursive subroutine json_value_destroy(json,p,destroy_next)
         if (associated(p%parent))   nullify(p%parent)
         if (associated(p%tail))     nullify(p%tail)
 
-        deallocate(p)
+        if (associated(p)) deallocate(p)
         nullify(p)
 
     end if
@@ -2657,9 +2683,15 @@ recursive subroutine check_if_valid(p,require_parent)
 
             ! now, check next one:
             if (associated(p%next)) then
-                ! if it's an element in an
-                ! array, then require a parent:
-                call check_if_valid(p%next,require_parent=.true.)
+                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

src/tests/jf_test_35.F90

@@ -0,0 +1,103 @@
+!*****************************************************************************************
+!>
+!  Module for the 35th unit test.
+
+module jf_test_35_mod
+
+    use json_module, rk => json_rk, lk => json_lk, ik => json_ik, ck => json_ck, cdk => json_cdk
+    use, intrinsic :: iso_fortran_env , only: error_unit, output_unit
+
+    implicit none
+
+    private
+    public :: test_35
+
+contains
+
+    subroutine test_35(error_cnt)
+
+    !! Test destroy a malformed JSON structure
+
+    implicit none
+
+    integer,intent(out) :: error_cnt
+
+    type(json_core) :: json
+    type(json_value),pointer :: p_root,p_array
+    logical(LK) :: is_valid  !! True if the structure is valid.
+    character(kind=CK,len=:),allocatable :: error_msg !! error message from `validate`
+    integer :: i !! counter
+
+    error_cnt = 0
+
+    write(error_unit,'(A)') ''
+    write(error_unit,'(A)') '================================='
+    write(error_unit,'(A)') '   TEST 35'
+    write(error_unit,'(A)') '================================='
+    write(error_unit,'(A)') ''
+
+    do i = 1, 2
+
+        write(error_unit,'(A)') ''
+
+        if (i==1) then
+            call json%create_object(p_root, '')
+            call json%create_array(p_array, 'array')
+            call json%add(p_array,'',1)
+            call json%add(p_root,p_array)
+            call json%add(p_root,p_array)  ! this creates a malformed JSON structure
+        elseif (i==2) then
+            call json%create_array(p_array, '')
+            call json%create_object(p_root, 'object')
+            call json%add(p_root,'int',1)
+            call json%add(p_array,p_root)
+            call json%add(p_array,p_root)  ! this creates a malformed JSON structure
+            ! note: below we will destroy p_root, which is the duplicate array element
+        end if
+
+        ! test initialize_json_core:
+        call json%initialize()
+
+        call json%print(p_root,error_unit)
+
+        ! validate it:
+        call json%validate(p_root,is_valid,error_msg)
+        if (.not. is_valid) then
+            write(error_unit,'(A)') 'Validation failed, as expected: '//error_msg
+        end if
+
+        call json%destroy(p_root)  ! this crashes with: malloc: *** error
+                                   ! for object 0x7f9bea500300: pointer being
+                                   ! freed was not allocated
+
+        if (json%failed()) then
+            call json%print_error_message(error_unit)
+            error_cnt = error_cnt + 1
+        else
+            write(error_unit,'(A)') 'Destroy successful'
+        end if
+        write(error_unit,'(A)') ''
+
+    end do
+
+    end subroutine test_35
+
+end module jf_test_35_mod
+!*****************************************************************************************
+
+#ifndef INTERGATED_TESTS
+!*****************************************************************************************
+program jf_test_35
+
+    !! 35th unit test.
+
+    use jf_test_35_mod , only: test_35
+    implicit none
+    integer :: n_errors
+    n_errors = 0
+    call test_35(n_errors)
+    if (n_errors /= 0) stop 1
+
+end program jf_test_35
+!*****************************************************************************************
+#endif