!***************************************************************************************** !> author: Jacob Williams ! license: BSD ! ! This module provides a low-level interface for manipulation of JSON data. ! The two public entities are [[json_value]], and [[json_core(type)]]. ! The [[json_file_module]] provides a higher-level interface to some ! of these routines. ! !### License ! * JSON-Fortran is released under a BSD-style license. ! See the [LICENSE](https://github.com/jacobwilliams/json-fortran/blob/master/LICENSE) ! file for details. module json_value_module use,intrinsic :: iso_fortran_env, only: iostat_end,error_unit,output_unit use,intrinsic :: ieee_arithmetic use json_kinds use json_parameters use json_string_utilities implicit none private #include "json_macros.inc" !********************************************************* !> ! If Unicode is not enabled, then ! JSON files are opened using access='STREAM' and ! form='UNFORMATTED'. This allows the file to ! be read faster. ! #ifdef USE_UCS4 logical,parameter :: use_unformatted_stream = .false. #else logical,parameter :: use_unformatted_stream = .true. #endif !********************************************************* !********************************************************* !> ! If Unicode is not enabled, then ! JSON files are opened using access='STREAM' and ! form='UNFORMATTED'. This allows the file to ! be read faster. ! #ifdef USE_UCS4 character(kind=CDK,len=*),parameter :: access_spec = 'SEQUENTIAL' #else character(kind=CDK,len=*),parameter :: access_spec = 'STREAM' #endif !********************************************************* !********************************************************* !> ! If Unicode is not enabled, then ! JSON files are opened using access='STREAM' and ! form='UNFORMATTED'. This allows the file to ! be read faster. ! #ifdef USE_UCS4 character(kind=CDK,len=*),parameter :: form_spec = 'FORMATTED' #else character(kind=CDK,len=*),parameter :: form_spec = 'UNFORMATTED' #endif !********************************************************* !********************************************************* !> ! Type used to construct the linked-list JSON structure. ! Normally, this should always be a pointer variable. ! This type should only be used by an instance of [[json_core(type)]]. ! !### Example ! ! The following test program: ! !````fortran ! program test ! use json_module ! implicit none ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_object(p,'') !create the root ! call json%add(p,'year',1805) !add some data ! call json%add(p,'value',1.0_RK) !add some data ! call json%print(p,'test.json') !write it to a file ! call json%destroy(p) !cleanup ! end program test !```` ! ! Produces the JSON file **test.json**: ! !````json ! { ! "year": 1805, ! "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 ![note: on Intel, the order of the variables below ! is significant to avoid the misaligned field warnings] sequence private !for the linked list: type(json_value),pointer :: previous => null() !! previous item in the list type(json_value),pointer :: next => null() !! next item in the list type(json_value),pointer :: parent => null() !! parent item of this type(json_value),pointer :: children => null() !! first child item of this type(json_value),pointer :: tail => null() !! last child item of this character(kind=CK,len=:),allocatable :: name !! variable name (unescaped) real(RK),allocatable :: dbl_value !! real data for this variable logical(LK),allocatable :: log_value !! logical data for this variable character(kind=CK,len=:),allocatable :: str_value !! string data for this variable !! (unescaped) integer(IK),allocatable :: int_value !! integer data for this variable integer(IK) :: var_type = json_unknown !! variable type integer(IK),private :: n_children = 0 !! number of children end type json_value !********************************************************* !********************************************************* !> ! To access the core routines for manipulation ! of [[json_value]] pointer variables. This class allows ! for thread safe use of the module. ! !### Usage !````fortran ! program test ! use json_module, wp=>json_RK ! implicit none ! type(json_core) :: json !<--have to declare this ! type(json_value),pointer :: p ! call json%create_object(p,'') !create the root ! call json%add(p,'year',1805) !add some data ! call json%add(p,'value',1.0_wp) !add some data ! call json%print(p,'test.json') !write it to a file ! call json%destroy(p) !cleanup ! end program test !```` type,public :: json_core private integer(IK) :: spaces_per_tab = 2 !! number of spaces for indenting logical(LK) :: compact_real = .true. !! to use the "compact" form of real !! numbers for output character(kind=CDK,len=:),allocatable :: real_fmt !! the format string to use !! for converting real numbers to strings. !! It can be set in [[json_initialize]], !! and used in [[json_value_print]] !! If not set, then `default_real_fmt` !! is used instead. logical(LK) :: is_verbose = .false. !! if true, all exceptions are !! immediately printed to console. logical(LK) :: stop_on_error = .false. !! if true, then the program is !! stopped immediately when an !! exception is raised. logical(LK) :: exception_thrown = .false. !! The error flag. Will be set to true !! when an error is thrown in the class. !! Many of the methods will check this !! and return immediately if it is true. character(kind=CK,len=:),allocatable :: err_message !! the error message. !! if `exception_thrown=False` then !! this variable is not allocated. integer(IK) :: char_count = 0 !! character position in the current line integer(IK) :: line_count = 1 !! lines read counter integer(IK) :: pushed_index = 0 !! used when parsing lines in file character(kind=CK,len=pushed_char_size) :: pushed_char = CK_'' !! used when parsing !! lines in file integer(IK) :: ipos = 1 !! for allocatable strings: next character to read logical(LK) :: strict_type_checking = .false. !! if true, then no type conversions are done !! in the `get` routines if the actual variable !! type is different from the return type (for !! example, integer to real). logical(LK) :: trailing_spaces_significant = .false. !! for name and path comparisons, if trailing !! space is to be considered significant. logical(LK) :: case_sensitive_keys = .true. !! if name and path comparisons !! are case sensitive. logical(LK) :: no_whitespace = .false. !! when printing a JSON string, don't include !! non-significant spaces or line breaks. !! If true, the entire structure will be !! printed on one line. logical(LK) :: unescaped_strings = .true. !! If false, then the escaped !! string is returned from [[json_get_string]] !! and similar routines. If true [default], !! then the string is returned unescaped. logical(LK) :: allow_comments = .true. !! if true, any comments will be ignored when !! parsing a file. The comment tokens are defined !! by the `comment_char` character variable. character(kind=CK,len=:),allocatable :: comment_char !! comment tokens when !! `allow_comments` is true. !! Examples: '`!`' or '`#`'. !! Default is `CK_'/!#'`. integer(IK) :: path_mode = 1_IK !! How the path strings are interpreted in the !! `get_by_path` routines: !! !! * 1 -- Default mode (see [[json_get_by_path_default]]) !! * 2 -- as RFC 6901 "JSON Pointer" paths !! (see [[json_get_by_path_rfc6901]]) !! * 3 -- JSONPath "bracket-notation" !! see [[json_get_by_path_jsonpath_bracket]]) character(kind=CK,len=1) :: path_separator = dot !! The `path` separator to use !! in the "default" mode for !! the paths in the various !! `get_by_path` routines. !! Note: if `path_mode/=1` !! then this is ignored. logical(LK) :: compress_vectors = .false. !! If true, then arrays of integers, !! nulls, reals, & logicals are !! printed all on one line. !! [Note: `no_whitespace` will !! override this option if necessary] logical(LK) :: allow_duplicate_keys = .true. !! If False, then after parsing, if any !! duplicate keys are found, an error is !! thrown. A call to [[json_value_validate]] !! will also check for duplicates. If True !! [default] then no special checks are done logical(LK) :: escape_solidus = .false. !! If True then the solidus "`/`" is always escaped !! ("`\/`") when serializing JSON. !! If False [default], then it is not escaped. !! Note that this option does not affect parsing !! (both escaped and unescaped versions are still !! valid in all cases). integer(IK) :: null_to_real_mode = 2_IK !! if `strict_type_checking=false`: !! !! * 1 : an exception will be raised if !! try to retrieve a `null` as a real. !! * 2 : a `null` retrieved as a real !! will return NaN. [default] !! * 3 : a `null` retrieved as a real !! will return 0.0. logical(LK) :: non_normals_to_null = .false. !! How to serialize NaN, Infinity, !! and -Infinity real values: !! !! * If true : as JSON `null` values !! * If false : as strings (e.g., "NaN", !! "Infinity", "-Infinity") [default] logical(LK) :: use_quiet_nan = .true. !! if true [default], `null_to_real_mode=2` !! and [[string_to_real]] will use !! `ieee_quiet_nan` for NaN values. If false, !! `ieee_signaling_nan` will be used. logical(LK) :: strict_integer_type_checking = .true. !! * If false, when parsing JSON, if an integer numeric value !! cannot be converted to an integer (`integer(IK)`), !! then an attempt is then make to convert it !! to a real (`real(RK)`). !! * If true [default], an exception will be raised if an integer !! value cannot be read when parsing JSON. logical(LK) :: allow_trailing_comma = .true. !! Allow a single trailing comma in arrays and objects. integer :: ichunk = 0 !! index in `chunk` for [[pop_char]] !! when `use_unformatted_stream=True` integer :: filesize = 0 !! the file size when when `use_unformatted_stream=True` character(kind=CK,len=:),allocatable :: chunk !! a chunk read from a stream file !! when `use_unformatted_stream=True` contains private !> ! Return a child of a [[json_value]] structure. generic,public :: get_child => json_value_get_child_by_index, & json_value_get_child,& MAYBEWRAP(json_value_get_child_by_name) procedure,private :: json_value_get_child_by_index procedure,private :: MAYBEWRAP(json_value_get_child_by_name) procedure,private :: json_value_get_child !> ! Add objects to a linked list of [[json_value]]s. ! !@note It might make more sense to call this `add_child`. generic,public :: add => json_value_add_member, & MAYBEWRAP(json_value_add_null), & MAYBEWRAP(json_value_add_integer), & MAYBEWRAP(json_value_add_integer_vec), & #ifndef REAL32 MAYBEWRAP(json_value_add_real32), & MAYBEWRAP(json_value_add_real32_vec), & #endif MAYBEWRAP(json_value_add_real), & MAYBEWRAP(json_value_add_real_vec), & #ifdef REAL128 MAYBEWRAP(json_value_add_real64), & MAYBEWRAP(json_value_add_real64_vec), & #endif MAYBEWRAP(json_value_add_logical), & MAYBEWRAP(json_value_add_logical_vec), & MAYBEWRAP(json_value_add_string), & MAYBEWRAP(json_value_add_string_vec) #ifdef USE_UCS4 generic,public :: add => json_value_add_string_name_ascii, & json_value_add_string_val_ascii, & json_value_add_string_vec_name_ascii, & json_value_add_string_vec_val_ascii #endif procedure,private :: json_value_add_member procedure,private :: MAYBEWRAP(json_value_add_integer) procedure,private :: MAYBEWRAP(json_value_add_null) procedure,private :: MAYBEWRAP(json_value_add_integer_vec) #ifndef REAL32 procedure,private :: MAYBEWRAP(json_value_add_real32) procedure,private :: MAYBEWRAP(json_value_add_real32_vec) #endif procedure,private :: MAYBEWRAP(json_value_add_real) procedure,private :: MAYBEWRAP(json_value_add_real_vec) #ifdef REAL128 procedure,private :: MAYBEWRAP(json_value_add_real64) procedure,private :: MAYBEWRAP(json_value_add_real64_vec) #endif procedure,private :: MAYBEWRAP(json_value_add_logical) procedure,private :: MAYBEWRAP(json_value_add_logical_vec) procedure,private :: MAYBEWRAP(json_value_add_string) procedure,private :: MAYBEWRAP(json_value_add_string_vec) #ifdef USE_UCS4 procedure,private :: json_value_add_string_name_ascii procedure,private :: json_value_add_string_val_ascii procedure,private :: json_value_add_string_vec_name_ascii procedure,private :: json_value_add_string_vec_val_ascii #endif !> ! These are like the `add` methods, except if a variable with the ! same path is already present, then its value is simply updated. ! Note that currently, these only work for scalar variables. ! These routines can also change the variable's type (but an error will be ! thrown if the existing variable is not a scalar). ! !### See also ! * [[json_core(type):add_by_path]] - this one can be used to change ! arrays and objects to scalars if so desired. ! !@note Unlike some routines, the `found` output is not optional, ! so it doesn't present exceptions from being thrown. ! !@note These have been mostly supplanted by the [[json_core(type):add_by_path]] ! methods, which do a similar thing (and can be used for ! scalars and vectors, etc.) generic,public :: update => MAYBEWRAP(json_update_logical),& #ifndef REAL32 MAYBEWRAP(json_update_real32),& #endif MAYBEWRAP(json_update_real),& #ifdef REAL128 MAYBEWRAP(json_update_real64),& #endif MAYBEWRAP(json_update_integer),& MAYBEWRAP(json_update_string) #ifdef USE_UCS4 generic,public :: update => json_update_string_name_ascii,& json_update_string_val_ascii #endif procedure,private :: MAYBEWRAP(json_update_logical) #ifndef REAL32 procedure,private :: MAYBEWRAP(json_update_real32) #endif procedure,private :: MAYBEWRAP(json_update_real) #ifdef REAL128 procedure,private :: MAYBEWRAP(json_update_real64) #endif procedure,private :: MAYBEWRAP(json_update_integer) procedure,private :: MAYBEWRAP(json_update_string) #ifdef USE_UCS4 procedure,private :: json_update_string_name_ascii procedure,private :: json_update_string_val_ascii #endif !> ! Add variables to a [[json_value]] linked list ! by specifying their paths. ! !### Example ! !````fortran ! use, intrinsic :: iso_fortran_env, only: output_unit ! use json_module, wp=>json_RK ! type(json_core) :: json ! type(json_value) :: p ! call json%create_object(p,'root') ! create the root ! ! now add some variables using the paths: ! call json%add_by_path(p,'inputs.t', 0.0_wp ) ! call json%add_by_path(p,'inputs.x(1)', 100.0_wp) ! call json%add_by_path(p,'inputs.x(2)', 200.0_wp) ! call json%print(p) ! now print to console !```` ! !### Notes ! * This uses [[json_create_by_path]] ! !### See also ! * The `json_core%update` methods. ! * [[json_create_by_path]] generic,public :: add_by_path => MAYBEWRAP(json_add_member_by_path),& MAYBEWRAP(json_add_integer_by_path),& #ifndef REAL32 MAYBEWRAP(json_add_real32_by_path),& #endif MAYBEWRAP(json_add_real_by_path),& #ifdef REAL128 MAYBEWRAP(json_add_real64_by_path),& #endif MAYBEWRAP(json_add_logical_by_path),& MAYBEWRAP(json_add_string_by_path),& MAYBEWRAP(json_add_integer_vec_by_path),& #ifndef REAL32 MAYBEWRAP(json_add_real32_vec_by_path),& #endif MAYBEWRAP(json_add_real_vec_by_path),& #ifdef REAL128 MAYBEWRAP(json_add_real64_vec_by_path),& #endif MAYBEWRAP(json_add_logical_vec_by_path),& MAYBEWRAP(json_add_string_vec_by_path) #ifdef USE_UCS4 generic,public :: add_by_path => json_add_string_by_path_value_ascii,& json_add_string_by_path_path_ascii,& json_add_string_vec_by_path_value_ascii,& json_add_string_vec_by_path_path_ascii #endif procedure :: MAYBEWRAP(json_add_member_by_path) procedure :: MAYBEWRAP(json_add_integer_by_path) #ifndef REAL32 procedure :: MAYBEWRAP(json_add_real32_by_path) #endif procedure :: MAYBEWRAP(json_add_real_by_path) #ifdef REAL128 procedure :: MAYBEWRAP(json_add_real64_by_path) #endif procedure :: MAYBEWRAP(json_add_logical_by_path) procedure :: MAYBEWRAP(json_add_string_by_path) procedure :: MAYBEWRAP(json_add_integer_vec_by_path) #ifndef REAL32 procedure :: MAYBEWRAP(json_add_real32_vec_by_path) #endif procedure :: MAYBEWRAP(json_add_real_vec_by_path) #ifdef REAL128 procedure :: MAYBEWRAP(json_add_real64_vec_by_path) #endif procedure :: MAYBEWRAP(json_add_logical_vec_by_path) procedure :: MAYBEWRAP(json_add_string_vec_by_path) #ifdef USE_UCS4 procedure :: json_add_string_by_path_value_ascii procedure :: json_add_string_by_path_path_ascii procedure :: json_add_string_vec_by_path_value_ascii procedure :: json_add_string_vec_by_path_path_ascii #endif !> ! Create a [[json_value]] linked list using the ! path to the variables. Optionally return a ! pointer to the variable. ! ! (This will create a `null` variable) ! !### See also ! * [[json_core(type):add_by_path]] generic,public :: create => MAYBEWRAP(json_create_by_path) procedure :: MAYBEWRAP(json_create_by_path) !> ! Get data from a [[json_value]] linked list. ! !@note There are two versions (e.g. [[json_get_integer]] and [[json_get_integer_by_path]]). ! The first one gets the value from the [[json_value]] passed into the routine, ! while the second one gets the value from the [[json_value]] found by parsing the ! path. The path version is split up into unicode and non-unicode versions. generic,public :: get => & MAYBEWRAP(json_get_by_path), & json_get_integer, MAYBEWRAP(json_get_integer_by_path), & json_get_integer_vec, MAYBEWRAP(json_get_integer_vec_by_path), & #ifndef REAL32 json_get_real32, MAYBEWRAP(json_get_real32_by_path), & json_get_real32_vec, MAYBEWRAP(json_get_real32_vec_by_path), & #endif json_get_real, MAYBEWRAP(json_get_real_by_path), & json_get_real_vec, MAYBEWRAP(json_get_real_vec_by_path), & #ifdef REAL128 json_get_real64, MAYBEWRAP(json_get_real64_by_path), & json_get_real64_vec, MAYBEWRAP(json_get_real64_vec_by_path), & #endif json_get_logical, MAYBEWRAP(json_get_logical_by_path), & json_get_logical_vec, MAYBEWRAP(json_get_logical_vec_by_path), & json_get_string, MAYBEWRAP(json_get_string_by_path), & json_get_string_vec, MAYBEWRAP(json_get_string_vec_by_path), & json_get_alloc_string_vec, MAYBEWRAP(json_get_alloc_string_vec_by_path),& json_get_array, MAYBEWRAP(json_get_array_by_path) procedure,private :: json_get_integer procedure,private :: json_get_integer_vec #ifndef REAL32 procedure,private :: json_get_real32 procedure,private :: json_get_real32_vec #endif procedure,private :: json_get_real procedure,private :: json_get_real_vec #ifdef REAL128 procedure,private :: json_get_real64 procedure,private :: json_get_real64_vec #endif procedure,private :: json_get_logical procedure,private :: json_get_logical_vec procedure,private :: json_get_string procedure,private :: json_get_string_vec procedure,private :: json_get_alloc_string_vec procedure,private :: json_get_array procedure,private :: MAYBEWRAP(json_get_by_path) procedure,private :: MAYBEWRAP(json_get_integer_by_path) procedure,private :: MAYBEWRAP(json_get_integer_vec_by_path) #ifndef REAL32 procedure,private :: MAYBEWRAP(json_get_real32_by_path) procedure,private :: MAYBEWRAP(json_get_real32_vec_by_path) #endif procedure,private :: MAYBEWRAP(json_get_real_by_path) procedure,private :: MAYBEWRAP(json_get_real_vec_by_path) #ifdef REAL128 procedure,private :: MAYBEWRAP(json_get_real64_by_path) procedure,private :: MAYBEWRAP(json_get_real64_vec_by_path) #endif procedure,private :: MAYBEWRAP(json_get_logical_by_path) procedure,private :: MAYBEWRAP(json_get_logical_vec_by_path) procedure,private :: MAYBEWRAP(json_get_string_by_path) procedure,private :: MAYBEWRAP(json_get_string_vec_by_path) procedure,private :: MAYBEWRAP(json_get_array_by_path) procedure,private :: MAYBEWRAP(json_get_alloc_string_vec_by_path) procedure,private :: json_get_by_path_default procedure,private :: json_get_by_path_rfc6901 procedure,private :: json_get_by_path_jsonpath_bracket !> ! Print the [[json_value]] to an output unit or file. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value) :: p ! !... ! call json%print(p,'test.json') !this is [[json_print_to_filename]] !```` generic,public :: print => json_print_to_console,& json_print_to_unit,& json_print_to_filename procedure :: json_print_to_console procedure :: json_print_to_unit procedure :: json_print_to_filename !> ! Destructor routine for a [[json_value]] pointer. ! This must be called explicitly if it is no longer needed, ! before it goes out of scope. Otherwise, a memory leak will result. ! !### Example ! ! Destroy the [[json_value]] pointer before the variable goes out of scope: !````fortran ! subroutine example1() ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_object(p,'') ! call json%add(p,'year',2015) ! call json%print(p) ! call json%destroy(p) ! end subroutine example1 !```` ! ! Note: it should NOT be called for a [[json_value]] pointer than has already been ! added to another [[json_value]] structure, since doing so may render the ! other structure invalid. Consider the following example: !````fortran ! subroutine example2(p) ! type(json_core) :: json ! type(json_value),pointer,intent(out) :: p ! type(json_value),pointer :: q ! call json%create_object(p,'') ! call json%add(p,'year',2015) ! call json%create_object(q,'q') ! call json%add(q,'val',1) ! call json%add(p, q) !add q to p structure ! ! do NOT call json%destroy(q) here, because q is ! ! now part of the output structure p. p should be destroyed ! ! somewhere upstream by the caller of this routine. ! nullify(q) !OK, but not strictly necessary ! end subroutine example2 !```` generic,public :: destroy => json_value_destroy,destroy_json_core procedure :: json_value_destroy procedure :: destroy_json_core !> ! If the child variable is present, then remove it. generic,public :: remove_if_present => MAYBEWRAP(json_value_remove_if_present) procedure :: MAYBEWRAP(json_value_remove_if_present) !> ! Allocate a [[json_value]] pointer and make it a real variable. ! The pointer should not already be allocated. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_real(p,'value',1.0_RK) !```` ! !### Note ! * [[json_core(type):create_real]] is just an alias ! to this one for backward compatibility. generic,public :: create_real => MAYBEWRAP(json_value_create_real) procedure :: MAYBEWRAP(json_value_create_real) #ifndef REAL32 generic,public :: create_real => MAYBEWRAP(json_value_create_real32) procedure :: MAYBEWRAP(json_value_create_real32) #endif #ifdef REAL128 generic,public :: create_real => MAYBEWRAP(json_value_create_real64) procedure :: MAYBEWRAP(json_value_create_real64) #endif !> ! This is equivalent to [[json_core(type):create_real]], ! and is here only for backward compatibility. generic,public :: create_double => MAYBEWRAP(json_value_create_real) #ifndef REAL32 generic,public :: create_double => MAYBEWRAP(json_value_create_real32) #endif #ifdef REAL128 generic,public :: create_double => MAYBEWRAP(json_value_create_real64) #endif !> ! Allocate a [[json_value]] pointer and make it an array variable. ! The pointer should not already be allocated. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_array(p,'arrayname') !```` generic,public :: create_array => MAYBEWRAP(json_value_create_array) procedure :: MAYBEWRAP(json_value_create_array) !> ! Allocate a [[json_value]] pointer and make it an object variable. ! The pointer should not already be allocated. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_object(p,'objectname') !```` ! !@note The name is not significant for the root structure or an array element. ! In those cases, an empty string can be used. generic,public :: create_object => MAYBEWRAP(json_value_create_object) procedure :: MAYBEWRAP(json_value_create_object) !> ! Allocate a json_value pointer and make it a null variable. ! The pointer should not already be allocated. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_null(p,'value') !```` generic,public :: create_null => MAYBEWRAP(json_value_create_null) procedure :: MAYBEWRAP(json_value_create_null) !> ! Allocate a json_value pointer and make it a string variable. ! The pointer should not already be allocated. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_string(p,'value','foobar') !```` generic,public :: create_string => MAYBEWRAP(json_value_create_string) procedure :: MAYBEWRAP(json_value_create_string) !> ! Allocate a json_value pointer and make it an integer variable. ! The pointer should not already be allocated. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_integer(p,42,'value') !```` generic,public :: create_integer => MAYBEWRAP(json_value_create_integer) procedure :: MAYBEWRAP(json_value_create_integer) !> ! Allocate a json_value pointer and make it a logical variable. ! The pointer should not already be allocated. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value),pointer :: p ! call json%create_logical(p,'value',.true.) !```` generic,public :: create_logical => MAYBEWRAP(json_value_create_logical) procedure :: MAYBEWRAP(json_value_create_logical) !> ! Parse the JSON file and populate the [[json_value]] tree. generic,public :: load => json_parse_file procedure :: json_parse_file !> ! Print the [[json_value]] structure to an allocatable string procedure,public :: serialize => json_value_to_string !> ! The same as `serialize`, but only here for backward compatibility procedure,public :: print_to_string => json_value_to_string !> ! Parse the JSON string and populate the [[json_value]] tree. generic,public :: deserialize => MAYBEWRAP(json_parse_string) procedure :: MAYBEWRAP(json_parse_string) !> ! Same as `load` and `deserialize` but only here for backward compatibility. generic,public :: parse => json_parse_file, & MAYBEWRAP(json_parse_string) !> ! Throw an exception. generic,public :: throw_exception => MAYBEWRAP(json_throw_exception) procedure :: MAYBEWRAP(json_throw_exception) !> ! Rename a [[json_value]] variable. generic,public :: rename => MAYBEWRAP(json_value_rename),& MAYBEWRAP(json_rename_by_path) procedure :: MAYBEWRAP(json_value_rename) procedure :: MAYBEWRAP(json_rename_by_path) #ifdef USE_UCS4 generic,public :: rename => json_rename_by_path_name_ascii,& json_rename_by_path_path_ascii procedure :: json_rename_by_path_name_ascii procedure :: json_rename_by_path_path_ascii #endif !> ! get info about a [[json_value]] generic,public :: info => json_info, MAYBEWRAP(json_info_by_path) procedure :: json_info procedure :: MAYBEWRAP(json_info_by_path) !> ! get string info about a [[json_value]] generic,public :: string_info => json_string_info procedure :: json_string_info !> ! get matrix info about a [[json_value]] generic,public :: matrix_info => json_matrix_info, MAYBEWRAP(json_matrix_info_by_path) procedure :: json_matrix_info procedure :: MAYBEWRAP(json_matrix_info_by_path) !> ! insert a new element after an existing one, ! updating the JSON structure accordingly generic,public :: insert_after => json_value_insert_after, & json_value_insert_after_child_by_index procedure :: json_value_insert_after procedure :: json_value_insert_after_child_by_index !> ! get the path to a JSON variable in a structure: generic,public :: get_path => MAYBEWRAP(json_get_path) procedure :: MAYBEWRAP(json_get_path) !> ! verify if a path is valid ! (i.e., a variable with this path exists in the file). generic,public :: valid_path => MAYBEWRAP(json_valid_path) procedure :: MAYBEWRAP(json_valid_path) procedure,public :: remove => json_value_remove !! Remove a [[json_value]] from a !! linked-list structure. procedure,public :: replace => json_value_replace !! Replace a [[json_value]] in a !! linked-list structure. procedure,public :: reverse => json_value_reverse !! Reverse the order of the children !! of an array of object. procedure,public :: check_for_errors => json_check_for_errors !! check for error and get error message procedure,public :: clear_exceptions => json_clear_exceptions !! clear exceptions procedure,public :: count => json_count !! count the number of children procedure,public :: clone => json_clone !! clone a JSON structure (deep copy) procedure,public :: failed => json_failed !! check for error procedure,public :: get_parent => json_get_parent !! get pointer to json_value parent procedure,public :: get_next => json_get_next !! get pointer to json_value next procedure,public :: get_previous => json_get_previous !! get pointer to json_value previous procedure,public :: get_tail => json_get_tail !! get pointer to json_value tail procedure,public :: initialize => json_initialize !! to initialize some parsing parameters procedure,public :: traverse => json_traverse !! to traverse all elements of a JSON !! structure procedure,public :: print_error_message => json_print_error_message !! simply routine to print error !! messages procedure,public :: swap => json_value_swap !! Swap two [[json_value]] pointers !! in a structure (or two different !! structures). procedure,public :: is_child_of => json_value_is_child_of !! Check if a [[json_value]] is a !! descendant of another. procedure,public :: validate => json_value_validate !! Check that a [[json_value]] linked !! list is valid (i.e., is properly !! constructed). This may be useful !! if it has been constructed externally. procedure,public :: check_for_duplicate_keys & => json_check_all_for_duplicate_keys !! Check entire JSON structure !! for duplicate keys (recursively) procedure,public :: check_children_for_duplicate_keys & => json_check_children_for_duplicate_keys !! Check a `json_value` object's !! children for duplicate keys !other private routines: procedure :: name_equal procedure :: name_strings_equal procedure :: json_value_print procedure :: string_to_int procedure :: string_to_dble procedure :: prepare_parser => json_prepare_parser procedure :: parse_end => json_parse_end procedure :: parse_value procedure :: parse_number procedure :: parse_string procedure :: parse_for_chars procedure :: parse_object procedure :: parse_array procedure :: annotate_invalid_json procedure :: pop_char procedure :: push_char procedure :: get_current_line_from_file_stream procedure,nopass :: get_current_line_from_file_sequential procedure :: convert procedure :: to_string procedure :: to_logical procedure :: to_integer procedure :: to_real procedure :: to_null procedure :: to_object procedure :: to_array procedure,nopass :: json_value_clone_func procedure :: is_vector => json_is_vector end type json_core !********************************************************* !********************************************************* !> ! Structure constructor to initialize a ! [[json_core(type)]] object ! !### Example ! !```fortran ! type(json_file) :: json_core ! json_core = json_core() !``` interface json_core module procedure initialize_json_core end interface !********************************************************* !************************************************************************************* abstract interface subroutine json_array_callback_func(json, element, i, count) !! Array element callback function. Used by [[json_get_array]] import :: json_value,json_core,IK implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: element integer(IK),intent(in) :: i !! index integer(IK),intent(in) :: count !! size of array end subroutine json_array_callback_func subroutine json_traverse_callback_func(json,p,finished) !! Callback function used by [[json_traverse]] import :: json_value,json_core,LK implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: p logical(LK),intent(out) :: finished !! set true to stop traversing end subroutine json_traverse_callback_func end interface public :: json_array_callback_func public :: json_traverse_callback_func !************************************************************************************* contains !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 4/17/2016 ! ! Destructor for the [[json_core(type)]] type. subroutine destroy_json_core(me) implicit none class(json_core),intent(out) :: me end subroutine destroy_json_core !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 4/26/2016 ! ! Function constructor for a [[json_core(type)]]. ! This is just a wrapper for [[json_initialize]]. ! !@note [[initialize_json_core]], [[json_initialize]], ! [[initialize_json_core_in_file]], and [[initialize_json_file]] ! all have a similar interface. function initialize_json_core(& #include "json_initialize_dummy_arguments.inc" ) result(json_core_object) implicit none type(json_core) :: json_core_object #include "json_initialize_arguments.inc" call json_core_object%initialize(& #include "json_initialize_dummy_arguments.inc" ) end function initialize_json_core !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/4/2013 ! ! Initialize the [[json_core(type)]] instance. ! ! The routine may be called before any of the [[json_core(type)]] methods are used in ! order to specify certain parameters. If it is not called, then the defaults ! are used. This routine is also called internally by various routines. ! It can also be called to clear exceptions, or to reset some ! of the variables (note that only the arguments present are changed). ! !### Modified ! * Izaak Beekman : 02/24/2015 ! !@note [[initialize_json_core]], [[json_initialize]], ! [[initialize_json_core_in_file]], and [[initialize_json_file]] ! all have a similar interface. subroutine json_initialize(me,& #include "json_initialize_dummy_arguments.inc" ) implicit none class(json_core),intent(inout) :: me #include "json_initialize_arguments.inc" character(kind=CDK,len=10) :: w !! max string length character(kind=CDK,len=10) :: d !! real precision digits character(kind=CDK,len=10) :: e !! real exponent digits character(kind=CDK,len=2) :: sgn !! sign flag: `ss` or `sp` character(kind=CDK,len=2) :: rl_edit_desc !! `G`, `E`, `EN`, or `ES` integer(IK) :: istat !! `iostat` flag for !! write statements logical(LK) :: sgn_prnt !! print sign flag character(kind=CK,len=max_integer_str_len) :: istr !! for integer to !! string conversion !reset exception to false: call me%clear_exceptions() !Just in case, clear these global variables also: me%pushed_index = 0 me%pushed_char = CK_'' me%char_count = 0 me%line_count = 1 me%ipos = 1 if (use_unformatted_stream) then me%filesize = 0 me%ichunk = 0 me%chunk = repeat(space, stream_chunk_size) ! default chunk size end if #ifdef USE_UCS4 ! reopen stdout and stderr with utf-8 encoding open(output_unit,encoding='utf-8') open(error_unit, encoding='utf-8') #endif !various optional inputs: if (present(spaces_per_tab)) & me%spaces_per_tab = spaces_per_tab if (present(stop_on_error)) & me%stop_on_error = stop_on_error if (present(verbose)) & me%is_verbose = verbose if (present(strict_type_checking)) & me%strict_type_checking = strict_type_checking if (present(trailing_spaces_significant)) & me%trailing_spaces_significant = trailing_spaces_significant if (present(case_sensitive_keys)) & me%case_sensitive_keys = case_sensitive_keys if (present(no_whitespace)) & me%no_whitespace = no_whitespace if (present(unescape_strings)) & me%unescaped_strings = unescape_strings if (present(path_mode)) then if (path_mode==1_IK .or. path_mode==2_IK .or. path_mode==3_IK) then me%path_mode = path_mode else me%path_mode = 1_IK ! just to have a valid value call me%throw_exception('Invalid path_mode.') end if end if ! if we are allowing comments in the file: ! [an empty string disables comments] if (present(comment_char)) then me%allow_comments = comment_char/=CK_'' me%comment_char = trim(adjustl(comment_char)) end if ! path separator: if (present(path_separator)) then me%path_separator = path_separator end if ! printing vectors in compressed form: if (present(compress_vectors)) then me%compress_vectors = compress_vectors end if ! checking for duplicate keys: if (present(allow_duplicate_keys)) then me%allow_duplicate_keys = allow_duplicate_keys end if ! if escaping the forward slash: if (present(escape_solidus)) then me%escape_solidus = escape_solidus end if ! how to handle null to real conversions: if (present(null_to_real_mode)) then select case (null_to_real_mode) case(1_IK:3_IK) me%null_to_real_mode = null_to_real_mode case default me%null_to_real_mode = 2_IK ! just to have a valid value call integer_to_string(null_to_real_mode,int_fmt,istr) call me%throw_exception('Invalid null_to_real_mode: '//istr) end select end if ! how to handle NaN and Infinities: if (present(non_normal_mode)) then select case (non_normal_mode) case(1_IK) ! use strings me%non_normals_to_null = .false. case(2_IK) ! use null me%non_normals_to_null = .true. case default call integer_to_string(non_normal_mode,int_fmt,istr) call me%throw_exception('Invalid non_normal_mode: '//istr) end select end if if (present(use_quiet_nan)) then me%use_quiet_nan = use_quiet_nan end if if (present(strict_integer_type_checking)) then me%strict_integer_type_checking = strict_integer_type_checking end if if (present(allow_trailing_comma)) then me%allow_trailing_comma = allow_trailing_comma end if !Set the format for real numbers: ! [if not changing it, then it remains the same] if ( (.not. allocated(me%real_fmt)) .or. & ! if this hasn't been done yet present(compact_reals) .or. & present(print_signs) .or. & present(real_format) ) then !allow the special case where real format is '*': ! [this overrides the other options] if (present(real_format)) then if (real_format==star) then if (present(compact_reals)) then ! we will also allow for compact reals with ! '*' format, if both arguments are present. me%compact_real = compact_reals else me%compact_real = .false. end if me%real_fmt = star return end if end if if (present(compact_reals)) me%compact_real = compact_reals !set defaults sgn_prnt = .false. if ( present( print_signs) ) sgn_prnt = print_signs if ( sgn_prnt ) then sgn = 'sp' else sgn = 'ss' end if rl_edit_desc = 'E' if ( present( real_format ) ) then select case ( real_format ) case ('g','G','e','E','en','EN','es','ES') rl_edit_desc = real_format case default call me%throw_exception('Invalid real format, "' // & trim(real_format) // '", passed to json_initialize.'// & new_line('a') // 'Acceptable formats are: "G", "E", "EN", and "ES".' ) end select end if ! set the default output/input format for reals: write(w,'(ss,I0)',iostat=istat) max_numeric_str_len if (istat==0) write(d,'(ss,I0)',iostat=istat) real_precision if (istat==0) write(e,'(ss,I0)',iostat=istat) real_exponent_digits if (istat==0) then me%real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) //& trim(w) // '.' // trim(d) // 'E' // trim(e) // ')' else me%real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) // & '27.17E4)' !just use this one (should never happen) end if end if end subroutine json_initialize !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! ! Returns true if `name` is equal to `p%name`, using the specified ! settings for case sensitivity and trailing whitespace. ! !### History ! * 4/30/2016 : original version ! * 8/25/2017 : now just a wrapper for [[name_strings_equal]] function name_equal(json,p,name) result(is_equal) implicit none class(json_core),intent(inout) :: json type(json_value),intent(in) :: p !! the json object character(kind=CK,len=*),intent(in) :: name !! the name to check for logical(LK) :: is_equal !! true if the string are !! lexically equal if (allocated(p%name)) then ! call the low-level routines for the name strings: is_equal = json%name_strings_equal(p%name,name) else is_equal = name == CK_'' ! check a blank name end if end function name_equal !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 8/25/2017 ! ! Returns true if the name strings `name1` is equal to `name2`, using ! the specified settings for case sensitivity and trailing whitespace. function name_strings_equal(json,name1,name2) result(is_equal) implicit none class(json_core),intent(inout) :: json character(kind=CK,len=*),intent(in) :: name1 !! the name to check character(kind=CK,len=*),intent(in) :: name2 !! the name to check logical(LK) :: is_equal !! true if the string are !! lexically equal !must be the same length if we are treating !trailing spaces as significant, so do a !quick test of this first: if (json%trailing_spaces_significant) then is_equal = len(name1) == len(name2) if (.not. is_equal) return end if if (json%case_sensitive_keys) then is_equal = name1 == name2 else is_equal = lowercase_string(name1) == lowercase_string(name2) end if end function name_strings_equal !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 10/31/2015 ! ! Create a deep copy of a [[json_value]] linked-list structure. ! !### Notes ! ! * If `from` has children, then they are also cloned. ! * The parent of `from` is not linked to `to`. ! * If `from` is an element of an array, then the previous and ! next entries are not cloned (only that element and it's children, if any). ! !### Example ! !````fortran ! program test ! use json_module ! implicit none ! type(json_core) :: json ! type(json_value),pointer :: j1, j2 ! call json%load('files/inputs/test1.json',j1) ! call json%clone(j1,j2) !now have two independent copies ! call json%destroy(j1) !destroys j1, but j2 remains ! call json%print(j2,'j2.json') ! call json%destroy(j2) ! end program test !```` subroutine json_clone(json,from,to) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: from !! this is the structure to clone type(json_value),pointer :: to !! the clone is put here !! (it must not already be associated) !call the main function: call json%json_value_clone_func(from,to) end subroutine json_clone !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 10/31/2015 ! ! Recursive deep copy function called by [[json_clone]]. ! !@note If new data is added to the [[json_value]] type, ! then this would need to be updated. recursive subroutine json_value_clone_func(from,to,parent,previous,tail) implicit none type(json_value),pointer :: from !! this is the structure to clone type(json_value),pointer :: to !! the clone is put here (it !! must not already be associated) type(json_value),pointer,optional :: parent !! to%parent type(json_value),pointer,optional :: previous !! to%previous logical,optional :: tail !! if "to" is the tail of !! its parent's children nullify(to) if (associated(from)) then allocate(to) !copy over the data variables: ! [note: the allocate() statements don't work here for the ! deferred-length characters in gfortran-4.9] if (allocated(from%name)) to%name = from%name if (allocated(from%dbl_value)) allocate(to%dbl_value,source=from%dbl_value) if (allocated(from%log_value)) allocate(to%log_value,source=from%log_value) if (allocated(from%str_value)) to%str_value = from%str_value if (allocated(from%int_value)) allocate(to%int_value,source=from%int_value) to%var_type = from%var_type to%n_children = from%n_children ! allocate and associate the pointers as necessary: if (present(parent)) to%parent => parent if (present(previous)) to%previous => previous if (present(tail)) then if (tail .and. associated(to%parent)) to%parent%tail => to end if if (associated(from%next) .and. associated(to%parent)) then ! we only clone the next entry in an array ! if the parent has also been cloned call json_value_clone_func(from = from%next,& to = to%next,& previous = to,& parent = to%parent,& tail = (.not. associated(from%next%next))) end if if (associated(from%children)) then call json_value_clone_func(from = from%children,& to = to%children,& parent = to,& tail = (.not. associated(from%children%next))) end if end if end subroutine json_value_clone_func !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! ! Destroy the data within a [[json_value]], and reset type to `json_unknown`. pure subroutine destroy_json_data(d) implicit none type(json_value),intent(inout) :: d d%var_type = json_unknown if (allocated(d%log_value)) deallocate(d%log_value) if (allocated(d%int_value)) deallocate(d%int_value) if (allocated(d%dbl_value)) deallocate(d%dbl_value) if (allocated(d%str_value)) deallocate(d%str_value) end subroutine destroy_json_data !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 2/13/2014 ! ! Returns information about a [[json_value]]. subroutine json_info(json,p,var_type,n_children,name) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p integer(IK),intent(out),optional :: var_type !! variable type integer(IK),intent(out),optional :: n_children !! number of children character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name if (.not. json%exception_thrown .and. associated(p)) then if (present(var_type)) var_type = p%var_type if (present(n_children)) n_children = json%count(p) if (present(name)) then if (allocated(p%name)) then name = p%name else name = CK_'' end if end if else ! error if (.not. json%exception_thrown) then call json%throw_exception('Error in json_info: '//& 'pointer is not associated.' ) end if if (present(var_type)) var_type = json_unknown if (present(n_children)) n_children = 0 if (present(name)) name = CK_'' end if end subroutine json_info !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/18/2016 ! ! Returns information about character strings returned from a [[json_value]]. subroutine json_string_info(json,p,ilen,max_str_len,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p integer(IK),dimension(:),allocatable,intent(out),optional :: ilen !! if `p` is an array, this !! is the actual length !! of each character !! string in the array. !! if not an array, this !! is returned unallocated. integer(IK),intent(out),optional :: max_str_len !! The maximum length required to !! hold the string representation returned !! by a call to a `get` routine. If a scalar, !! this is just the length of the scalar. If !! a vector, this is the maximum length of !! any element. logical(LK),intent(out),optional :: found !! true if there were no errors. !! if not present, an error will !! throw an exception character(kind=CK,len=:),allocatable :: cval !! for getting values as strings. logical(LK) :: initialized !! if the output array has been sized logical(LK) :: get_max_len !! if we are returning the `max_str_len` logical(LK) :: get_ilen !! if we are returning the `ilen` array integer(IK) :: var_type !! variable type get_max_len = present(max_str_len) get_ilen = present(ilen) if (.not. json%exception_thrown) then if (present(found)) found = .true. initialized = .false. if (get_max_len) max_str_len = 0 select case (p%var_type) case (json_array) ! it's an array ! call routine for each element call json%get(p, array_callback=get_string_lengths) case default ! not an array if (json%strict_type_checking) then ! only allowing strings to be returned ! as strings, so we can check size directly call json%info(p,var_type=var_type) if (var_type==json_string) then if (allocated(p%str_value) .and. get_max_len) & max_str_len = len(p%str_value) else ! it isn't a string, so there is no length call json%throw_exception('Error in json_string_info: '//& 'When strict_type_checking is true '//& 'the variable must be a character string.',& found) end if else ! in this case, we have to get the value ! as a string to know what size it is. call json%get(p, value=cval) if (.not. json%exception_thrown) then if (allocated(cval) .and. get_max_len) & max_str_len = len(cval) end if end if end select end if if (json%exception_thrown) then if (present(found)) then call json%clear_exceptions() found = .false. end if if (get_max_len) max_str_len = 0 if (get_ilen) then if (allocated(ilen)) deallocate(ilen) end if end if contains subroutine get_string_lengths(json, element, i, count) !! callback function to call for each element in the array. implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: element integer(IK),intent(in) :: i !! index integer(IK),intent(in) :: count !! size of array character(kind=CK,len=:),allocatable :: cval integer(IK) :: var_type if (json%exception_thrown) return if (.not. initialized) then if (get_ilen) allocate(ilen(count)) initialized = .true. end if if (json%strict_type_checking) then ! only allowing strings to be returned ! as strings, so we can check size directly call json%info(element,var_type=var_type) if (var_type==json_string) then if (allocated(element%str_value)) then if (get_max_len) then if (len(element%str_value)>max_str_len) & max_str_len = len(element%str_value) end if if (get_ilen) ilen(i) = len(element%str_value) else if (get_ilen) ilen(i) = 0 end if else ! it isn't a string, so there is no length call json%throw_exception('Error in json_string_info: '//& 'When strict_type_checking is true '//& 'the array must contain only '//& 'character strings.',found) end if else ! in this case, we have to get the value ! as a string to know what size it is. call json%get(element, value=cval) if (json%exception_thrown) return if (allocated(cval)) then if (get_max_len) then if (len(cval)>max_str_len) max_str_len = len(cval) end if if (get_ilen) ilen(i) = len(cval) else if (get_ilen) ilen(i) = 0 end if end if end subroutine get_string_lengths end subroutine json_string_info !***************************************************************************************** !***************************************************************************************** ! ! Returns information about a [[json_value]], given the path. ! !### See also ! * [[json_info]] ! !@note If `found` is present, no exceptions will be thrown if an ! error occurs. Otherwise, an exception will be thrown if the ! variable is not found. subroutine json_info_by_path(json,p,path,found,var_type,n_children,name) implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: p !! a JSON linked list character(kind=CK,len=*),intent(in) :: path !! path to the variable logical(LK),intent(out),optional :: found !! true if it was found integer(IK),intent(out),optional :: var_type !! variable type integer(IK),intent(out),optional :: n_children !! number of children character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name type(json_value),pointer :: p_var !! temporary pointer logical(LK) :: ok !! if the variable was found #if defined __GFORTRAN__ character(kind=CK,len=:),allocatable :: p_name !! temporary variable for getting name #endif call json%get(p,path,p_var,found) !check if it was found: if (present(found)) then ok = found else ok = .not. json%exception_thrown end if if (.not. ok) then if (present(var_type)) var_type = json_unknown if (present(n_children)) n_children = 0 if (present(name)) name = CK_'' else !get info: #if defined __GFORTRAN__ call json%info(p_var,var_type,n_children) if (present(name)) then !workaround for gfortran bug if (allocated(p_var%name)) then p_name = p_var%name name = p_name else name = CK_'' end if end if #else call json%info(p_var,var_type,n_children,name) #endif end if end subroutine json_info_by_path !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_info_by_path]] where "path" is kind=CDK. subroutine wrap_json_info_by_path(json,p,path,found,var_type,n_children,name) implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: p !! a JSON linked list character(kind=CDK,len=*),intent(in) :: path !! path to the variable logical(LK),intent(out),optional :: found !! true if it was found integer(IK),intent(out),optional :: var_type !! variable type integer(IK),intent(out),optional :: n_children !! number of children character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name call json%info(p,to_unicode(path),found,var_type,n_children,name) end subroutine wrap_json_info_by_path !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 10/16/2015 ! ! Alternate version of [[json_info]] that returns matrix ! information about a [[json_value]]. ! ! A [[json_value]] is a valid rank 2 matrix if all of the following are true: ! ! * The var_type is *json_array* ! * Each child is also a *json_array*, each of which has the same number of elements ! * Each individual element has the same variable type (integer, logical, etc.) ! ! The idea here is that if it is a valid matrix, it can be interoperable with ! a Fortran rank 2 array of the same type. ! !### Example ! ! The following example is an array with `var_type=json_integer`, ! `n_sets=3`, and `set_size=4` ! !```json ! { ! "matrix": [ ! [1,2,3,4], ! [5,6,7,8], ! [9,10,11,12] ! ] ! } !``` subroutine json_matrix_info(json,p,is_matrix,var_type,n_sets,set_size,name) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p !! a JSON linked list logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix integer(IK),intent(out),optional :: var_type !! variable type of data in the matrix !! (if all elements have the same type) integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix !! rows if using row-major order) integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix !! cols if using row-major order) character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name type(json_value),pointer :: p_row !! for getting a set type(json_value),pointer :: p_element !! for getting an element in a set integer(IK) :: vartype !! json variable type of `p` integer(IK) :: row_vartype !! json variable type of a row integer(IK) :: element_vartype !! json variable type of an element in a row integer(IK) :: nr !! number of children of `p` integer(IK) :: nc !! number of elements in first child of `p` integer(IK) :: icount !! number of elements in a set integer(IK) :: i !! counter integer(IK) :: j !! counter #if defined __GFORTRAN__ character(kind=CK,len=:),allocatable :: p_name !! temporary variable for getting name #endif !get info about the variable: #if defined __GFORTRAN__ call json%info(p,vartype,nr) if (present(name)) then !workaround for gfortran bug if (allocated(p%name)) then p_name = p%name name = p_name else name = CK_'' end if end if #else call json%info(p,vartype,nr,name) #endif is_matrix = (vartype==json_array) if (is_matrix) then main : do i=1,nr nullify(p_row) call json%get_child(p,i,p_row) if (.not. associated(p_row)) then is_matrix = .false. call json%throw_exception('Error in json_matrix_info: '//& 'Malformed JSON linked list') exit main end if call json%info(p_row,var_type=row_vartype,n_children=icount) if (row_vartype==json_array) then if (i==1) nc = icount !number of columns in first row if (icount==nc) then !make sure each row has the same number of columns !see if all the variables in this row are the same type: do j=1,icount nullify(p_element) call json%get_child(p_row,j,p_element) if (.not. associated(p_element)) then is_matrix = .false. call json%throw_exception('Error in json_matrix_info: '//& 'Malformed JSON linked list') exit main end if call json%info(p_element,var_type=element_vartype) if (i==1 .and. j==1) vartype = element_vartype !type of first element !in the row if (vartype/=element_vartype) then !not all variables are the same time is_matrix = .false. exit main end if end do else is_matrix = .false. exit main end if else is_matrix = .false. exit main end if end do main end if if (is_matrix) then if (present(var_type)) var_type = vartype if (present(n_sets)) n_sets = nr if (present(set_size)) set_size = nc else if (present(var_type)) var_type = json_unknown if (present(n_sets)) n_sets = 0 if (present(set_size)) set_size = 0 end if end subroutine json_matrix_info !***************************************************************************************** !***************************************************************************************** !> ! Returns matrix information about a [[json_value]], given the path. ! !### See also ! * [[json_matrix_info]] ! !@note If `found` is present, no exceptions will be thrown if an ! error occurs. Otherwise, an exception will be thrown if the ! variable is not found. subroutine json_matrix_info_by_path(json,p,path,is_matrix,found,& var_type,n_sets,set_size,name) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p !! a JSON linked list character(kind=CK,len=*),intent(in) :: path !! path to the variable logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix logical(LK),intent(out),optional :: found !! true if it was found integer(IK),intent(out),optional :: var_type !! variable type of data in !! the matrix (if all elements have !! the same type) integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix !! rows if using row-major order) integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix !! cols if using row-major order) character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name type(json_value),pointer :: p_var logical(LK) :: ok #if defined __GFORTRAN__ character(kind=CK,len=:),allocatable :: p_name !! temporary variable for getting name #endif call json%get(p,path,p_var,found) !check if it was found: if (present(found)) then ok = found else ok = .not. json%exception_thrown end if if (.not. ok) then if (present(var_type)) var_type = json_unknown if (present(n_sets)) n_sets = 0 if (present(set_size)) set_size = 0 if (present(name)) name = CK_'' else !get info about the variable: #if defined __GFORTRAN__ call json%matrix_info(p_var,is_matrix,var_type,n_sets,set_size) if (present(name)) then !workaround for gfortran bug if (allocated(p_var%name)) then p_name = p_var%name name = p_name else name = CK_'' end if end if #else call json%matrix_info(p_var,is_matrix,var_type,n_sets,set_size,name) #endif if (json%exception_thrown .and. present(found)) then found = .false. call json%clear_exceptions() end if end if end subroutine json_matrix_info_by_path !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_matrix_info_by_path]] where "path" is kind=CDK. subroutine wrap_json_matrix_info_by_path(json,p,path,is_matrix,found,& var_type,n_sets,set_size,name) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p !! a JSON linked list character(kind=CDK,len=*),intent(in) :: path !! path to the variable logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix logical(LK),intent(out),optional :: found !! true if it was found integer(IK),intent(out),optional :: var_type !! variable type of data in !! the matrix (if all elements have !! the same type) integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix !! rows if using row-major order) integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix !! cols if using row-major order) character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name call json%matrix_info(p,to_unicode(path),is_matrix,found,var_type,n_sets,set_size,name) end subroutine wrap_json_matrix_info_by_path !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 4/29/2016 ! ! Rename a [[json_value]]. subroutine json_value_rename(json,p,name) implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: p character(kind=CK,len=*),intent(in) :: name !! new variable name if (json%trailing_spaces_significant) then p%name = name else p%name = trim(name) end if end subroutine json_value_rename !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 4/29/2016 ! ! Alternate version of [[json_value_rename]], where `name` is kind=CDK. subroutine wrap_json_value_rename(json,p,name) implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: p character(kind=CDK,len=*),intent(in) :: name !! new variable name call json%rename(p,to_unicode(name)) end subroutine wrap_json_value_rename !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/4/2013 ! ! Clear exceptions in the [[json_core(type)]]. pure subroutine json_clear_exceptions(json) implicit none class(json_core),intent(inout) :: json !clear the flag and message: json%exception_thrown = .false. if (allocated(json%err_message)) deallocate(json%err_message) end subroutine json_clear_exceptions !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/4/2013 ! ! Throw an exception in the [[json_core(type)]]. ! This routine sets the error flag, and prevents any subsequent routine ! from doing anything, until [[json_clear_exceptions]] is called. ! !@note If `is_verbose` is true, this will also print a ! traceback if the Intel compiler is used. ! !@note If `stop_on_error` is true, then the program is stopped. subroutine json_throw_exception(json,msg,found) #ifdef __INTEL_COMPILER use ifcore, only: tracebackqq #endif implicit none class(json_core),intent(inout) :: json character(kind=CK,len=*),intent(in) :: msg !! the error message logical(LK),intent(inout),optional :: found !! if the caller is handling the !! exception with an optimal return !! argument. If so, `json%stop_on_error` !! is ignored. logical(LK) :: stop_on_error json%exception_thrown = .true. json%err_message = trim(msg) stop_on_error = json%stop_on_error .and. .not. present(found) if (stop_on_error) then #ifdef __INTEL_COMPILER ! for Intel, we raise a traceback and quit call tracebackqq(string=trim(msg), user_exit_code=0) #else write(error_unit,'(A)') 'JSON-Fortran Exception: '//trim(msg) error stop 1 #endif elseif (json%is_verbose) then write(output_unit,'(A)') '***********************' write(output_unit,'(A)') 'JSON-Fortran Exception: '//trim(msg) !#if defined __GFORTRAN__ ! call backtrace() ! (have to compile with -fbacktrace -fall-intrinsics flags) !#endif #ifdef __INTEL_COMPILER call tracebackqq(user_exit_code=-1) ! print a traceback and return #endif write(output_unit,'(A)') '***********************' end if end subroutine json_throw_exception !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_throw_exception]], where `msg` is kind=CDK. subroutine wrap_json_throw_exception(json,msg,found) implicit none class(json_core),intent(inout) :: json character(kind=CDK,len=*),intent(in) :: msg !! the error message logical(LK),intent(inout),optional :: found !! if the caller is handling the !! exception with an optimal return !! argument. If so, `json%stop_on_error` !! is ignored. call json%throw_exception(to_unicode(msg),found) end subroutine wrap_json_throw_exception !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/4/2013 ! ! Retrieve error code from the [[json_core(type)]]. ! This should be called after `parse` to check for errors. ! If an error is thrown, before using the class again, [[json_initialize]] ! should be called to clean up before it is used again. ! !### Example ! !````fortran ! type(json_file) :: json ! logical :: status_ok ! character(kind=CK,len=:),allocatable :: error_msg ! call json%load(filename='myfile.json') ! call json%check_for_errors(status_ok, error_msg) ! if (.not. status_ok) then ! write(*,*) 'Error: '//error_msg ! call json%clear_exceptions() ! call json%destroy() ! end if !```` ! !### See also ! * [[json_failed]] ! * [[json_throw_exception]] subroutine json_check_for_errors(json,status_ok,error_msg) implicit none class(json_core),intent(in) :: json logical(LK),intent(out),optional :: status_ok !! true if there were no errors character(kind=CK,len=:),allocatable,intent(out),optional :: error_msg !! the error message. !! (not allocated if !! there were no errors) #if defined __GFORTRAN__ character(kind=CK,len=:),allocatable :: tmp !! workaround for gfortran bugs #endif if (present(status_ok)) status_ok = .not. json%exception_thrown if (present(error_msg)) then if (json%exception_thrown) then ! if an exception has been thrown, ! then this will always be allocated ! [see json_throw_exception] #if defined __GFORTRAN__ tmp = json%err_message error_msg = tmp #else error_msg = json%err_message #endif end if end if end subroutine json_check_for_errors !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/5/2013 ! ! Logical function to indicate if an exception has been thrown in a [[json_core(type)]]. ! !### Example ! !````fortran ! type(json_core) :: json ! type(json_value),pointer :: p ! logical :: status_ok ! character(len=:),allocatable :: error_msg ! call json%load(filename='myfile.json',p) ! if (json%failed()) then ! call json%check_for_errors(status_ok, error_msg) ! write(*,*) 'Error: '//error_msg ! call json%clear_exceptions() ! call json%destroy(p) ! end if !```` ! ! Note that [[json_file]] contains a wrapper for this routine, which is used like: !````fortran ! type(json_file) :: f ! logical :: status_ok ! character(len=:),allocatable :: error_msg ! call f%load(filename='myfile.json') ! if (f%failed()) then ! call f%check_for_errors(status_ok, error_msg) ! write(*,*) 'Error: '//error_msg ! call f%clear_exceptions() ! call f%destroy() ! end if !```` ! !### See also ! * [[json_check_for_errors]] pure function json_failed(json) result(failed) implicit none class(json_core),intent(in) :: json logical(LK) :: failed !! will be true if an exception !! has been thrown. failed = json%exception_thrown end function json_failed !***************************************************************************************** !***************************************************************************************** !> ! Allocate a [[json_value]] pointer variable. ! This should be called before adding data to it. ! !### Example ! !````fortran ! type(json_value),pointer :: var ! call json_value_create(var) ! call json%to_real(var,1.0_RK) !```` ! !### Notes ! 1. This routine does not check for exceptions. ! 2. The pointer should not already be allocated, or a memory leak will occur. subroutine json_value_create(p) implicit none type(json_value),pointer :: p nullify(p) allocate(p) end subroutine json_value_create !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 1/22/2014 ! ! Destroy a [[json_value]] linked-list structure. ! !@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. pure recursive subroutine json_value_destroy(json,p,destroy_next) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p !! variable to destroy logical(LK),intent(in),optional :: destroy_next !! if true, then `p%next` !! is also destroyed (default is true) 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 if (present(destroy_next)) then des_next = destroy_next else des_next = .true. end if if (allocated(p%name)) deallocate(p%name) 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 ! 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 ! 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 nullify(p%children) nullify(child) end if if (associated(p%next) .and. des_next) call json%destroy(p%next) nullify(p%previous) nullify(p%parent) nullify(p%tail) if (associated(p)) deallocate(p) nullify(p) end if end subroutine json_value_destroy !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 9/9/2014 ! ! Remove a [[json_value]] (and all its children) ! from a linked-list structure, preserving the rest of the structure. ! !### Examples ! ! To extract an object from one JSON structure, and add it to another: !````fortran ! type(json_core) :: json ! type(json_value),pointer :: json1,json2,p ! logical :: found ! !create and populate json1 and json2 ! call json%get(json1,'name',p,found) ! get pointer to name element of json1 ! call json%remove(p,destroy=.false.) ! remove it from json1 (don't destroy) ! call json%add(json2,p) ! add it to json2 !```` ! ! To remove an object from a JSON structure (and destroy it): !````fortran ! type(json_core) :: json ! type(json_value),pointer :: json1,p ! logical :: found ! !create and populate json1 ! call json%get(json1,'name',p,found) ! get pointer to name element of json1 ! call json%remove(p) ! remove and destroy it !```` ! !### History ! * Jacob Williams : 12/28/2014 : added destroy optional argument. ! * Jacob Williams : 12/04/2020 : bug fix. subroutine json_value_remove(json,p,destroy) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p logical(LK),intent(in),optional :: destroy !! Option to destroy `p` after it is removed: !! !! * If `destroy` is not present, it is also destroyed. !! * If `destroy` is present and true, it is destroyed. !! * If `destroy` is present and false, it is not destroyed. type(json_value),pointer :: parent !! pointer to parent type(json_value),pointer :: previous !! pointer to previous type(json_value),pointer :: next !! pointer to next logical(LK) :: destroy_it !! if `p` should be destroyed if (associated(p)) then !optional input argument: if (present(destroy)) then destroy_it = destroy else destroy_it = .true. end if if (associated(p%parent)) then parent => p%parent if (associated(p%next)) then !there are later items in the list: next => p%next if (associated(p%previous)) then !there are earlier items in the list previous => p%previous previous%next => next next%previous => previous else !this is the first item in the list parent%children => next nullify(next%previous) end if else if (associated(p%previous)) then !there are earlier items in the list: previous => p%previous nullify(previous%next) parent%tail => previous else !this is the only item in the list: nullify(parent%children) nullify(parent%tail) end if end if ! nullify all pointers to original structure: nullify(p%next) nullify(p%previous) nullify(p%parent) parent%n_children = parent%n_children - 1 end if if (destroy_it) call json%destroy(p) end if end subroutine json_value_remove !***************************************************************************************** !***************************************************************************************** !> ! Replace `p1` with `p2` in a JSON structure. ! !@note The replacement is done using an insert and remove ! See [[json_value_insert_after]] and [[json_value_remove]] ! for details. subroutine json_value_replace(json,p1,p2,destroy) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p1 !! the item to replace type(json_value),pointer :: p2 !! item to take the place of `p1` logical(LK),intent(in),optional :: destroy !! Should `p1` also be destroyed !! (default is True). Normally, !! this should be true to avoid !! a memory leak. logical(LK) :: destroy_p1 !! if `p1` is to be destroyed if (present(destroy)) then destroy_p1 = destroy else destroy_p1 = .true. ! default end if call json%insert_after(p1,p2) call json%remove(p1,destroy_p1) end subroutine json_value_replace !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 4/11/2017 ! ! Reverse the order of the children of an array or object. subroutine json_value_reverse(json,p) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p type(json_value),pointer :: tmp !! temp variable for traversing the list type(json_value),pointer :: current !! temp variable for traversing the list integer(IK) :: var_type !! for getting the variable type if (associated(p)) then call json%info(p,var_type=var_type) ! can only reverse objects or arrays if (var_type==json_object .or. var_type==json_array) then nullify(tmp) current => p%children p%tail => current ! Swap next and previous for all nodes: do if (.not. associated(current)) exit tmp => current%previous current%previous => current%next current%next => tmp current => current%previous end do if (associated(tmp)) then p%children => tmp%previous end if end if end if end subroutine json_value_reverse !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 4/26/2016 ! ! 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. 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 !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 4/28/2016 ! ! Returns True if `p2` is a descendant of `p1` ! (i.e, a child, or a child of child, etc.) function json_value_is_child_of(json,p1,p2) result(is_child_of) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p1 type(json_value),pointer :: p2 logical(LK) :: is_child_of is_child_of = .false. if (json%exception_thrown) return if (associated(p1) .and. associated(p2)) then if (associated(p1%children)) then call json%traverse(p1%children,is_child_of_callback) end if end if contains subroutine is_child_of_callback(json,p,finished) !! Traverse until `p` is `p2`. implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: p logical(LK),intent(out) :: finished is_child_of = associated(p,p2) finished = is_child_of ! stop searching if found end subroutine is_child_of_callback end function json_value_is_child_of !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 5/2/2016 ! ! Validate a [[json_value]] linked list by checking to make sure ! all the pointers are properly associated, arrays and objects ! have the correct number of children, and the correct data is ! allocated for the variable types. ! ! It recursively traverses the entire structure and checks every element. ! !### History ! * Jacob Williams, 8/26/2017 : added duplicate key check. ! !@note It will return on the first error it encounters. ! !@note This routine does not check or throw any exceptions. ! If `json` is currently in a state of exception, it will ! remain so after calling this routine. subroutine json_value_validate(json,p,is_valid,error_msg) implicit none class(json_core),intent(inout) :: json type(json_value),pointer,intent(in) :: p logical(LK),intent(out) :: is_valid !! True if the structure is valid. character(kind=CK,len=:),allocatable,intent(out) :: error_msg !! if not valid, this will contain !! a description of the problem logical(LK) :: has_duplicate !! to check for duplicate keys character(kind=CK,len=:),allocatable :: path !! path to duplicate key logical(LK) :: status_ok !! to check for existing exception character(kind=CK,len=:),allocatable :: exception_msg !! error message for an existing exception character(kind=CK,len=:),allocatable :: exception_msg2 !! error message for a new exception if (associated(p)) then is_valid = .true. call check_if_valid(p,require_parent=associated(p%parent)) if (is_valid .and. .not. json%allow_duplicate_keys) then ! if no errors so far, also check the ! entire structure for duplicate keys: ! note: check_for_duplicate_keys does call routines ! that check and throw exceptions, so let's clear any ! first. (save message for later) call json%check_for_errors(status_ok, exception_msg) call json%clear_exceptions() call json%check_for_duplicate_keys(p,has_duplicate,path=path) if (json%failed()) then ! if an exception was thrown during this call, ! then clear it but make that the error message ! returned by this routine. Normally this should ! never actually occur since we have already ! validated the structure. call json%check_for_errors(is_valid, exception_msg2) error_msg = exception_msg2 call json%clear_exceptions() is_valid = .false. else if (has_duplicate) then error_msg = 'duplicate key found: '//path is_valid = .false. end if end if if (.not. status_ok) then ! restore any existing exception if necessary call json%throw_exception(exception_msg) end if ! cleanup: if (allocated(path)) deallocate(path) if (allocated(exception_msg)) deallocate(exception_msg) if (allocated(exception_msg2)) deallocate(exception_msg2) end if else error_msg = 'The pointer is not associated' is_valid = .false. end if contains recursive subroutine check_if_valid(p,require_parent) implicit none type(json_value),pointer,intent(in) :: p logical,intent(in) :: require_parent !! the first one may be a root (so no parent), !! but all descendants must have a parent. integer(IK) :: i !! counter type(json_value),pointer :: element type(json_value),pointer :: previous if (is_valid .and. associated(p)) then ! data type: select case (p%var_type) case(json_null,json_object,json_array) if (allocated(p%log_value) .or. allocated(p%int_value) .or. & allocated(p%dbl_value) .or. allocated(p%str_value)) then error_msg = 'incorrect data allocated for '//& 'json_null, json_object, or json_array variable type' is_valid = .false. return end if case(json_logical) if (.not. allocated(p%log_value)) then error_msg = 'log_value should be allocated for json_logical variable type' is_valid = .false. return else if (allocated(p%int_value) .or. & allocated(p%dbl_value) .or. allocated(p%str_value)) then error_msg = 'incorrect data allocated for json_logical variable type' is_valid = .false. return end if case(json_integer) if (.not. allocated(p%int_value)) then error_msg = 'int_value should be allocated for json_integer variable type' is_valid = .false. return else if (allocated(p%log_value) .or. & allocated(p%dbl_value) .or. allocated(p%str_value)) then error_msg = 'incorrect data allocated for json_integer variable type' is_valid = .false. return end if case(json_real) if (.not. allocated(p%dbl_value)) then error_msg = 'dbl_value should be allocated for json_real variable type' is_valid = .false. return else if (allocated(p%log_value) .or. allocated(p%int_value) .or. & allocated(p%str_value)) then error_msg = 'incorrect data allocated for json_real variable type' is_valid = .false. return end if case(json_string) if (.not. allocated(p%str_value)) then error_msg = 'str_value should be allocated for json_string variable type' is_valid = .false. return else if (allocated(p%log_value) .or. allocated(p%int_value) .or. & allocated(p%dbl_value)) then error_msg = 'incorrect data allocated for json_string variable type' is_valid = .false. return end if case default error_msg = 'invalid JSON variable type' is_valid = .false. return end select if (require_parent .and. .not. associated(p%parent)) then error_msg = 'parent pointer is not associated' is_valid = .false. return end if if (.not. allocated(p%name)) then if (associated(p%parent)) then if (p%parent%var_type/=json_array) then error_msg = 'JSON variable must have a name if not an '//& 'array element or the root' is_valid = .false. return end if end if end if if (associated(p%children) .neqv. associated(p%tail)) then error_msg = 'both children and tail pointers must be associated' is_valid = .false. return end if ! now, check next one: if (associated(p%next)) then 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 if (p%var_type/=json_array .and. p%var_type/=json_object) then error_msg = 'only arrays and objects can have children' is_valid = .false. return end if ! first validate children pointers: previous => null() element => p%children do i = 1_IK, p%n_children if (.not. associated(element%parent,p)) then error_msg = 'child''s parent pointer not properly associated' is_valid = .false. return end if if (i==1 .and. associated(element%previous)) then error_msg = 'first child shouldn''t have a previous' is_valid = .false. return end if if (i<p%n_children .and. .not. associated(element%next)) then error_msg = 'not enough children' is_valid = .false. return end if if (i==p%n_children .and. associated(element%next)) then error_msg = 'too many children' is_valid = .false. return end if if (i>1) then if (.not. associated(previous,element%previous)) then error_msg = 'previous pointer not properly associated' is_valid = .false. return end if end if if (i==p%n_children .and. & .not. associated(element%parent%tail,element)) then error_msg = 'parent''s tail pointer not properly associated' is_valid = .false. return end if if (i<p%n_children) then !setup next case: previous => element element => element%next end if end do !now check all the children: call check_if_valid(p%children,require_parent=.true.) end if end if end subroutine check_if_valid end subroutine json_value_validate !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/6/2014 ! ! Given the path string, remove the variable ! from [[json_value]], if it exists. subroutine json_value_remove_if_present(json,p,path) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: path !! the path to the variable to remove type(json_value),pointer :: p_var logical(LK) :: found call json%get(p,path,p_var,found) if (found) call json%remove(p_var) end subroutine json_value_remove_if_present !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_value_remove_if_present]], where `path` is kind=CDK. subroutine wrap_json_value_remove_if_present(json,p,path) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: path call json%remove_if_present(p,to_unicode(path)) end subroutine wrap_json_value_remove_if_present !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/6/2014 ! ! Given the path string, if the variable is present, ! and is a scalar, then update its value. ! If it is not present, then create it and set its value. ! !@note If the variable is not a scalar, an exception will be thrown. subroutine json_update_logical(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure logical(LK),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. type(json_value),pointer :: p_var integer(IK) :: var_type call json%get(p,path,p_var,found) if (found) then call json%info(p_var,var_type) select case (var_type) case (json_null,json_logical,json_integer,json_real,json_string) call json%to_logical(p_var,val) !update the value case default found = .false. call json%throw_exception('Error in json_update_logical: '//& 'the variable is not a scalar value',found) end select else call json%add_by_path(p,path,val) !add the new element end if end subroutine json_update_logical !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_update_logical]], where `path` is kind=CDK. subroutine wrap_json_update_logical(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure logical(LK),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. call json%update(p,to_unicode(path),val,found) end subroutine wrap_json_update_logical !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/6/2014 ! ! Given the path string, if the variable is present, ! and is a scalar, then update its value. ! If it is not present, then create it and set its value. ! !@note If the variable is not a scalar, an exception will be thrown. subroutine json_update_real(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure real(RK),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. type(json_value),pointer :: p_var integer(IK) :: var_type call json%get(p,path,p_var,found) if (found) then call json%info(p_var,var_type) select case (var_type) case (json_null,json_logical,json_integer,json_real,json_string) call json%to_real(p_var,val) !update the value case default found = .false. call json%throw_exception('Error in json_update_real: '//& 'the variable is not a scalar value',found) end select else call json%add_by_path(p,path,val) !add the new element end if end subroutine json_update_real !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_update_real]], where `path` is kind=CDK. subroutine wrap_json_update_real(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure real(RK),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. call json%update(p,to_unicode(path),val,found) end subroutine wrap_json_update_real !***************************************************************************************** #ifndef REAL32 !***************************************************************************************** !> ! Alternate version of [[json_update_real]], where `val` is `real32`. subroutine json_update_real32(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure real(real32),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. call json%update(p,path,real(val,RK),found) end subroutine json_update_real32 !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_update_real32]], where `path` is kind=CDK. subroutine wrap_json_update_real32(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure real(real32),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. call json%update(p,to_unicode(path),real(val,RK),found) end subroutine wrap_json_update_real32 !***************************************************************************************** #endif #ifdef REAL128 !***************************************************************************************** !> ! Alternate version of [[json_update_real]], where `val` is `real64`. subroutine json_update_real64(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure real(real64),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. call json%update(p,path,real(val,RK),found) end subroutine json_update_real64 !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_update_real64]], where `path` is kind=CDK. subroutine wrap_json_update_real64(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure real(real64),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. call json%update(p,to_unicode(path),real(val,RK),found) end subroutine wrap_json_update_real64 !***************************************************************************************** #endif !***************************************************************************************** !> author: Jacob Williams ! date: 12/6/2014 ! ! Given the path string, if the variable is present, ! and is a scalar, then update its value. ! If it is not present, then create it and set its value. ! !@note If the variable is not a scalar, an exception will be thrown. subroutine json_update_integer(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure integer(IK),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. type(json_value),pointer :: p_var integer(IK) :: var_type call json%get(p,path,p_var,found) if (found) then call json%info(p_var,var_type) select case (var_type) case (json_null,json_logical,json_integer,json_real,json_string) call json%to_integer(p_var,val) !update the value case default found = .false. call json%throw_exception('Error in json_update_integer: '//& 'the variable is not a scalar value',found) end select else call json%add_by_path(p,path,val) !add the new element end if end subroutine json_update_integer !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_update_integer]], where `path` is kind=CDK. subroutine wrap_json_update_integer(json,p,path,val,found) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure integer(IK),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. call json%update(p,to_unicode(path),val,found) end subroutine wrap_json_update_integer !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 12/6/2014 ! ! Given the path string, if the variable is present, ! and is a scalar, then update its value. ! If it is not present, then create it and set its value. ! !@note If the variable is not a scalar, an exception will be thrown. subroutine json_update_string(json,p,path,val,found,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure character(kind=CK,len=*),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val` !! (only used if `val` is present) logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val` !! (only used if `val` is present) !! (note that ADJUSTL is done before TRIM) type(json_value),pointer :: p_var integer(IK) :: var_type call json%get(p,path,p_var,found) if (found) then call json%info(p_var,var_type) select case (var_type) case (json_null,json_logical,json_integer,json_real,json_string) call json%to_string(p_var,val,trim_str=trim_str,adjustl_str=adjustl_str) ! update the value case default found = .false. call json%throw_exception('Error in json_update_string: '//& 'the variable is not a scalar value',found) end select else call json%add_by_path(p,path,val) !add the new element end if end subroutine json_update_string !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_update_string]], where `path` and `value` are kind=CDK. subroutine wrap_json_update_string(json,p,path,val,found,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure character(kind=CDK,len=*),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val` !! (only used if `val` is present) logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val` !! (only used if `val` is present) !! (note that ADJUSTL is done before TRIM) call json%update(p,to_unicode(path),to_unicode(val),found,trim_str,adjustl_str) end subroutine wrap_json_update_string !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_update_string]], where `path` is kind=CDK. subroutine json_update_string_name_ascii(json,p,path,val,found,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure character(kind=CK, len=*),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val` !! (only used if `val` is present) logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val` !! (only used if `val` is present) !! (note that ADJUSTL is done before TRIM) call json%update(p,to_unicode(path),val,found,trim_str,adjustl_str) end subroutine json_update_string_name_ascii !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_update_string]], where `val` is kind=CDK. subroutine json_update_string_val_ascii(json,p,path,val,found,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK, len=*),intent(in) :: path !! path to the variable in the structure character(kind=CDK,len=*),intent(in) :: val !! the new value logical(LK),intent(out) :: found !! if the variable was found and was a scalar. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val` !! (only used if `val` is present) logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val` !! (only used if `val` is present) !! (note that ADJUSTL is done before TRIM) call json%update(p,path,to_unicode(val),found,trim_str,adjustl_str) end subroutine json_update_string_val_ascii !***************************************************************************************** !***************************************************************************************** !> ! Adds `member` as a child of `p`. subroutine json_value_add_member(json,p,member) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p !! `p` must be a `json_object` !! or a `json_array` type(json_value),pointer :: member !! the child member !! to add to `p` integer(IK) :: var_type !! variable type of `p` if (.not. json%exception_thrown) then if (associated(p)) then call json%info(p,var_type=var_type) select case (var_type) case(json_object, json_array) ! associate the parent member%parent => p ! add to linked list if (associated(p%children)) then p%tail%next => member member%previous => p%tail else p%children => member member%previous => null() !first in the list end if ! new member is now the last one in the list p%tail => member p%n_children = p%n_children + 1 case default call json%throw_exception('Error in json_value_add_member: '//& 'can only add child to object or array') end select else call json%throw_exception('Error in json_value_add_member: '//& 'the pointer is not associated') end if end if end subroutine json_value_add_member !***************************************************************************************** !***************************************************************************************** !> ! Inserts `element` after `p`, and updates the JSON structure accordingly. ! !### Example ! !````fortran ! program test ! use json_module ! implicit none ! logical(json_LK) :: found ! type(json_core) :: json ! type(json_value),pointer :: p,new,element ! call json%load(file='myfile.json', p=p) ! call json%get(p,'x(3)',element,found) ! get pointer to an array element in the file ! call json%create_integer(new,1,'') ! create a new element ! call json%insert_after(element,new) ! insert new element after x(3) ! call json%print(p,'myfile2.json') ! write it to a file ! call json%destroy(p) ! cleanup ! end program test !```` ! !### Details ! ! * This routine can be used to insert a new element (or set of elements) ! into an array or object at a specific index. ! See [[json_value_insert_after_child_by_index]] ! * Children and subsequent elements of `element` are carried along. ! * If the inserted elements are part of an existing list, then ! they are removed from that list. ! !```` ! p ! [1] - [2] - [3] - [4] ! | ! [5] - [6] - [7] n=3 elements inserted ! element last ! ! Result is: ! ! [1] - [2] - [5] - [6] - [7] - [3] - [4] ! !```` subroutine json_value_insert_after(json,p,element) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p !! a value from a JSON structure !! (presumably, this is a child of !! an object or array). type(json_value),pointer :: element !! the element to insert after `p` type(json_value),pointer :: parent !! the parent of `p` type(json_value),pointer :: next !! temp pointer for traversing structure type(json_value),pointer :: last !! the last of the items being inserted integer :: n !! number of items being inserted if (.not. json%exception_thrown) then parent => p%parent ! set first parent of inserted list: element%parent => parent ! Count the number of inserted elements. ! and set their parents. n = 1 ! initialize counter next => element%next last => element do if (.not. associated(next)) exit n = n + 1 next%parent => parent last => next next => next%next end do if (associated(parent)) then ! update parent's child counter: parent%n_children = parent%n_children + n ! if p is last of parents children then ! also have to update parent tail pointer: if (associated(parent%tail,p)) then parent%tail => last end if end if if (associated(element%previous)) then ! element is apparently part of an existing list, ! so have to update that as well. if (associated(element%previous%parent)) then element%previous%parent%n_children = & element%previous%parent%n_children - n element%previous%parent%tail => & element%previous ! now the last one in the list else ! this would be a memory leak if the previous entries ! are not otherwise being pointed too ! [throw an error in this case???] end if !remove element from the other list: element%previous%next => null() end if element%previous => p if (associated(p%next)) then ! if there are any in the list after p: last%next => p%next last%next%previous => element else last%next => null() end if p%next => element end if end subroutine json_value_insert_after !***************************************************************************************** !***************************************************************************************** !> ! Inserts `element` after the `idx`-th child of `p`, ! and updates the JSON structure accordingly. This is just ! a wrapper for [[json_value_insert_after]]. subroutine json_value_insert_after_child_by_index(json,p,idx,element) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p !! a JSON object or array. integer(IK),intent(in) :: idx !! the index of the child of `p` to !! insert the new element after !! (this is a 1-based Fortran !! style array index) type(json_value),pointer :: element !! the element to insert type(json_value),pointer :: tmp !! for getting the `idx`-th child of `p` if (.not. json%exception_thrown) then ! get the idx-th child of p: call json%get_child(p,idx,tmp) ! call json_value_insert_after: if (.not. json%exception_thrown) call json%insert_after(tmp,element) end if end subroutine json_value_insert_after_child_by_index !***************************************************************************************** !***************************************************************************************** !> ! Add a new member (`json_value` pointer) to a JSON structure, given the path. ! !@warning If the path points to an existing variable in the structure, ! then this routine will destroy it and replace it with the ! new value. subroutine json_add_member_by_path(json,me,path,p,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable type(json_value),pointer,intent(in) :: p !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created type(json_value),pointer :: tmp character(kind=CK,len=:),allocatable :: name !! name of the variable if ( .not. json%exception_thrown ) then if (.not. associated(p)) then call json%throw_exception('Error in json_add_member_by_path:'//& ' Input pointer p is not associated.',found) if (present(found)) then found = .false. call json%clear_exceptions() end if if ( present(was_created) ) was_created = .false. else ! return a pointer to the path (possibly creating it) call json%create(me,path,tmp,found,was_created) if (.not. associated(tmp)) then call json%throw_exception('Error in json_add_member_by_path:'//& ' Unable to resolve path: '//trim(path),found) if (present(found)) then found = .false. call json%clear_exceptions() end if else call json%info(tmp,name=name) ! replace it with the new one: call json%replace(tmp,p,destroy=.true.) call json%rename(p,name) end if end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_member_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_member_by_path]] where "path" is kind=CDK. subroutine wrap_json_add_member_by_path(json,me,path,p,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable type(json_value),pointer,intent(in) :: p !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%json_add_member_by_path(me,to_unicode(path),p,found,was_created) end subroutine wrap_json_add_member_by_path !***************************************************************************************** !***************************************************************************************** !> ! Add an integer value to a [[json_value]], given the path. ! !@warning If the path points to an existing variable in the structure, ! then this routine will destroy it and replace it with the ! new value. subroutine json_add_integer_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable integer(IK),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created type(json_value),pointer :: p type(json_value),pointer :: tmp character(kind=CK,len=:),allocatable :: name !! variable name if ( .not. json%exception_thrown ) then nullify(p) ! return a pointer to the path (possibly creating it) ! If the variable had to be created, then ! it will be a json_null variable. call json%create(me,path,p,found,was_created) if (.not. associated(p)) then call json%throw_exception('Error in json_add_integer_by_path:'//& ' Unable to resolve path: '//trim(path),found) if (present(found)) then found = .false. call json%clear_exceptions() end if else !NOTE: a new object is created, and the old one ! is replaced and destroyed. This is to ! prevent memory leaks if the type is ! being changed (for example, if an array ! is being replaced with a scalar). if (p%var_type==json_integer) then p%int_value = value else call json%info(p,name=name) call json%create_integer(tmp,value,name) call json%replace(p,tmp,destroy=.true.) end if end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_integer_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_integer_by_path]] where "path" is kind=CDK. subroutine wrap_json_add_integer_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable integer(IK),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%json_add_integer_by_path(me,to_unicode(path),value,found,was_created) end subroutine wrap_json_add_integer_by_path !***************************************************************************************** !***************************************************************************************** !> ! Add an real value to a [[json_value]], given the path. ! !@warning If the path points to an existing variable in the structure, ! then this routine will destroy it and replace it with the ! new value. subroutine json_add_real_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable real(RK),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created type(json_value),pointer :: p type(json_value),pointer :: tmp character(kind=CK,len=:),allocatable :: name !! variable name if ( .not. json%exception_thrown ) then nullify(p) ! return a pointer to the path (possibly creating it) ! If the variable had to be created, then ! it will be a json_null variable. call json%create(me,path,p,found,was_created) if (.not. associated(p)) then call json%throw_exception('Error in json_add_real_by_path:'//& ' Unable to resolve path: '//trim(path),found) if (present(found)) then found = .false. call json%clear_exceptions() end if else !NOTE: a new object is created, and the old one ! is replaced and destroyed. This is to ! prevent memory leaks if the type is ! being changed (for example, if an array ! is being replaced with a scalar). if (p%var_type==json_real) then p%dbl_value = value else call json%info(p,name=name) call json%create_real(tmp,value,name) call json%replace(p,tmp,destroy=.true.) end if end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_real_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_real_by_path]] where "path" is kind=CDK. subroutine wrap_json_add_real_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable real(RK),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%json_add_real_by_path(me,to_unicode(path),value,found,was_created) end subroutine wrap_json_add_real_by_path !***************************************************************************************** #ifndef REAL32 !***************************************************************************************** !> ! Alternate version of [[json_add_real_by_path]] where value=real32. subroutine json_add_real32_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable real(real32),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%add_by_path(me,path,real(value,RK),found,was_created) end subroutine json_add_real32_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_real32_by_path]] where "path" is kind=CDK. subroutine wrap_json_add_real32_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable real(real32),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created) end subroutine wrap_json_add_real32_by_path !***************************************************************************************** #endif #ifdef REAL128 !***************************************************************************************** !> ! Alternate version of [[json_add_real_by_path]] where value=real32. subroutine json_add_real64_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable real(real64),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%add_by_path(me,path,real(value,RK),found,was_created) end subroutine json_add_real64_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_real64_by_path]] where "path" is kind=CDK. subroutine wrap_json_add_real64_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable real(real64),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created) end subroutine wrap_json_add_real64_by_path !***************************************************************************************** #endif !***************************************************************************************** !> ! Add a logical value to a [[json_value]], given the path. ! !@warning If the path points to an existing variable in the structure, ! then this routine will destroy it and replace it with the ! new value. subroutine json_add_logical_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable logical(LK),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created type(json_value),pointer :: p type(json_value),pointer :: tmp character(kind=CK,len=:),allocatable :: name !! variable name if ( .not. json%exception_thrown ) then nullify(p) ! return a pointer to the path (possibly creating it) ! If the variable had to be created, then ! it will be a json_null variable. call json%create(me,path,p,found,was_created) if (.not. associated(p)) then call json%throw_exception('Error in json_add_logical_by_path:'//& ' Unable to resolve path: '//trim(path),found) if (present(found)) then found = .false. call json%clear_exceptions() end if else !NOTE: a new object is created, and the old one ! is replaced and destroyed. This is to ! prevent memory leaks if the type is ! being changed (for example, if an array ! is being replaced with a scalar). if (p%var_type==json_logical) then p%log_value = value else call json%info(p,name=name) call json%create_logical(tmp,value,name) call json%replace(p,tmp,destroy=.true.) end if end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_logical_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_logical_by_path]] where "path" is kind=CDK. subroutine wrap_json_add_logical_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable logical(LK),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%json_add_logical_by_path(me,to_unicode(path),value,found,was_created) end subroutine wrap_json_add_logical_by_path !***************************************************************************************** !***************************************************************************************** !> ! Add a string value to a [[json_value]], given the path. ! !@warning If the path points to an existing variable in the structure, ! then this routine will destroy it and replace it with the ! new value. subroutine json_add_string_by_path(json,me,path,value,found,& was_created,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable character(kind=CK,len=*),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element type(json_value),pointer :: p type(json_value),pointer :: tmp character(kind=CK,len=:),allocatable :: name !! variable name if ( .not. json%exception_thrown ) then nullify(p) ! return a pointer to the path (possibly creating it) ! If the variable had to be created, then ! it will be a json_null variable. call json%create(me,path,p,found,was_created) if (.not. associated(p)) then call json%throw_exception('Error in json_add_string_by_path:'//& ' Unable to resolve path: '//trim(path),found) if (present(found)) then found = .false. call json%clear_exceptions() end if else !NOTE: a new object is created, and the old one ! is replaced and destroyed. This is to ! prevent memory leaks if the type is ! being changed (for example, if an array ! is being replaced with a scalar). if (p%var_type==json_string) then p%str_value = value else call json%info(p,name=name) call json%create_string(tmp,value,name,trim_str,adjustl_str) call json%replace(p,tmp,destroy=.true.) end if end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_string_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_string_by_path]] where "path" is kind=CDK. subroutine wrap_json_add_string_by_path(json,me,path,value,found,& was_created,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable character(kind=CDK,len=*),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element call json%json_add_string_by_path(me,to_unicode(path),to_unicode(value),& found,was_created,trim_str,adjustl_str) end subroutine wrap_json_add_string_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_string_by_path]] where "path" is kind=CDK. subroutine json_add_string_by_path_path_ascii(json,me,path,value,found,& was_created,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable character(kind=CK,len=*),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element call json%json_add_string_by_path(me,to_unicode(path),value,found,was_created,trim_str,adjustl_str) end subroutine json_add_string_by_path_path_ascii !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_string_by_path]] where "value" is kind=CDK. subroutine json_add_string_by_path_value_ascii(json,me,path,value,found,& was_created,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable character(kind=CDK,len=*),intent(in) :: value !! the value to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element call json%json_add_string_by_path(me,path,to_unicode(value),found,was_created,trim_str,adjustl_str) end subroutine json_add_string_by_path_value_ascii !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_integer_by_path]] for adding an integer vector by path. subroutine json_add_integer_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable integer(IK),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created type(json_value),pointer :: p !! pointer to path (which may exist) type(json_value),pointer :: var !! new variable that is created integer(IK) :: i !! counter character(kind=CK,len=:),allocatable :: name !! the variable name logical(LK) :: p_found !! if the path was successfully found (or created) if ( .not. json%exception_thrown ) then !get a pointer to the variable !(creating it if necessary) call json%create(me,path,p,found=p_found) if (p_found) then call json%info(p,name=name) ! want to keep the existing name call json%create_array(var,name) ! create a new array variable call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p) !populate each element of the array: do i=1,size(value) call json%add(var, CK_'', value(i)) end do end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_integer_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_integer_vec_by_path]] where "path" is kind=CDK). subroutine wrap_json_add_integer_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable integer(IK),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%json_add_integer_vec_by_path(me,to_unicode(path),value,found,was_created) end subroutine wrap_json_add_integer_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_logical_by_path]] for adding a logical vector by path. subroutine json_add_logical_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable logical(LK),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created type(json_value),pointer :: p !! pointer to path (which may exist) type(json_value),pointer :: var !! new variable that is created integer(IK) :: i !! counter character(kind=CK,len=:),allocatable :: name !! the variable name logical(LK) :: p_found !! if the path was successfully found (or created) if ( .not. json%exception_thrown ) then !get a pointer to the variable !(creating it if necessary) call json%create(me,path,p,found=p_found) if (p_found) then call json%info(p,name=name) ! want to keep the existing name call json%create_array(var,name) ! create a new array variable call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p) !populate each element of the array: do i=1,size(value) call json%add(var, CK_'', value(i)) end do end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_logical_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_logical_vec_by_path]] where "path" is kind=CDK). subroutine wrap_json_add_logical_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable logical(LK),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%json_add_logical_vec_by_path(me,to_unicode(path),value,found,was_created) end subroutine wrap_json_add_logical_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path. subroutine json_add_real_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable real(RK),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created type(json_value),pointer :: p !! pointer to path (which may exist) type(json_value),pointer :: var !! new variable that is created integer(IK) :: i !! counter character(kind=CK,len=:),allocatable :: name !! the variable name logical(LK) :: p_found !! if the path was successfully found (or created) if ( .not. json%exception_thrown ) then !get a pointer to the variable !(creating it if necessary) call json%create(me,path,p,found=p_found) if (p_found) then call json%info(p,name=name) ! want to keep the existing name call json%create_array(var,name) ! create a new array variable call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p) !populate each element of the array: do i=1,size(value) call json%add(var, CK_'', value(i)) end do end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_real_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_real_vec_by_path]] where "path" is kind=CDK). subroutine wrap_json_add_real_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable real(RK),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%json_add_real_vec_by_path(me,to_unicode(path),value,found,was_created) end subroutine wrap_json_add_real_vec_by_path !***************************************************************************************** #ifndef REAL32 !***************************************************************************************** !> ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path. subroutine json_add_real32_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable real(real32),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%add_by_path(me,path,real(value,RK),found,was_created) end subroutine json_add_real32_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_real32_vec_by_path]] where "path" is kind=CDK). subroutine wrap_json_add_real32_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable real(real32),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created) end subroutine wrap_json_add_real32_vec_by_path !***************************************************************************************** #endif #ifdef REAL128 !***************************************************************************************** !> ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path. subroutine json_add_real64_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable real(real64),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%add_by_path(me,path,real(value,RK),found,was_created) end subroutine json_add_real64_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_real64_vec_by_path]] where "path" is kind=CDK). subroutine wrap_json_add_real64_vec_by_path(json,me,path,value,found,was_created) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable real(real64),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created) end subroutine wrap_json_add_real64_vec_by_path !***************************************************************************************** #endif !***************************************************************************************** !> ! Wrapper to [[json_add_string_by_path]] for adding a string vector by path. ! !@note The `ilen` input can be used to specify the actual lengths of the ! the strings in the array. They must all be `<= len(value)`. subroutine json_add_string_vec_by_path(json,me,path,value,found,was_created,ilen,trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable character(kind=CK,len=*),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each !! element in `value`. If not present, !! the full `len(value)` string is added !! for each element. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element type(json_value),pointer :: p !! pointer to path (which may exist) type(json_value),pointer :: var !! new variable that is created integer(IK) :: i !! counter character(kind=CK,len=:),allocatable :: name !! the variable name logical(LK) :: p_found !! if the path was successfully found (or created) if ( .not. json%exception_thrown ) then ! validate ilen array if present: if (present(ilen)) then if (size(ilen)/=size(value)) then call json%throw_exception('Error in json_add_string_vec_by_path: '//& 'Invalid size of ilen input vector.',found) if (present(found)) then found = .false. call json%clear_exceptions() end if if (present(was_created)) was_created = .false. return else ! also have to validate the specified lengths. ! (must not be greater than input string length) do i = 1, size(value) if (ilen(i)>len(value)) then call json%throw_exception('Error in json_add_string_vec_by_path: '//& 'Invalid ilen element.',found) if (present(found)) then found = .false. call json%clear_exceptions() end if if (present(was_created)) was_created = .false. return end if end do end if end if !get a pointer to the variable !(creating it if necessary) call json%create(me,path,p,found=p_found) if (p_found) then call json%info(p,name=name) ! want to keep the existing name call json%create_array(var,name) ! create a new array variable call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p) !populate each element of the array: do i=1,size(value) if (present(ilen)) then call json%add(var, CK_'', value(i)(1:ilen(i)), & trim_str=trim_str, adjustl_str=adjustl_str) else call json%add(var, CK_'', value(i), & trim_str=trim_str, adjustl_str=adjustl_str) end if end do end if else if ( present(found) ) found = .false. if ( present(was_created) ) was_created = .false. end if end subroutine json_add_string_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_string_vec_by_path]] where "path" and "value" are kind=CDK). subroutine wrap_json_add_string_vec_by_path(json,me,path,value,& found,was_created,ilen,& trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable character(kind=CDK,len=*),dimension(:),intent(in):: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each !! element in `value`. If not present, !! the full `len(value)` string is added !! for each element. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element call json%json_add_string_vec_by_path(me,to_unicode(path),to_unicode(value),& found,was_created,ilen,trim_str,adjustl_str) end subroutine wrap_json_add_string_vec_by_path !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_string_vec_by_path]] where "value" is kind=CDK). subroutine json_add_string_vec_by_path_value_ascii(json,me,path,value,& found,was_created,ilen,& trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CK,len=*),intent(in) :: path !! the path to the variable character(kind=CDK,len=*),dimension(:),intent(in):: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each !! element in `value`. If not present, !! the full `len(value)` string is added !! for each element. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element call json%json_add_string_vec_by_path(me,path,to_unicode(value),& found,was_created,ilen,trim_str,adjustl_str) end subroutine json_add_string_vec_by_path_value_ascii !***************************************************************************************** !***************************************************************************************** !> ! Wrapper for [[json_add_string_vec_by_path]] where "path" is kind=CDK). subroutine json_add_string_vec_by_path_path_ascii(json,me,path,value,& found,was_created,ilen,& trim_str,adjustl_str) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: me !! the JSON structure character(kind=CDK,len=*),intent(in) :: path !! the path to the variable character(kind=CK,len=*),dimension(:),intent(in) :: value !! the vector to add logical(LK),intent(out),optional :: found !! if the variable was found logical(LK),intent(out),optional :: was_created !! if the variable had to be created integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each !! element in `value`. If not present, !! the full `len(value)` string is added !! for each element. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element call json%json_add_string_vec_by_path(me,to_unicode(path),value,& found,was_created,ilen,trim_str,adjustl_str) end subroutine json_add_string_vec_by_path_path_ascii !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 1/19/2014 ! ! Add a real value child to the [[json_value]] variable. ! !@note This routine is part of the public API that can be ! used to build a JSON structure using [[json_value]] pointers. subroutine json_value_add_real(json,p,name,val) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: name !! variable name real(RK),intent(in) :: val !! real value type(json_value),pointer :: var !create the variable: call json%create_real(var,val,name) !add it: call json%add(p, var) end subroutine json_value_add_real !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_value_add_real]] where `name` is kind=CDK. subroutine wrap_json_value_add_real(json,p,name,val) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: name !! variable name real(RK),intent(in) :: val !! real value call json%add(p, to_unicode(name), val) end subroutine wrap_json_value_add_real !***************************************************************************************** !***************************************************************************************** !> author: Jacob Williams ! date: 1/20/2014 ! ! Add a real vector child to the [[json_value]] variable. ! !@note This routine is part of the public API that can be ! used to build a JSON structure using [[json_value]] pointers. subroutine json_value_add_real_vec(json, p, name, val) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: name real(RK),dimension(:),intent(in) :: val type(json_value),pointer :: var integer(IK) :: i !! counter !create the variable as an array: call json%create_array(var,name) !populate the array: do i=1,size(val) call json%add(var, CK_'', val(i)) end do !add it: call json%add(p, var) end subroutine json_value_add_real_vec !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_value_add_real_vec]] where `name` is kind=CDK. subroutine wrap_json_value_add_real_vec(json, p, name, val) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: name real(RK),dimension(:),intent(in) :: val call json%add(p, to_unicode(name), val) end subroutine wrap_json_value_add_real_vec !***************************************************************************************** #ifndef REAL32 !***************************************************************************************** !> ! Alternate version of [[json_value_add_real]] where `val` is `real32`. subroutine json_value_add_real32(json,p,name,val) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: name !! variable name real(real32),intent(in) :: val !! real value call json%add(p,name,real(val,RK)) end subroutine json_value_add_real32 !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_value_add_real32]] where `name` is kind=CDK. subroutine wrap_json_value_add_real32(json,p,name,val) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CDK,len=*),intent(in) :: name !! variable name real(real32),intent(in) :: val !! real value call json%add(p, to_unicode(name), val) end subroutine wrap_json_value_add_real32 !***************************************************************************************** !***************************************************************************************** !> ! Alternate version of [[json_value_add_real_vec]] where `val` is `real32`. subroutine json_value_add_real32_vec(json, p, name, val) implicit none class(json_core),intent(inout) :: json type(json_value),pointer :: p character(kind=CK,len=*),intent(in) :: name real(real32),dimension(:),intent(in) :: val call json%add(p,name,real(val,RK)) end subroutine json_value_ad