!*****************************************************************************************
!> author: Jacob Williams
! license: BSD
!
!# JSON-Fortran:
! A Fortran 2008 JSON (JavaScript Object Notation) API.
!
! [TOC]
!
! This module provides an interface for reading and writing JSON files.
!
!@note ```-DUSE_UCS4``` is an optional preprocessor flag.
! When present, Unicode support is enabled. Note that this
! is currently only supported with the gfortran compiler.
! Example: ```gfortran -DUSE_UCS4 ... ```
#ifdef USE_UCS4
# pragma push_macro("USE_UCS4")
# undef USE_UCS4
! The documentation given here assumes ```USE_UCS4``` **is** defined.
# pragma pop_macro("USE_UCS4")
#else
! The documentation given here assumes ```USE_UCS4``` **is not** defined.
#endif
!
!@warning ```CK``` and ```CDK``` are the JSON-Fortran character kind and JSON-Fortran default
! character kind respectively. Client code **MUST** ensure characters of ```kind=CK```
! are used for all character variables and strings passed to the JSON-Fortran
! library *EXCEPT* for file names which must be of ```'DEFAULT'``` character kind,
! provided here as ```CDK```. In particular, any variable that is a: json path, string
! value or object name passed to the JSON-Fortran library **MUST** be of type ```CK```.
!
!@note Most string literal constants of default kind are fine to pass as arguments to
! JSON-Fortran procedures since they have been overloaded to accept ```intent(in)```
! character arguments of the default (```CDK```) kind. If you find a procedure which does
! not accept an ```intent(in)``` literal string argument of default kind, please
! [file an issue](https://github.com/jacobwilliams/json-fortran/issues/new) on github.
!
!## License
!
! **JSON-Fortran License:**
!
! JSON-Fortran: A Fortran 2008 JSON API
!
! http://github.com/jacobwilliams/json-fortran
!
! Copyright (c) 2014-2015, Jacob Williams
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
! * Redistributions of source code must retain the above copyright notice, this
! list of conditions and the following disclaimer.
! * Redistributions in binary form must reproduce the above copyright notice, this
! list of conditions and the following disclaimer in the documentation and/or
! other materials provided with the distribution.
! * The names of its contributors may not be used to endorse or promote products
! derived from this software without specific prior written permission.
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! **Original FSON License:**
!
! Copyright (c) 2012 Joseph A. Levin
!
! Permission is hereby granted, free of charge, to any person obtaining a copy of this
! software and associated documentation files (the "Software"), to deal in the Software
! without restriction, including without limitation the rights to use, copy, modify, merge,
! publish, distribute, sublicense, and/or sell copies of the Software, and to permit
! persons to whom the Software is furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all copies or
! substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,
! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT
! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
! DEALINGS IN THE SOFTWARE.
!
!## History
! * Joseph A. Levin : March 2012 : Original FSON code [retrieved on 12/2/2013].
! * Jacob Williams : 2/8/2014 : Extensive modifications to the original FSON code.
! The original F95 code was split into four files:
! fson_path_m.f95, fson_string_m.f95, fson_value_m.f95, and fson.f95.
! The new code has been extensively updated, refactored and combined into this
! one module (json_module.f90).
! Various Fortran 2003/2008 features are now used
! (e.g., allocatable strings, newunit, generic, class, and abstract interface).
! * Development continues at: [Github](http://github.com/jacobwilliams/json-fortran)
!
!## See also
! * [json-fortran development site](http://github.com/jacobwilliams/json-fortran)
! * [json-fortran online documentation](http://jacobwilliams.github.io/json-fortran)
! * [JSON website](http://www.json.org/)
! * [JSON validator](http://jsonlint.com/)
module json_module
use,intrinsic :: iso_fortran_env
implicit none
private
integer,parameter :: RK = real64 !! Default real kind [8 bytes]
integer,parameter :: IK = int32 !! Default integer kind [4 bytes].
!*********************************************************
!>
! Processor dependendant 'DEFAULT' character kind.
! This is 1 byte for the Intel and Gfortran compilers.
integer,parameter,public :: CDK = selected_char_kind('DEFAULT')
!*********************************************************
!*********************************************************
!>
! Default logical kind.
! This is 4 bytes for the Intel and Gfortran compilers
! (and perhaps others).
! The declaration ensures a valid kind
! if the compiler doesn't have a logical_kinds(3).
!
integer,parameter :: LK = logical_kinds(min(3,size(logical_kinds)))
!*********************************************************
!*********************************************************
!>
! String kind preprocessor macro.
!
#if defined __GFORTRAN__ && defined USE_UCS4
! gfortran compiler AND UCS4 support requested:
character(kind=CDK,len=*),parameter :: json_fortran_string_kind = 'ISO_10646'
#else
! this is the string kind to use unless compiling with GFortran AND
! UCS4/ISO 10646 support is requested
character(kind=CDK,len=*),parameter :: json_fortran_string_kind = 'DEFAULT'
#endif
!*********************************************************
!*********************************************************
!>
! Default character kind used by JSON-Fortran.
! If ISO 10646 (UCS4) support is available, use that,
! otherwise, gracefully fall back on 'DEFAULT' characters.
! Currently only gfortran >= 4.9.2 will correctly support
! UCS4 which is stored in 4 bytes.
! (and perhaps others).
integer,parameter,public :: CK = selected_char_kind(json_fortran_string_kind)
!*********************************************************
!*********************************************************
! File encoding preprocessor macro.
!
#if defined __GFORTRAN__ && defined USE_UCS4
! gfortran compiler AND UCS4 support requested, & silence redefine warning:
! Make sure we output files with utf-8 encoding too
#define FILE_ENCODING ,encoding='UTF-8'
#else
! don't ask for utf-8 file encoding unless using UCS4
! this may let us use unformatted stream io to read in files more quickly
! even with unicode support turned on `inquire( ... encoding=FL_ENCODING)`
! may be able to detect json files in which each character is exactly one
! byte
#define FILE_ENCODING
#endif
!*********************************************************
!*********************************************************
! This C preprocessor macro will take a procedure name as an
! input, and output either that same procedure name if the
! code is compiled without USE_UCS4 being defined or it will
! expand the procedure name to the original procedure name,
! followed by a comma and then the original procedure name
! with 'wrap_' prepended to it. This is suitable for creating
! overloaded interfaces that will accept UCS4 character actual
! arguments as well as DEFAULT/ASCII character arguments,
! based on whether or not ISO 10646 is supported and requested.
!
# ifdef USE_UCS4
# ifdef __GFORTRAN__
! gfortran uses cpp in old-school compatibility mode so
! the # stringify and ## concatenate operators don't work
! but we can use C/C++ style comment to ensure PROCEDURE is
! correctly tokenized and prepended with 'wrap_' when the
! macro is expanded
# define MAYBEWRAP(PROCEDURE) PROCEDURE , wrap_/**/PROCEDURE
# endif
! ifdef __INTEL_COMPILER
! Intel's fpp does support the more contemporary ## concatenation
! operator, but doesn't treat the C/C++ comments the same way.
! If you use the gfortran approach and pass the -noB switch to
! fpp, the macro will expand, but with a space between wrap_ and
! whatever PROCEDURE expands to
! Intel doesn't support ISO 10646 yet, but this is here to
! ease the transition once they do.
! define MAYBEWRAP(PROCEDURE) PROCEDURE , wrap_##PROCEDURE
! endif
# else
# define MAYBEWRAP(PROCEDURE) PROCEDURE
# 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
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
!*********************************************************
!*********************************************************
!
! The types of JSON data.
!
integer(IK),parameter,public :: json_unknown = 0 !! Unknown JSON data type (see [[json_file_variable_info]] and [[json_info]])
integer(IK),parameter,public :: json_null = 1 !! Null JSON data type (see [[json_file_variable_info]] and [[json_info]])
integer(IK),parameter,public :: json_object = 2 !! Object JSON data type (see [[json_file_variable_info]] and [[json_info]])
integer(IK),parameter,public :: json_array = 3 !! Array JSON data type (see [[json_file_variable_info]] and [[json_info]])
integer(IK),parameter,public :: json_logical = 4 !! Logical JSON data type (see [[json_file_variable_info]] and [[json_info]])
integer(IK),parameter,public :: json_integer = 5 !! Integer JSON data type (see [[json_file_variable_info]] and [[json_info]])
integer(IK),parameter,public :: json_double = 6 !! Double JSON data type (see [[json_file_variable_info]] and [[json_info]])
integer(IK),parameter,public :: json_string = 7 !! String JSON data type (see [[json_file_variable_info]] and [[json_info]])
!*********************************************************
!*********************************************************
!>
! Type used to construct the linked-list JSON structure.
! Normally, this should always be a pointer variable.
!
!# Example
!
! The following test program:
!```fortran
! program test
! use json_module
! implicit none
! type(json_value),pointer :: p
! call json_initialize() !initialize the module
! call json_create_object(p,'') !create the root
! call json_add(p,'year',1805) !add some data
! call json_add(p,'value',1.0d0) !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
! }
!```
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
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
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
!*********************************************************
!*********************************************************
!> author: Jacob Williams
! date: 12/9/2013
!
! The json_file is the main public class that is
! used to open a file and get data from it.
!
!# Example
!
!```fortran
! program test
! use json_module
! implicit none
! type(json_file) :: json
! integer :: ival
! real(real64) :: rval
! character(len=:),allocatable :: cval
! logical :: found
! call json_initialize()
! call json%load_file(filename='myfile.json')
! call json%print_file() !print to the console
! call json%get('var.i',ival,found)
! call json%get('var.r(3)',rval,found)
! call json%get('var.c',cval,found)
! call json%destroy()
! end program test
!```
type,public :: json_file
private
type(json_value),pointer :: p => null() !! the JSON structure read from the file
contains
procedure,public :: load_file => json_file_load
generic, public :: load_from_string => MAYBEWRAP(json_file_load_from_string)
procedure,public :: destroy => json_file_destroy
procedure,public :: move => json_file_move_pointer
generic,public :: info => MAYBEWRAP(json_file_variable_info)
procedure,public :: print_to_string => json_file_print_to_string
generic,public :: print_file => json_file_print_to_console, &
json_file_print_1, &
json_file_print_2
generic,public :: get => MAYBEWRAP(json_file_get_object), &
MAYBEWRAP(json_file_get_integer), &
MAYBEWRAP(json_file_get_double), &
MAYBEWRAP(json_file_get_logical), &
MAYBEWRAP(json_file_get_string), &
MAYBEWRAP(json_file_get_integer_vec), &
MAYBEWRAP(json_file_get_double_vec), &
MAYBEWRAP(json_file_get_logical_vec), &
MAYBEWRAP(json_file_get_string_vec), &
json_file_get_root
generic,public :: update => MAYBEWRAP(json_file_update_integer), &
MAYBEWRAP(json_file_update_logical), &
MAYBEWRAP(json_file_update_real), &
MAYBEWRAP(json_file_update_string)
# ifdef USE_UCS4
generic,public :: update => json_file_update_string_name_ascii, &
json_file_update_string_val_ascii
# endif
!load from string:
procedure :: MAYBEWRAP(json_file_load_from_string)
!git info:
procedure :: MAYBEWRAP(json_file_variable_info)
!get:
procedure :: MAYBEWRAP(json_file_get_object)
procedure :: MAYBEWRAP(json_file_get_integer)
procedure :: MAYBEWRAP(json_file_get_double)
procedure :: MAYBEWRAP(json_file_get_logical)
procedure :: MAYBEWRAP(json_file_get_string)
procedure :: MAYBEWRAP(json_file_get_integer_vec)
procedure :: MAYBEWRAP(json_file_get_double_vec)
procedure :: MAYBEWRAP(json_file_get_logical_vec)
procedure :: MAYBEWRAP(json_file_get_string_vec)
procedure :: json_file_get_root
!update:
procedure :: MAYBEWRAP(json_file_update_integer)
procedure :: MAYBEWRAP(json_file_update_logical)
procedure :: MAYBEWRAP(json_file_update_real)
procedure :: MAYBEWRAP(json_file_update_string)
# ifdef USE_UCS4
procedure :: json_file_update_string_name_ascii
procedure :: json_file_update_string_val_ascii
# endif
!print_file:
procedure :: json_file_print_to_console
procedure :: json_file_print_1
procedure :: json_file_print_2
end type json_file
!*********************************************************
!*********************************************************
!> author: Izaak Beekman
! date: 07/23/2015
!
! Structure constructor to initialize a [[json_file(type)]] object
! with an existing [[json_value]] object
!
!# Example
!
!```fortran
! ...
! type(json_file) :: my_file
! type(json_value) :: json_object
! ...
! ! Construct a json_object
! my_file = json_file(json_object)
!```
interface json_file
module procedure initialize_json_file
end interface
!*************************************************************************************
!*************************************************************************************
abstract interface
subroutine array_callback_func(element, i, count)
!! Array element callback function. Used by [[json_get_array]]
import :: json_value,IK
implicit none
type(json_value), pointer,intent(in) :: element
integer(IK),intent(in) :: i !index
integer(IK),intent(in) :: count !size of array
end subroutine array_callback_func
subroutine traverse_callback_func(p,finished)
!! Callback function used by [[json_traverse]]
import :: json_value,LK
implicit none
type(json_value),pointer,intent(in) :: p
logical(LK),intent(out) :: finished
end subroutine traverse_callback_func
end interface
!*************************************************************************************
# ifdef USE_UCS4
! Provide a means to convert to UCS4 while concatenating UCS4 and default strings
interface operator(//)
module procedure ucs4_join_default, default_join_ucs4
end interface
! Provide a string comparison operator that works with mixed kinds
interface operator(==)
module procedure ucs4_comp_default, default_comp_ucs4
end interface
# endif
!*************************************************************************************
!>
! Get a child, either by index or name string.
! Both of these return a [[json_value]] pointer.
!
!@note Formerly, this was called json_value_get_child
interface json_get_child
module procedure json_value_get_by_index
module procedure MAYBEWRAP(json_value_get_by_name_chars)
end interface json_get_child
!*************************************************************************************
!*************************************************************************************
!>
! Add objects to a linked list of [[json_value]]s.
!
!@note Formerly, this was called json_value_add
interface json_add
module procedure json_value_add_member
module procedure MAYBEWRAP(json_value_add_integer)
module procedure MAYBEWRAP(json_value_add_integer_vec)
module procedure MAYBEWRAP(json_value_add_double)
module procedure MAYBEWRAP(json_value_add_double_vec)
module procedure MAYBEWRAP(json_value_add_logical)
module procedure MAYBEWRAP(json_value_add_logical_vec)
module procedure MAYBEWRAP(json_value_add_string)
module procedure MAYBEWRAP(json_value_add_string_vec)
# ifdef USE_UCS4
module procedure json_value_add_string_name_ascii
module procedure json_value_add_string_val_ascii
module procedure json_value_add_string_vec_name_ascii
module procedure json_value_add_string_vec_val_ascii
# endif
end interface json_add
!*************************************************************************************
!*************************************************************************************
!>
! These are like [[json_add]], except if a child with the same name 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).
!
!@note It should not be used to change the type of a variable in an array,
! or it may result in an invalid JSON file.
interface json_update
module procedure MAYBEWRAP(json_update_logical),&
MAYBEWRAP(json_update_double),&
MAYBEWRAP(json_update_integer),&
MAYBEWRAP(json_update_string)
# ifdef USE_UCS4
module procedure json_update_string_name_ascii
module procedure json_update_string_val_ascii
# endif
end interface json_update
!*************************************************************************************
!*************************************************************************************
!>
! Get data from a [[json_value]] linked list.
!
!@note There are two versions (e.g. [[json_get_integer]] and [[json_get_integer_with_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.
interface json_get
module procedure MAYBEWRAP(json_get_by_path)
module procedure json_get_integer, MAYBEWRAP(json_get_integer_with_path)
module procedure json_get_integer_vec, MAYBEWRAP(json_get_integer_vec_with_path)
module procedure json_get_double, MAYBEWRAP(json_get_double_with_path)
module procedure json_get_double_vec, MAYBEWRAP(json_get_double_vec_with_path)
module procedure json_get_logical, MAYBEWRAP(json_get_logical_with_path)
module procedure json_get_logical_vec, MAYBEWRAP(json_get_logical_vec_with_path)
module procedure json_get_string, MAYBEWRAP(json_get_string_with_path)
module procedure json_get_string_vec, MAYBEWRAP(json_get_string_vec_with_path)
module procedure json_get_array, MAYBEWRAP(json_get_array_with_path)
end interface json_get
!*************************************************************************************
!*************************************************************************************
!>
! Print the json_value structure to an allocatable string.
interface json_print_to_string
module procedure json_value_to_string
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Print the [[json_value]] to a file.
!
!# Example
!
!```fortran
! type(json_value) :: p
! !...
! call json_print(p,'test.json') !this is [[json_print_2]]
!```
interface json_print
module procedure json_print_1 !input is unit number
module procedure json_print_2 !input is file name
end interface
!*************************************************************************************
!*************************************************************************************
!>
! 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_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_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
!```
interface json_destroy
module procedure json_value_destroy
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Remove a [[json_value]] from a linked-list structure.
interface json_remove
module procedure json_value_remove
end interface
!*************************************************************************************
!*************************************************************************************
!>
! If the child variable is present, then remove it.
interface json_remove_if_present
module procedure MAYBEWRAP(json_value_remove_if_present)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Allocate a [[json_value]] pointer and make it a double variable.
! The pointer should not already be allocated.
!
!# Example
!
!```fortran
! type(json_value),pointer :: p
! call json_create_double(p,'value',1.0d0)
!```
interface json_create_double
module procedure MAYBEWRAP(json_value_create_double)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Allocate a [[json_value]] pointer and make it an array variable.
! The pointer should not already be allocated.
!
!# Example
!
!```fortran
! type(json_value),pointer :: p
! call json_create(p,'arrayname')
!```
interface json_create_array
module procedure MAYBEWRAP(json_value_create_array)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Allocate a [[json_value]] pointer and make it an object variable.
! The pointer should not already be allocated.
!
!# Example
!
!```fortran
! type(json_value),pointer :: p
! call json_create(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.
interface json_create_object
module procedure MAYBEWRAP(json_value_create_object)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Allocate a json_value pointer and make it a null variable.
! The pointer should not already be allocated.
!
!# Example
!
!```fortran
! type(json_value),pointer :: p
! call json_create_null(p,'value')
!```
interface json_create_null
module procedure MAYBEWRAP(json_value_create_null)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Allocate a json_value pointer and make it a string variable.
! The pointer should not already be allocated.
!
!# Example
!
!```fortran
! type(json_value),pointer :: p
! call json_create_string(p,'value','foobar')
!```
interface json_create_string
module procedure MAYBEWRAP(json_value_create_string)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Allocate a json_value pointer and make it an integer variable.
! The pointer should not already be allocated.
!
!# Example
!
!```fortran
! type(json_value),pointer :: p
! call json_create_integer(p,'value',42)
!```
interface json_create_integer
module procedure MAYBEWRAP(json_value_create_integer)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Allocate a json_value pointer and make it a logical variable.
! The pointer should not already be allocated.
!
!# Example
!
!```fortran
! type(json_value),pointer :: p
! call json_create_logical(p,'value',.true.)
!```
interface json_create_logical
module procedure MAYBEWRAP(json_value_create_logical)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Parse the JSON file and populate the [[json_value]] tree.
interface json_parse
module procedure json_parse_file, MAYBEWRAP(json_parse_string)
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Convert a 'DEFAULT' kind character input to 'ISO_10646' kind and return it
interface to_unicode
module procedure to_uni, to_uni_vec
end interface
!*************************************************************************************
!*************************************************************************************
!>
! Throw an exception.
interface throw_exception
module procedure MAYBEWRAP(json_throw_exception)
end interface throw_exception
!*************************************************************************************
!public routines:
public :: json_add ! add data to a JSON structure
public :: json_check_for_errors ! check for error and get error message
public :: json_clear_exceptions ! clear exceptions
public :: json_count ! count the number of children
public :: json_create_array ! allocate a json_value array
public :: json_create_double ! allocate a json_value double
public :: json_create_integer ! allocate a json_value integer
public :: json_create_logical ! allocate a json_value logical
public :: json_create_null ! allocate a json_value null
public :: json_create_object ! allocate a json_value object
public :: json_create_string ! allocate a json_value string
public :: json_destroy ! clear a JSON structure (destructor)
public :: json_failed ! check for error
public :: json_get ! get data from the JSON structure
public :: json_get_child ! get a child of a json_value
public :: json_info ! get info about a json_value
public :: json_initialize ! to initialize the module
public :: json_parse ! read a JSON file and populate the structure
public :: json_print ! print the JSON structure to a file
public :: json_print_to_string ! write the JSON structure to a string
public :: json_remove ! remove from a JSON structure
public :: json_remove_if_present ! remove from a JSON structure (if it is present)
public :: json_update ! update a value in a JSON structure
public :: json_traverse ! to traverse all elements of a JSON structure
public :: json_print_error_message !
public :: to_unicode ! Function to convert from 'DEFAULT' to 'ISO_10646' strings
# ifdef USE_UCS4
public :: operator(//)
public :: operator(==)
# endif
character(kind=CDK,len=*),parameter,public :: json_ext = '.json' !! JSON file extension
!special JSON characters
character(kind=CK,len=*),parameter :: space = ' '
character(kind=CK,len=*),parameter :: start_object = '{'
character(kind=CK,len=*),parameter :: end_object = '}'
character(kind=CK,len=*),parameter :: start_array = '['
character(kind=CK,len=*),parameter :: end_array = ']'
character(kind=CK,len=*),parameter :: delimiter = ','
character(kind=CK,len=*),parameter :: colon_char = ':'
character(kind=CK,len=*),parameter :: bspace = achar(8)
character(kind=CK,len=*),parameter :: horizontal_tab = achar(9)
character(kind=CK,len=*),parameter :: newline = achar(10)
character(kind=CK,len=*),parameter :: formfeed = achar(12)
character(kind=CK,len=*),parameter :: carriage_return = achar(13)
character(kind=CK,len=*),parameter :: quotation_mark = achar(34)
character(kind=CK,len=*),parameter :: slash = achar(47)
character(kind=CK,len=*),parameter :: backslash = achar(92)
!These were parameters, but gfortran bug (https://gcc.gnu.org/bugzilla/show_bug.cgi?id=65141)
!necessitates moving them here to be variables
character(kind=CK,len=4) :: null_str = 'null'
character(kind=CK,len=4) :: true_str = 'true'
character(kind=CK,len=5) :: false_str = 'false'
! Control characters, possibly in unicode
integer, private :: i_
character(kind=CK,len=*),parameter :: control_chars(32) = [(achar(i_),i_=1,31), achar(127)]
!for indenting (Note: jsonlint.com uses 4 spaces)
integer(IK),parameter :: spaces_per_tab = 2
!Variables for real string printing:
logical(LK) :: compact_real = .true. !! to use the "compact" form of real numbers for output
!find out the precision of the floating point number system
!and set safety factors
integer(IK),parameter :: rp_safety_factor = 1
integer(IK),parameter :: rp_addl_safety = 1
integer(IK),parameter :: real_precision = rp_safety_factor*precision(1.0_RK) + &
rp_addl_safety
!Get the number of possible digits in the exponent when using decimal number system
integer(IK),parameter :: maxexp = maxexponent(1.0_RK)
integer(IK),parameter :: minexp = minexponent(1.0_RK)
integer(IK),parameter :: real_exponent_digits = floor( 1 + log10( &
real(max(maxexp,abs(maxexp)),&
kind=RK) ) )
integer(IK),parameter :: max_numeric_str_len = real_precision + real_exponent_digits + 6
!! 6 = sign + leading 0 + decimal + 'E' + exponent sign + 1 extra
character(kind=CDK,len=*),parameter :: int_fmt = '(ss,I0)' !! minimum width format for integers
character(kind=CK, len=*),parameter :: star = '*' !! for invalid numbers
character(kind=CDK,len=:),allocatable :: real_fmt !! the format string to use for real numbers
!! it is set in [[json_initialize]]
!
! Note: the following global variables make this module non thread safe.
!
!exception handling [private variables]
logical(LK) :: is_verbose = .false. !! if true, all exceptions are immediately printed to console
logical(LK) :: exception_thrown = .true. !! the error flag (by default, this is true to make sure that [[json_initialize]] is called.
character(kind=CK,len=:),allocatable :: err_message !! the error message
!temp vars used when parsing lines in file [private variables]
integer(IK) :: char_count = 0 !character position in the current line
integer(IK) :: line_count = 1 !lines read counter
integer(IK) :: pushed_index = 0
character(kind=CK,len=10) :: pushed_char = '' !JW : what is this magic number 10??
integer(IK),parameter :: chunk_size = 100 !! for allocatable strings: allocate chunks of this size
integer(IK) :: ipos = 1 !! for allocatable strings: next character to read
integer(IK),parameter :: unit2str = -1 !! unit number to cause stuff to be
!! output to strings rather than files.
!! See 9.5.6.12 in the F2003/08 standard
contains
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
! date: 07/23/2015
!
! Cast a [[json_value]] object as a [[json_file(type)]] object
function initialize_json_file(p) result(file_object)
implicit none
type(json_value), pointer, optional, intent(in) :: p !! `json_value` object to cast
!! as a `json_file` object
type(json_file) :: file_object
if (present(p)) file_object%p => p
end function initialize_json_file
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Destroy the data within a [[json_value]], and rest type to `json_unknown`.
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: 12/9/2013
!
! Destroy the [[json_file(type)]].
subroutine json_file_destroy(me)
implicit none
class(json_file),intent(inout) :: me
if (associated(me%p)) call json_value_destroy(me%p)
end subroutine json_file_destroy
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/5/2014
!
! Move the [[json_value]] pointer from one [[json_file(type)]] to another.
! The "from" pointer is then nullified, but not destroyed.
!
!@note If "from%p" is not associated, then an error is thrown.
subroutine json_file_move_pointer(to,from)
implicit none
class(json_file),intent(inout) :: to
class(json_file),intent(inout) :: from
if (associated(from%p)) then
to%p => from%p
nullify(from%p)
else
call throw_exception('Error in json_file_move_pointer: '//&
'pointer is not associated.')
end if
end subroutine json_file_move_pointer
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/9/2013
!
! Load the JSON data from a file.
!
!# Example
!
!```fortran
! type(json_file) :: f
! call f%load_file('my_file.json')
!```
subroutine json_file_load(me, filename, unit)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: filename !! the filename to open
integer(IK),intent(in),optional :: unit !! the unit number to use
call json_parse(file=filename, p=me%p, unit=unit)
end subroutine json_file_load
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/13/2015
!
! Load the JSON data from a string.
!
!# Example
!
! Load JSON from a string:
!```fortran
! type(json_file) :: f
! call f%load_from_string('{ "name": "Leonidas" }')
!```
subroutine json_file_load_from_string(me, str)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: str !! string to load JSON data from
call json_parse(str=str, p=me%p)
end subroutine json_file_load_from_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_load_from_string]], where "str" is kind=CDK.
subroutine wrap_json_file_load_from_string(me, str)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: str
call json_file_load_from_string(me,to_unicode(str))
end subroutine wrap_json_file_load_from_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/11/2015
!
! Print the JSON file to the console.
subroutine json_file_print_to_console(me)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=:),allocatable :: dummy
call json_value_print(me%p,iunit=output_unit,str=dummy,indent=1,colon=.true.)
end subroutine json_file_print_to_console
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/9/2013
!
! Prints the JSON file to the specified file unit number.
subroutine json_file_print_1(me, iunit)
implicit none
class(json_file),intent(inout) :: me
integer(IK),intent(in) :: iunit !! file unit number (must not be -1)
integer(IK) :: i
character(kind=CK,len=:),allocatable :: dummy
if (iunit/=unit2str) then
i = iunit
call json_value_print(me%p,iunit=i,str=dummy,indent=1,colon=.true.)
else
call throw_exception('Error in json_file_print_1: iunit must not be -1.')
end if
end subroutine json_file_print_1
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/11/2015
!
! Print the JSON structure to the specified filename.
! The file is opened, printed, and then closed.
!
!# Example
! Example loading a JSON file, changing a value, and then printing
! result to a new file:
!```fortran
! type(json_file) :: f
! logical :: found
! call f%load_file('my_file.json') !open the original file
! call f%update('version',4,found) !change the value of a variable
! call f%print_file('my_file_2.json') !save file as new name
!```
subroutine json_file_print_2(me,filename)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: filename !! filename to print to
integer(IK) :: iunit,istat
open(newunit=iunit,file=filename,status='REPLACE',iostat=istat FILE_ENCODING )
if (istat==0) then
call me%print_file(iunit) !call the other routine
close(iunit,iostat=istat)
else
call throw_exception('Error in json_file_print_2: could not open file: '//&
trim(filename))
end if
end subroutine json_file_print_2
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/11/2015
!
! Print the JSON file to a string.
!
!# Example
!
! Open a JSON file, and then print the contents to a string:
!```fortran
! type(json_file) :: f
! character(kind=CK,len=:),allocatable :: str
! call f%load_file('my_file.json')
! call f%print_file(str)
!```
subroutine json_file_print_to_string(me,str)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=:),allocatable,intent(out) :: str !! string to print JSON data to
call json_value_to_string(me%p,str)
end subroutine json_file_print_to_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 2/3/2014
!
! Returns information about a variable in a [[json_file(type)]].
subroutine json_file_variable_info(me,path,found,var_type,n_children)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path !! path to the variable
logical(LK),intent(out) :: found !! the variable exists in the structure
integer(IK),intent(out) :: var_type !! variable type
integer(IK),intent(out) :: n_children !! number of children
type(json_value),pointer :: p
!initialize:
nullify(p)
!get a pointer to the variable (if it is there):
call me%get(path,p,found)
if (found) then
!get info:
call json_info(p,var_type,n_children)
else
!set to dummy values:
var_type = json_unknown
n_children = 0
end if
!cleanup:
nullify(p)
end subroutine json_file_variable_info
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_variable_info]], where "path" is kind=CDK.
subroutine wrap_json_file_variable_info(me,path,found,var_type,n_children)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
logical(LK),intent(out) :: found
integer(IK),intent(out) :: var_type
integer(IK),intent(out) :: n_children
call json_file_variable_info(me,to_unicode(path),found,var_type,n_children)
end subroutine wrap_json_file_variable_info
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 2/13/2014
!
! Returns information about a [[json_value]].
subroutine json_info(p,var_type,n_children,name)
implicit none
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 (present(var_type)) var_type = p%var_type
if (present(n_children)) n_children = json_count(p)
if (present(name)) name = p%name
end subroutine json_info
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 2/3/2014
!
! Get a [[json_value]] pointer to an object from a JSON file.
subroutine json_file_get_object(me, path, p, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path !! the path to the variable
type(json_value),pointer,intent(out) :: p !! pointer to the variable
logical(LK),intent(out),optional :: found !! if it was really found
call json_get_by_path(me%p, path=path, p=p, found=found)
end subroutine json_file_get_object
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
! date: 7/23/2015
!
! Get a [[json_value]] pointer to the JSON file root.
!
!@note This is equivalent to calling ```[[json_file]]%get('$',p)```
subroutine json_file_get_root(me,p)
implicit none
class(json_file),intent(inout) :: me
type(json_value),pointer,intent(out) :: p !! pointer to the variable
p => me%p
end subroutine json_file_get_root
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_object]], where "path" is kind=CDK.
subroutine wrap_json_file_get_object(me, path, p, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
type(json_value),pointer,intent(out) :: p
logical(LK),intent(out),optional :: found
call json_file_get_object(me, to_unicode(path), p, found)
end subroutine wrap_json_file_get_object
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/9/2013
!
! Get an integer value from a JSON file.
subroutine json_file_get_integer(me, path, val, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path !! the path to the variable
integer(IK),intent(out) :: val !! value
logical(LK),intent(out),optional :: found !! if it was really found
call json_get(me%p, path=path, value=val, found=found)
end subroutine json_file_get_integer
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_integer]], where "path" is kind=CDK.
subroutine wrap_json_file_get_integer(me, path, val, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
integer(IK),intent(out) :: val
logical(LK),intent(out),optional :: found
call json_file_get_integer(me, to_unicode(path), val, found)
end subroutine wrap_json_file_get_integer
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/20/2014
!
! Get an integer vector from a JSON file.
subroutine json_file_get_integer_vec(me, path, vec, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path !! the path to the variable
integer(IK),dimension(:),allocatable,intent(out) :: vec !! the value vector
logical(LK),intent(out),optional :: found !! if it was really found
call json_get(me%p, path, vec, found)
end subroutine json_file_get_integer_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_integer_vec]], where "path" is kind=CDK.
subroutine wrap_json_file_get_integer_vec(me, path, vec, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
integer(IK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_file_get_integer_vec(me, to_unicode(path), vec, found)
end subroutine wrap_json_file_get_integer_vec
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/9/2013
!
! Get a real(RK) variable value from a JSON file.
subroutine json_file_get_double (me, path, val, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path
real(RK),intent(out) :: val
logical(LK),intent(out),optional :: found
call json_get(me%p, path=path, value=val, found=found)
end subroutine json_file_get_double
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_double]], where "path" is kind=CDK.
subroutine wrap_json_file_get_double (me, path, val, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
real(RK),intent(out) :: val
logical(LK),intent(out),optional :: found
call json_file_get_double(me, to_unicode(path), val, found)
end subroutine wrap_json_file_get_double
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/19/2014
!
! Get a real(RK) vector from a JSON file.
subroutine json_file_get_double_vec(me, path, vec, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path
real(RK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_get(me%p, path, vec, found)
end subroutine json_file_get_double_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_double_vec]], where "path" is kind=CDK.
subroutine wrap_json_file_get_double_vec(me, path, vec, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
real(RK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_file_get_double_vec(me, to_unicode(path), vec, found)
end subroutine wrap_json_file_get_double_vec
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/9/2013
!
! Get a logical(LK) value from a JSON file.
subroutine json_file_get_logical(me,path,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path
logical(LK),intent(out) :: val
logical(LK),intent(out),optional :: found
call json_get(me%p, path=path, value=val, found=found)
end subroutine json_file_get_logical
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_logical]], where "path" is kind=CDK.
subroutine wrap_json_file_get_logical(me,path,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
logical(LK),intent(out) :: val
logical(LK),intent(out),optional :: found
call json_file_get_logical(me, to_unicode(path), val, found)
end subroutine wrap_json_file_get_logical
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/20/2014
!
! Get a logical(LK) vector from a JSON file.
subroutine json_file_get_logical_vec(me, path, vec, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path
logical(LK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_get(me%p, path, vec, found)
end subroutine json_file_get_logical_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_logical_vec]], where "path" is kind=CDK.
subroutine wrap_json_file_get_logical_vec(me, path, vec, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
logical(LK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_file_get_logical_vec(me, to_unicode(path), vec, found)
end subroutine wrap_json_file_get_logical_vec
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/9/2013
!
! Get a character string from a json file.
! The output val is an allocatable character string.
subroutine json_file_get_string(me, path, val, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path
character(kind=CK,len=:),allocatable,intent(out) :: val
logical(LK),intent(out),optional :: found
call json_get(me%p, path=path, value=val, found=found)
end subroutine json_file_get_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_string]], where "path" is kind=CDK.
subroutine wrap_json_file_get_string(me, path, val, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
character(kind=CK,len=:),allocatable,intent(out) :: val
logical(LK),intent(out),optional :: found
call json_file_get_string(me, to_unicode(path), val, found)
end subroutine wrap_json_file_get_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/19/2014
!
! Get a string vector from a JSON file.
subroutine json_file_get_string_vec(me, path, vec, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: path
character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_get(me%p, path, vec, found)
end subroutine json_file_get_string_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_get_string_vec]], where "path" is kind=CDK.
subroutine wrap_json_file_get_string_vec(me, path, vec, found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: path
character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_file_get_string_vec(me, to_unicode(path), vec, found)
end subroutine wrap_json_file_get_string_vec
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/4/2013
!
! Initialize the JSON-Fortran module.
! The routine must be called before any of the routines are used.
! It can also be called after using the module and encountering exceptions.
!
!# Modified
! * Izaak Beekman : 02/24/2015
subroutine json_initialize(verbose,compact_reals,print_signs,real_format)
implicit none
logical(LK),intent(in),optional :: verbose !! mainly useful for debugging (default is false)
logical(LK),intent(in),optional :: compact_reals !! to compact the real number strings for output (default is true)
logical(LK),intent(in),optional :: print_signs !! always print numeric sign (default is false)
character(len=*,kind=CDK),intent(in),optional :: real_format !! exponential (default), scientific, engineering or general
character(kind=CDK,len=10) :: w,d,e
character(kind=CDK,len=2) :: sgn, rl_edit_desc
integer(IK) :: istat
logical(LK) :: sgn_prnt
!clear any errors from previous runs:
call json_clear_exceptions()
!Ensure gfortran bug work around "parameters" are set properly
null_str = 'null'
true_str = 'true'
false_str = 'false'
!Just in case, clear these global variables also:
pushed_index = 0
pushed_char = ''
char_count = 0
line_count = 1
ipos = 1
# ifdef USE_UCS4
! reopen stdout and stderr with utf-8 encoding
open(output_unit,encoding='utf-8')
open(error_unit, encoding='utf-8')
# endif
!verbose error printing:
if (present(verbose)) is_verbose = verbose
!Set the format for real numbers:
! [if not changing it, then it remains the same]
if ( (.not. allocated(real_fmt)) .or. & ! if this hasn't been done yet
present(compact_reals) .or. &
present(print_signs) .or. &
present(real_format) ) then
if (present(compact_reals)) 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 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
real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) // trim(w) // '.' // trim(d) // 'E' // trim(e) // ')'
else
real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) // '30.16E3)' !just use this one (should never happen)
end if
end if
end subroutine json_initialize
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/4/2013
!
! Clear exceptions in the JSON module.
subroutine json_clear_exceptions()
implicit none
!clear the flag and message:
exception_thrown = .false.
err_message = ''
end subroutine json_clear_exceptions
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/4/2013
!
! Throw an exception in the JSON module.
! This routine sets the error flag, and prevents any subsequent routine
! from doing anything, until [[json_clear_exceptions]] is called.
subroutine json_throw_exception(msg)
implicit none
character(kind=CK,len=*),intent(in) :: msg !the error message
exception_thrown = .true.
err_message = trim(msg)
if (is_verbose) then
write(*,'(A)') '***********************'
write(*,'(A)') 'JSON-Fortran EXCEPTION: '//trim(msg)
!call backtrace() ! gfortran (use -fbacktrace -fall-intrinsics flags)
!call tracebackqq(-1) ! intel (requires "use ifcore" in this routine)
write(*,'(A)') '***********************'
end if
end subroutine json_throw_exception
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_throw_exception]], where "msg" is kind=CDK.
subroutine wrap_json_throw_exception(msg)
implicit none
character(kind=CDK,len=*),intent(in) :: msg !the error message
call json_throw_exception(to_unicode(msg))
end subroutine wrap_json_throw_exception
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/4/2013
!
! Retrieve error code from the module.
! This should be called after [[json_parse]] to check for errors.
! If an error is thrown, before using the module 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_file(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]]
subroutine json_check_for_errors(status_ok, error_msg)
implicit none
logical(LK),intent(out) :: status_ok !! true if there were no errors
character(kind=CK,len=:),allocatable,intent(out) :: error_msg !! the error message (if there were errors)
status_ok = .not. exception_thrown
if (.not. status_ok) then
if (allocated(err_message)) then
error_msg = err_message
else
error_msg = 'Error: json_initialize() must be called first to initialize the module.'
end if
else
error_msg = ''
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.
!
!# Example
!
!```fortran
! type(json_file) :: json
! logical :: status_ok
! character(len=:),allocatable :: error_msg
! call json%load_file(filename='myfile.json')
! if (json_failed()) then
! call json_check_for_errors(status_ok, error_msg)
! write(*,*) 'Error: '//error_msg
! call json_clear_exceptions()
! call json%destroy()
! end if
!```
!
!# See also
! * [[json_check_for_errors]]
!
function json_failed() result(failed)
implicit none
logical(LK) :: failed
failed = 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 to_double(var,1.0d0)
!```
!
!# Notes
! 1. This routine does not check for exceptions.
! 2. The pointer should not already be allocated.
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.
recursive subroutine json_value_destroy(me,destroy_next)
implicit none
type(json_value),pointer :: me
logical(LK),intent(in),optional :: destroy_next !! if true, then me%next is also destroyed (default is true)
logical(LK) :: des_next
type(json_value), pointer :: p
if (associated(me)) then
if (present(destroy_next)) then
des_next = destroy_next
else
des_next = .true.
end if
if (allocated(me%name)) deallocate(me%name)
call destroy_json_data(me)
if (associated(me%children)) then
do while (me%n_children > 0)
p => me%children
me%children => me%children%next
me%n_children = me%n_children - 1
call json_value_destroy(p,.false.)
end do
nullify(me%children)
nullify(p)
end if
if (associated(me%next) .and. des_next) call json_value_destroy(me%next)
if (associated(me%previous)) nullify(me%previous)
if (associated(me%parent)) nullify(me%parent)
if (associated(me%tail)) nullify(me%tail)
deallocate(me)
nullify(me)
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_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_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.
!
subroutine json_value_remove(me,destroy)
implicit none
type(json_value),pointer :: me
logical(LK),intent(in),optional :: destroy !! 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,previous,next
logical(LK) :: destroy_it
if (associated(me)) then
!optional input argument:
if (present(destroy)) then
destroy_it = destroy
else
destroy_it = .true.
end if
if (associated(me%parent)) then
parent => me%parent
if (associated(me%next)) then
!there are later items in the list:
next => me%next
nullify(me%next)
if (associated(me%previous)) then
!there are earlier items in the list
previous => me%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(me%previous)) then
!there are earlier items in the list:
previous => me%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
parent%n_children = parent%n_children - 1
end if
if (destroy_it) call json_value_destroy(me)
end if
end subroutine json_value_remove
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/6/2014
!
! Given the path string, remove the variable from
! the [[json_value]] structure, if it exists.
subroutine json_value_remove_if_present(p,name)
implicit none
type(json_value),pointer :: p
character(kind=CK,len=*),intent(in) :: name
type(json_value),pointer :: p_var
logical(LK) :: found
call json_get(p,name,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 "name" is kind=CDK.
subroutine wrap_json_value_remove_if_present(p,name)
implicit none
type(json_value),pointer :: p
character(kind=CDK,len=*),intent(in) :: name
call json_value_remove_if_present(p,to_unicode(name))
end subroutine wrap_json_value_remove_if_present
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date:1/10/2015
!
! Given the path string, if the variable is present in the file,
! and is a scalar, then update its value.
! If it is not present, then create it and set its value.
!
!# See also
! * [[json_update_integer]]
subroutine json_file_update_integer(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: name
integer(IK),intent(in) :: val
logical(LK),intent(out) :: found
if (.not. exception_thrown) call json_update(me%p,name,val,found)
end subroutine json_file_update_integer
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_update_integer]], where "name" is kind=CDK.
subroutine wrap_json_file_update_integer(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: name
integer(IK),intent(in) :: val
logical(LK),intent(out) :: found
call json_file_update_integer(me,to_unicode(name),val,found)
end subroutine wrap_json_file_update_integer
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/10/2015
!
! Given the path string, if the variable is present in the file,
! and is a scalar, then update its value.
! If it is not present, then create it and set its value.
!
!# See also
! * [[json_update_logical]]
subroutine json_file_update_logical(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: name
logical(LK),intent(in) :: val
logical(LK),intent(out) :: found
if (.not. exception_thrown) call json_update(me%p,name,val,found)
end subroutine json_file_update_logical
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_update_logical]], where "name" is kind=CDK.
subroutine wrap_json_file_update_logical(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: name
logical(LK),intent(in) :: val
logical(LK),intent(out) :: found
call json_file_update_logical(me,to_unicode(name),val,found)
end subroutine wrap_json_file_update_logical
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/10/2015
!
! Given the path string, if the variable is present in the file,
! and is a scalar, then update its value.
! If it is not present, then create it and set its value.
!
!# See also
! * [[json_update_double]]
subroutine json_file_update_real(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: name
real(RK),intent(in) :: val
logical(LK),intent(out) :: found
if (.not. exception_thrown) call json_update(me%p,name,val,found)
end subroutine json_file_update_real
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_update_real]], where "name" is kind=CDK.
subroutine wrap_json_file_update_real(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: name
real(RK),intent(in) :: val
logical(LK),intent(out) :: found
call json_file_update_real(me,to_unicode(name),val,found)
end subroutine wrap_json_file_update_real
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/10/2015
!
! Given the path string, if the variable is present in the file,
! and is a scalar, then update its value.
! If it is not present, then create it and set its value.
!
!# See also
! * [[json_update_string]]
subroutine json_file_update_string(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK,len=*),intent(in) :: name
character(kind=CK,len=*),intent(in) :: val
logical(LK),intent(out) :: found
if (.not. exception_thrown) call json_update(me%p,name,val,found)
end subroutine json_file_update_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_update_string]], where "name" and "val" are kind=CDK.
subroutine wrap_json_file_update_string(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: name
character(kind=CDK,len=*),intent(in) :: val
logical(LK),intent(out) :: found
call json_file_update_string(me,to_unicode(name),to_unicode(val),found)
end subroutine wrap_json_file_update_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_update_string]], where "name" is kind=CDK.
subroutine json_file_update_string_name_ascii(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CDK,len=*),intent(in) :: name
character(kind=CK, len=*),intent(in) :: val
logical(LK),intent(out) :: found
call json_file_update_string(me,to_unicode(name),val,found)
end subroutine json_file_update_string_name_ascii
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_file_update_string]], where "val" is kind=CDK.
subroutine json_file_update_string_val_ascii(me,name,val,found)
implicit none
class(json_file),intent(inout) :: me
character(kind=CK, len=*),intent(in) :: name
character(kind=CDK,len=*),intent(in) :: val
logical(LK),intent(out) :: found
call json_file_update_string(me,name,to_unicode(val),found)
end subroutine json_file_update_string_val_ascii
!*****************************************************************************************
!*****************************************************************************************
!> 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.
subroutine json_update_logical(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CK,len=*),intent(in) :: name
logical(LK),intent(in) :: val
logical(LK),intent(out) :: found
type(json_value),pointer :: p_var
integer(IK) :: var_type
call json_get(p,name,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_double,json_string)
call to_logical(p_var,val) !update the value
case default
found = .false.
call throw_exception('Error in json_update_logical: '//&
'the variable is not a scalar value')
end select
else
call json_add(p,name,val) !add the new element
end if
end subroutine json_update_logical
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_update_logical]], where "name" is kind=CDK.
subroutine wrap_json_update_logical(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CDK,len=*),intent(in) :: name
logical(LK),intent(in) :: val
logical(LK),intent(out) :: found
call json_update_logical(p,to_unicode(name),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.
subroutine json_update_double(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CK,len=*),intent(in) :: name
real(RK),intent(in) :: val
logical(LK),intent(out) :: found
type(json_value),pointer :: p_var
integer(IK) :: var_type
call json_get(p,name,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_double,json_string)
call to_double(p_var,val) !update the value
case default
found = .false.
call throw_exception('Error in json_update_double: '//&
'the variable is not a scalar value')
end select
else
call json_add(p,name,val) !add the new element
end if
end subroutine json_update_double
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_update_double]], where "name" is kind=CDK.
subroutine wrap_json_update_double(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CDK,len=*),intent(in) :: name
real(RK),intent(in) :: val
logical(LK),intent(out) :: found
call json_update_double(p,to_unicode(name),val,found)
end subroutine wrap_json_update_double
!*****************************************************************************************
!*****************************************************************************************
!> 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.
subroutine json_update_integer(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CK,len=*),intent(in) :: name
integer(IK),intent(in) :: val
logical(LK),intent(out) :: found
type(json_value),pointer :: p_var
integer(IK) :: var_type
call json_get(p,name,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_double,json_string)
call to_integer(p_var,val) !update the value
case default
found = .false.
call throw_exception('Error in json_update_integer: '//&
'the variable is not a scalar value')
end select
else
call json_add(p,name,val) !add the new element
end if
end subroutine json_update_integer
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_update_integer]], where "name" is kind=CDK.
subroutine wrap_json_update_integer(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CDK,len=*),intent(in) :: name
integer(IK),intent(in) :: val
logical(LK),intent(out) :: found
call json_update_integer(p,to_unicode(name),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.
subroutine json_update_string(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CK,len=*),intent(in) :: name
character(kind=CK,len=*),intent(in) :: val
logical(LK),intent(out) :: found
type(json_value),pointer :: p_var
integer(IK) :: var_type
call json_get(p,name,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_double,json_string)
call to_string(p_var,val) !update the value
case default
found = .false.
call throw_exception('Error in json_update_string: '//&
'the variable is not a scalar value')
end select
else
call json_add(p,name,val) !add the new element
end if
end subroutine json_update_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_update_string]], where "name" and "value" are kind=CDK.
subroutine wrap_json_update_string(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CDK,len=*),intent(in) :: name
character(kind=CDK,len=*),intent(in) :: val
logical(LK),intent(out) :: found
call json_update_string(p,to_unicode(name),to_unicode(val),found)
end subroutine wrap_json_update_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_update_string]], where "name" is kind=CDK.
subroutine json_update_string_name_ascii(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CDK,len=*),intent(in) :: name
character(kind=CK, len=*),intent(in) :: val
logical(LK),intent(out) :: found
call json_update_string(p,to_unicode(name),val,found)
end subroutine json_update_string_name_ascii
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_update_string]], where "val" is kind=CDK.
subroutine json_update_string_val_ascii(p,name,val,found)
implicit none
type(json_value),pointer :: p
character(kind=CK, len=*),intent(in) :: name
character(kind=CDK,len=*),intent(in) :: val
logical(LK),intent(out) :: found
call json_update_string(p,name,to_unicode(val),found)
end subroutine json_update_string_val_ascii
!*****************************************************************************************
!*****************************************************************************************
!>
! Adds "member" as a child of "me".
subroutine json_value_add_member(me, member)
implicit none
type(json_value),pointer :: me
type(json_value),pointer :: member !! the child member to add
if (.not. exception_thrown) then
! associate the parent
member%parent => me
! add to linked list
if (associated(me%children)) then
me%tail%next => member
member%previous => me%tail
else
me%children => member
member%previous => null() !first in the list
end if
! new member is now the last one in the list
me%tail => member
me%n_children = me%n_children + 1
end if
end subroutine json_value_add_member
!*****************************************************************************************
!*****************************************************************************************
!> 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_double(me, name, val)
implicit none
type(json_value),pointer :: me
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_value_create(var)
call to_double(var,val,name)
!add it:
call json_add(me, var)
!cleanup:
nullify(var)
end subroutine json_value_add_double
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_double]] where "name" is kind=CDK.
subroutine wrap_json_value_add_double(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name !! variable name
real(RK),intent(in) :: val !! real value
call json_value_add_double(me, to_unicode(name), val)
end subroutine wrap_json_value_add_double
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/20/2014
!
! Add a real vector to the structure.
!
!@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_double_vec(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name
real(RK),dimension(:),intent(in) :: val
type(json_value),pointer :: var
integer(IK) :: i
!create the variable as an array:
call json_value_create(var)
call to_array(var,name)
!populate the array:
do i=1,size(val)
call json_add(var, '', val(i))
end do
!add it:
call json_add(me, var)
!cleanup:
nullify(var)
end subroutine json_value_add_double_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_double_vec]] where "name" is kind=CDK.
subroutine wrap_json_value_add_double_vec(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
real(RK),dimension(:),intent(in) :: val
call json_value_add_double_vec(me, to_unicode(name), val)
end subroutine wrap_json_value_add_double_vec
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/20/2014
!
! Add an integer 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_integer(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name
integer(IK),intent(in) :: val
type(json_value),pointer :: var
!create the variable:
call json_value_create(var)
call to_integer(var,val,name)
!add it:
call json_add(me, var)
!cleanup:
nullify(var)
end subroutine json_value_add_integer
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_integer]] where "name" is kind=CDK.
subroutine wrap_json_value_add_integer(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name !! name of the variable
integer(IK),intent(in) :: val !! value
call json_value_add_integer(me, to_unicode(name), val)
end subroutine wrap_json_value_add_integer
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/20/2014
!
! Add an integer vector to the structure.
!
!@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_integer_vec(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name !! name of the variable
integer(IK),dimension(:),intent(in) :: val !! value
type(json_value),pointer :: var
integer(IK) :: i !counter
!create the variable as an array:
call json_value_create(var)
call to_array(var,name)
!populate the array:
do i=1,size(val)
call json_add(var, '', val(i))
end do
!add it:
call json_add(me, var)
!cleanup:
nullify(var)
end subroutine json_value_add_integer_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_integer_vec]] where "name" is kind=CDK.
subroutine wrap_json_value_add_integer_vec(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name !! name of the variable
integer(IK),dimension(:),intent(in) :: val !! value
call json_value_add_integer_vec(me, to_unicode(name), val)
end subroutine wrap_json_value_add_integer_vec
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/20/2014
!
! Add a logical 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_logical(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name !! name of the variable
logical(LK),intent(in) :: val !! value
type(json_value),pointer :: var
!create the variable:
call json_value_create(var)
call to_logical(var,val,name)
!add it:
call json_add(me, var)
!cleanup:
nullify(var)
end subroutine json_value_add_logical
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_logical]] where "name" is kind=CDK.
subroutine wrap_json_value_add_logical(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name !! name of the variable
logical(LK),intent(in) :: val !! value
call json_value_add_logical(me, to_unicode(name), val)
end subroutine wrap_json_value_add_logical
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/20/2014
!
! Add a logical vector to the structure.
!
!@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_logical_vec(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name !! name of the vector
logical(LK),dimension(:),intent(in) :: val !! value
type(json_value),pointer :: var
integer(IK) :: i !counter
!create the variable as an array:
call json_value_create(var)
call to_array(var,name)
!populate the array:
do i=1,size(val)
call json_add(var, '', val(i))
end do
!add it:
call json_add(me, var)
!cleanup:
nullify(var)
end subroutine json_value_add_logical_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_logical_vec]] where "name" is kind=CDK.
subroutine wrap_json_value_add_logical_vec(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name !! name of the variable
logical(LK),dimension(:),intent(in) :: val !! value
call json_value_add_logical_vec(me, to_unicode(name), val)
end subroutine wrap_json_value_add_logical_vec
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/19/2014
!
! Add a character string 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_string(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name !! name of the variable
character(kind=CK,len=*),intent(in) :: val !! value
type(json_value),pointer :: var
character(kind=CK,len=:),allocatable :: str
!add escape characters if necessary:
call escape_string(val, str)
!create the variable:
call json_value_create(var)
call to_string(var,str,name)
!add it:
call json_add(me, var)
!cleanup:
nullify(var)
end subroutine json_value_add_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_string]] where "name" and "val" are kind=CDK.
subroutine wrap_json_value_add_string(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name !! name of the variable
character(kind=CDK,len=*),intent(in) :: val !! value
call json_value_add_string(me, to_unicode(name), to_unicode(val))
end subroutine wrap_json_value_add_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_string]] where "name" is kind=CDK.
subroutine json_value_add_string_name_ascii(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name !! name of the variable
character(kind=CK, len=*),intent(in) :: val !! value
call json_value_add_string(me, to_unicode(name), val)
end subroutine json_value_add_string_name_ascii
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_string]] where "val" is kind=CDK.
subroutine json_value_add_string_val_ascii(me, name, val)
implicit none
type(json_value),pointer :: me
character(kind=CK, len=*),intent(in) :: name !! name of the variable
character(kind=CDK,len=*),intent(in) :: val !! value
call json_value_add_string(me, name, to_unicode(val))
end subroutine json_value_add_string_val_ascii
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/21/2014
!
! Add the escape characters to a string for adding to JSON.
subroutine escape_string(str_in, str_out)
implicit none
character(kind=CK,len=*),intent(in) :: str_in
character(kind=CK,len=:),allocatable,intent(out) :: str_out
integer(IK) :: i,ipos
character(kind=CK,len=1) :: c
character(kind=CK,len=*),parameter :: specials = quotation_mark//&
backslash//&
slash//&
bspace//&
formfeed//&
newline//&
carriage_return//&
horizontal_tab
!Do a quick scan for the special characters,
! if any are present, then process the string,
! otherwise, return the string as is.
if (scan(str_in,specials)>0) then
str_out = repeat(space,chunk_size)
ipos = 1
!go through the string and look for special characters:
do i=1,len(str_in)
c = str_in(i:i) !get next character in the input string
!if the string is not big enough, then add another chunk:
if (ipos+3>len(str_out)) str_out = str_out // repeat(space, chunk_size)
select case(c)
case(quotation_mark,backslash,slash)
str_out(ipos:ipos+1) = backslash//c
ipos = ipos + 2
case(bspace)
str_out(ipos:ipos+1) = '\b'
ipos = ipos + 2
case(formfeed)
str_out(ipos:ipos+1) = '\f'
ipos = ipos + 2
case(newline)
str_out(ipos:ipos+1) = '\n'
ipos = ipos + 2
case(carriage_return)
str_out(ipos:ipos+1) = '\r'
ipos = ipos + 2
case(horizontal_tab)
str_out(ipos:ipos+1) = '\t'
ipos = ipos + 2
case default
str_out(ipos:ipos) = c
ipos = ipos + 1
end select
end do
!trim the string if necessary:
if (ipos<len(str_out)+1) then
if (ipos==1) then
str_out = ''
else
str_out = str_out(1:ipos-1)
end if
end if
else
str_out = str_in
end if
end subroutine escape_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/19/2014
!
! Add an array of character strings to the structure.
!
!@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_string_vec(me, name, val, trim_str, adjustl_str)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name !! variable name
character(kind=CK,len=*),dimension(:),intent(in) :: val !! array of strings
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 :: var
integer(IK) :: i
logical(LK) :: trim_string, adjustl_string
character(kind=CK,len=:),allocatable :: str
!if the string is to be trimmed or not:
if (present(trim_str)) then
trim_string = trim_str
else
trim_string = .false.
end if
if (present(adjustl_str)) then
adjustl_string = adjustl_str
else
adjustl_string = .false.
end if
!create the variable as an array:
call json_value_create(var)
call to_array(var,name)
!populate the array:
do i=1,size(val)
!the string to write:
str = val(i)
if (adjustl_string) str = adjustl(str)
if (trim_string) str = trim(str)
!write it:
call json_add(var, '', str)
!cleanup
deallocate(str)
end do
!add it:
call json_add(me, var)
!cleanup:
nullify(var)
end subroutine json_value_add_string_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_string_vec]] where "name" and "val" are kind=CDK.
subroutine wrap_json_value_add_string_vec(me, name, val, trim_str, adjustl_str)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
character(kind=CDK,len=*),dimension(:),intent(in) :: val
logical(LK),intent(in),optional :: trim_str
logical(LK),intent(in),optional :: adjustl_str
call json_value_add_string_vec(me, to_unicode(name), to_unicode(val), trim_str, adjustl_str)
end subroutine wrap_json_value_add_string_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_string_vec]] where "name" is kind=CDK.
subroutine json_value_add_string_vec_name_ascii(me, name, val, trim_str, adjustl_str)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
character(kind=CK, len=*),dimension(:),intent(in) :: val
logical(LK),intent(in),optional :: trim_str
logical(LK),intent(in),optional :: adjustl_str
call json_value_add_string_vec(me, to_unicode(name), val, trim_str, adjustl_str)
end subroutine json_value_add_string_vec_name_ascii
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_add_string_vec]] where "val" is kind=CDK.
subroutine json_value_add_string_vec_val_ascii(me, name, val, trim_str, adjustl_str)
implicit none
type(json_value),pointer :: me
character(kind=CK, len=*),intent(in) :: name
character(kind=CDK,len=*),dimension(:),intent(in) :: val
logical(LK),intent(in),optional :: trim_str
logical(LK),intent(in),optional :: adjustl_str
call json_value_add_string_vec(me, name, to_unicode(val), trim_str, adjustl_str)
end subroutine json_value_add_string_vec_val_ascii
!*****************************************************************************************
!*****************************************************************************************
!>
! Count the number of children.
!
!# History
! * JW : 1/4/2014 : Original routine removed.
! Now using n_children variable.
! Renamed from json_value_count.
pure function json_count(me) result(count)
implicit none
integer(IK) :: count !! number of children
type(json_value),pointer,intent(in) :: me
count = me%n_children
end function json_count
!*****************************************************************************************
!*****************************************************************************************
!>
! Returns a child in the object or array given the index.
subroutine json_value_get_by_index(me, idx, p)
implicit none
type(json_value),pointer,intent(in) :: me !! object or array JSON data
integer(IK),intent(in) :: idx !! index of the child
type(json_value),pointer :: p !! pointer to the child
integer(IK) :: i
nullify(p)
if (.not. exception_thrown) then
if (associated(me%children)) then
p => me%children
do i = 1, idx - 1
if (associated(p%next)) then
p => p%next
else
call throw_exception('Error in json_value_get_by_index:'//&
' p%next is not associated.')
nullify(p)
return
end if
end do
else
call throw_exception('Error in json_value_get_by_index:'//&
' me%children is not associated.')
end if
end if
end subroutine json_value_get_by_index
!*****************************************************************************************
!*****************************************************************************************
!>
! Returns a child in the object or array given the name string.
!
! It is a case-sensitive search, and the name string is not trimmed.
! So, for example,
!```fortran
! 'a ' /= 'A ' /= 'a '
!```
!
!@note The "name" input is not a path, and is not parsed like it is in [[json_get_by_path]].
subroutine json_value_get_by_name_chars(me, name, p)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),intent(in) :: name !! the name of a child of "me"
type(json_value),pointer :: p !! pointer to the child
integer(IK) :: i,n_children
nullify(p)
if (.not. exception_thrown) then
if (associated(me)) then
if (me%var_type==json_object) then
n_children = json_count(me)
p => me%children !start with first one
do i=1, n_children
if (allocated(p%name)) then
if (p%name == name) return
end if
p => p%next
end do
end if
!did not find anything:
call throw_exception('Error in json_value_get_by_name_chars: '//&
'child variable '//trim(name)//' was not found.')
nullify(p)
else
call throw_exception('Error in json_value_get_by_name_chars: '//&
'pointer is not associated.')
end if
end if
end subroutine json_value_get_by_name_chars
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_value_get_by_name_chars]] where "name" is kind=CDK.
subroutine wrap_json_value_get_by_name_chars(me, name, p)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: name
type(json_value),pointer :: p
call json_value_get_by_name_chars(me,to_unicode(name),p)
end subroutine wrap_json_value_get_by_name_chars
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 2/12/2014
!
! Print the [[json_value]] structure to an allocatable string.
subroutine json_value_to_string(me,str)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=:),intent(out),allocatable :: str !! prints structure to this string
str = ''
call json_value_print(me, iunit=unit2str, str=str, indent=1, colon=.true.)
end subroutine json_value_to_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 6/20/2014
!
! Print the [[json_value]] structure to a file.
subroutine json_print_1(me,iunit)
implicit none
type(json_value),pointer,intent(in) :: me
integer(IK),intent(in) :: iunit !! the file unit (the file must already have been opened, can't be -1).
character(kind=CK,len=:),allocatable :: dummy
if (iunit/=unit2str) then
call json_value_print(me,iunit,str=dummy, indent=1, colon=.true.)
else
call throw_exception('Error in json_print: iunit must not be -1.')
end if
end subroutine json_print_1
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/23/2014
!
! Print the [[json_value]] structure to a file.
subroutine json_print_2(me,filename)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: filename !! the filename to print to (should not already be open)
integer(IK) :: iunit,istat
open(newunit=iunit,file=filename,status='REPLACE',iostat=istat FILE_ENCODING )
if (istat==0) then
call json_print(me,iunit)
close(iunit,iostat=istat)
else
call throw_exception('Error in json_print: could not open file: '//&
trim(filename))
end if
end subroutine json_print_2
!*****************************************************************************************
!*****************************************************************************************
!>
! Print the JSON structure to a string or a file.
!
!# Notes
! * This is an internal routine called by the wrapper routines
! [[json_print]] and [[json_value_to_string]].
! * The reason the str argument is non-optional is because of a
! bug in v4.9 of the gfortran compiler.
recursive subroutine json_value_print(me,iunit,str,indent,need_comma,colon,is_array_element)
implicit none
type(json_value),pointer,intent(in) :: me
integer(IK),intent(in) :: iunit !! file unit to write to (6=console)
integer(IK),intent(in),optional :: indent !! indention level
logical(LK),intent(in),optional :: is_array_element !! if this is an array element
logical(LK),intent(in),optional :: need_comma !! if it needs a comma after it
logical(LK),intent(in),optional :: colon !! if the colon was just written
character(kind=CK,len=:),intent(inout),allocatable :: str
!! if iunit==unit2str (-1) then the structure is
!! printed to this string rather than
!! a file. This mode is used by
!! [[json_value_to_string]].
character(kind=CK,len=max_numeric_str_len) :: tmp !for val to string conversions
character(kind=CK,len=:),allocatable :: s
type(json_value),pointer :: element
integer(IK) :: tab, i, count, spaces
logical(LK) :: print_comma
logical(LK) :: write_file, write_string
logical(LK) :: is_array
if (.not. exception_thrown) then
!whether to write a string or a file (one or the other):
write_string = (iunit==unit2str)
write_file = .not. write_string
!if the comma will be printed after the value
! [comma not printed for the last elements]
if (present(need_comma)) then
print_comma = need_comma
else
print_comma = .false.
end if
!number of "tabs" to indent:
if (present(indent)) then
tab = indent
else
tab = 0
end if
!convert to number of spaces:
spaces = tab*spaces_per_tab
!if this is an element in an array:
if (present(is_array_element)) then
is_array = is_array_element
else
is_array = .false.
end if
!if the colon was the last thing written
if (present(colon)) then
s = ''
else
s = repeat(space, spaces)
end if
select case (me%var_type)
case (json_object)
count = json_count(me)
if (count==0) then !special case for empty object
call write_it( s//start_object//end_object, comma=print_comma )
else
call write_it( s//start_object )
!if an object is in an array, there is an extra tab:
if (is_array) then
tab = tab+1
spaces = tab*spaces_per_tab
end if
nullify(element)
element => me%children
do i = 1, count
! print the name
if (allocated(element%name)) then
call write_it(repeat(space, spaces)//quotation_mark//&
element%name//quotation_mark//colon_char//space,&
advance=.false.)
else
call throw_exception('Error in json_value_print:'//&
' element%name not allocated')
nullify(element)
return
end if
! recursive print of the element
call json_value_print(element, iunit=iunit, indent=tab + 1, &
need_comma=i<count, colon=.true., str=str)
! get the next child the list:
element => element%next
end do
! [one fewer tab if it isn't an array element]
if (.not. is_array) s = repeat(space, max(0,spaces-spaces_per_tab))
call write_it( s//end_object, comma=print_comma )
nullify(element)
end if
case (json_array)
count = json_count(me)
if (count==0) then !special case for empty array
call write_it( s//start_array//end_array, comma=print_comma )
else
call write_it( start_array )
nullify(element)
element => me%children
do i = 1, count
! recursive print of the element
call json_value_print(element, iunit=iunit, indent=tab,&
need_comma=i<count, is_array_element=.true., str=str)
! get the next child the list:
element => element%next
end do
!indent the closing array character:
call write_it( repeat(space, max(0,spaces-spaces_per_tab))//end_array,&
comma=print_comma )
nullify(element)
end if
case (json_null)
call write_it( s//null_str, comma=print_comma )
case (json_string)
if (allocated(me%str_value)) then
call write_it( s//quotation_mark// &
trim(me%str_value)//quotation_mark, comma=print_comma )
else
call throw_exception('Error in json_value_print:'//&
' me%value_string not allocated')
return
end if
case (json_logical)
if (me%log_value) then
call write_it( s//true_str, comma=print_comma )
else
call write_it( s//false_str, comma=print_comma )
end if
case (json_integer)
call integer_to_string(me%int_value,tmp)
call write_it( s//trim(tmp), comma=print_comma )
case (json_double)
call real_to_string(me%dbl_value,tmp)
call write_it( s//trim(tmp), comma=print_comma )
case default
call throw_exception('Error in json_value_print: unknown data type')
end select
!cleanup:
if (allocated(s)) deallocate(s)
end if
contains
!
! write the string to the file (or the output string)
!
subroutine write_it(s,advance,comma)
implicit none
character(kind=CK,len=*),intent(in) :: s !string to print
logical(LK),intent(in),optional :: advance !to add line break or not
logical(LK),intent(in),optional :: comma !print comma after the string
logical(LK) :: add_line_break, add_comma
character(kind=CK,len=:),allocatable :: s2
if (present(comma)) then
add_comma = comma
else
add_comma = .false. !default is not to add comma
end if
if (present(advance)) then
add_line_break = advance
else
add_line_break = .true. !default is to advance
end if
!string to print:
s2 = s
if (add_comma) s2 = s2 // delimiter
if (write_file) then
if (add_line_break) then
write(iunit,fmt='(A)') s2
else
write(iunit,fmt='(A)',advance='NO') s2
end if
else !write string
str = str // s2
if (add_line_break) str = str // newline
end if
!cleanup:
if (allocated(s2)) deallocate(s2)
end subroutine write_it
end subroutine json_value_print
!*****************************************************************************************
!*****************************************************************************************
!>
! Returns the [[json_value]] pointer given the path string.
!
!# Example
!
!```fortran
! type(json_value),pointer :: dat,p
! logical :: found
! !...
! call json_get(dat,'data(2).version',p,found)
!```
!
!# Notes
! The following special characters are used to denote paths:
!
!```
! $ - root
! @ - this
! . - child object member
! [] or () - child array element
!```
!
! Thus, if any of these characters are present in the name key,
! this routine cannot be used to get the value.
! In that case, the [[json_get_child]] routines would need to be used.
subroutine json_get_by_path(me, path, p, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),intent(in) :: path
type(json_value),pointer,intent(out) :: p
logical(LK),intent(out),optional :: found !! true if it was found
character(kind=CK,len=1),parameter :: start_array_alt = '('
character(kind=CK,len=1),parameter :: end_array_alt = ')'
integer(IK) :: i,length,child_i
character(kind=CK,len=1) :: c
logical(LK) :: array
type(json_value),pointer :: tmp
if (.not. exception_thrown) then
nullify(p)
! default to assuming relative to this
p => me
child_i = 1
array = .false.
length = len_trim(path)
do i=1, length
c = path(i:i)
select case (c)
case (CK_'$')
! root
do while (associated (p%parent))
p => p%parent
end do
child_i = i + 1
case (CK_'@')
! this
p => me
child_i = i + 1
case (CK_'.')
! get child member from p
if (child_i < i) then
nullify(tmp)
call json_get_child(p, path(child_i:i-1), tmp)
p => tmp
nullify(tmp)
else
child_i = i + 1
cycle
end if
if (.not. associated(p)) then
call throw_exception('Error in json_get_by_path:'//&
' Error getting child member.')
exit
end if
child_i = i+1
case (start_array,start_array_alt)
!....Modified to allow for 'var[3]' style syntax
!Note: jmozmoz/fson has a slightly different version of this...
! start looking for the array element index
array = .true.
! get child member from p
if (child_i < i) then
nullify(tmp)
call json_get_child(p, path(child_i:i-1), tmp)
p => tmp
nullify(tmp)
else
child_i = i + 1
cycle
end if
if (.not. associated(p)) then
call throw_exception('Error in json_get_by_path:'//&
' Error getting array element')
exit
end if
child_i = i + 1
case (end_array,end_array_alt)
if (.not.array) then
call throw_exception('Error in json_get_by_path: Unexpected ]')
exit
end if
array = .false.
child_i = string_to_integer(path(child_i:i-1))
nullify(tmp)
call json_get_child(p, child_i, tmp)
p => tmp
nullify(tmp)
child_i= i + 1
end select
end do
if (exception_thrown) then
if (present(found)) then
found = .false.
call json_clear_exceptions()
end if
else
! grab the last child if present in the path
if (child_i <= length) then
nullify(tmp)
call json_get_child(p, path(child_i:i-1), tmp)
p => tmp
nullify(tmp)
end if
if (associated(p)) then
if (present(found)) found = .true. !everything seems to be ok
else
call throw_exception('Error in json_get_by_path:'//&
' variable not found: '//trim(path))
if (present(found)) then
found = .false.
call json_clear_exceptions()
end if
end if
end if
else
if (present(found)) found = .false.
end if
end subroutine json_get_by_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_by_path]] where "path" is kind=CDK.
subroutine wrap_json_get_by_path(me, path, p, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: path
type(json_value),pointer,intent(out) :: p
logical(LK),intent(out),optional :: found
call json_get_by_path(me, to_unicode(path), p, found)
end subroutine wrap_json_get_by_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Convert a string into an integer.
!
!# History
! * Jacob Williams : 12/10/2013 : Rewrote routine. Added error checking.
! * Modified by Izaak Beekman
!
!@note Replacement for the parse_integer function in the original code.
function string_to_integer(str) result(ival)
implicit none
character(kind=CK,len=*),intent(in) :: str
integer(IK) :: ival
character(kind=CDK,len=:),allocatable :: digits
integer(IK) :: ndigits_digits,ndigits,ierr
if (.not. exception_thrown) then
! Compute how many digits we need to read
ndigits = 2*len_trim(str)
ndigits_digits = floor(log10(real(ndigits)))+1
allocate(character(kind=CDK,len=ndigits_digits) :: digits)
write(digits,'(I0)') ndigits !gfortran will have a runtime error with * edit descriptor here
! gfortran bug: '*' edit descriptor for ISO_10646 strings does bad stuff.
read(str,'(I'//trim(digits)//')',iostat=ierr) ival !string to integer
if (ierr/=0) then !if there was an error
ival = 0
call throw_exception('Error in string_to_integer:'//&
' string cannot be converted to an integer: '//trim(str))
end if
else
ival = 0
end if
end function string_to_integer
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/19/2014
!
! Convert a string into a double.
function string_to_double(str) result(rval)
implicit none
real(RK) :: rval
character(kind=CK,len=*),intent(in) :: str
integer(IK) :: ierr
if (.not. exception_thrown) then
read(str,fmt=real_fmt,iostat=ierr) rval !string to double
if (ierr/=0) then !if there was an error
rval = 0.0_RK
call throw_exception('Error in string_to_double:'//&
' string cannot be converted to a double: '//trim(str))
end if
end if
end function string_to_double
!*****************************************************************************************
!*****************************************************************************************
!>
! Get an integer value from a [[json_value]].
subroutine json_get_integer(me, value)
implicit none
type(json_value),pointer,intent(in) :: me
integer(IK),intent(out) :: value
value = 0
if ( exception_thrown ) return
select case(me%var_type)
case (json_integer)
value = me%int_value
case (json_double)
value = int(me%dbl_value)
case (json_logical)
if (me%log_value) then
value = 1
else
value = 0
end if
case default
call throw_exception('Error in get_integer:'//&
' Unable to resolve value to integer: '//me%name)
end select
end subroutine json_get_integer
!*****************************************************************************************
!*****************************************************************************************
!>
! Get an integer value from a [[json_value]], given the path string.
subroutine json_get_integer_with_path(me, path, value, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),intent(in) :: path
integer(IK),intent(out) :: value
logical(LK),intent(out),optional :: found
type(json_value),pointer :: p
value = 0
if ( exception_thrown ) then
if ( present(found) ) found = .false.
return
end if
nullify(p)
call json_get_by_path(me=me, path=path, p=p)
if (.not. associated(p)) then
call throw_exception('Error in json_get_integer:'//&
' Unable to resolve path: '// trim(path))
else
call json_get_integer(p,value)
nullify(p)
end if
if ( exception_thrown ) then
if ( present(found) ) then
found = .false.
call json_clear_exceptions()
end if
else
if ( present(found) ) found = .true.
end if
end subroutine json_get_integer_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_integer_with_path]], where "path" is kind=CDK.
subroutine wrap_json_get_integer_with_path(me, path, value, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: path
integer(IK),intent(out) :: value
logical(LK),intent(out),optional :: found
call json_get_integer_with_path(me, to_unicode(path), value, found)
end subroutine wrap_json_get_integer_with_path
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 5/14/2014
!
! Get an integer vector from a [[json_value]].
subroutine json_get_integer_vec(me, vec)
implicit none
type(json_value),pointer :: me
integer(IK),dimension(:),allocatable,intent(out) :: vec
logical(LK) :: initialized
initialized = .false.
if (allocated(vec)) deallocate(vec)
!the callback function is called for each element of the array:
call json_get(me, array_callback=get_int_from_array)
contains
! callback function for integer
subroutine get_int_from_array(element, i, count)
implicit none
type(json_value),pointer,intent(in) :: element
integer(IK),intent(in) :: i !index
integer(IK),intent(in) :: count !size of array
!size the output array:
if (.not. initialized) then
allocate(vec(count))
initialized = .true.
end if
!populate the elements:
call json_get(element, value=vec(i))
end subroutine get_int_from_array
end subroutine json_get_integer_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Get an integer vector from a [[json_value]], given the path string.
subroutine json_get_integer_vec_with_path(me, path, vec, found)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: path
integer(IK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
logical(LK) :: initialized
initialized = .false.
call json_get(me, path=path, array_callback=get_int_from_array, found=found)
! need to duplicate callback function, no other way
contains
! callback function for integer
subroutine get_int_from_array(element, i, count)
implicit none
type(json_value),pointer,intent(in) :: element
integer(IK),intent(in) :: i !index
integer(IK),intent(in) :: count !size of array
!size the output array:
if (.not. initialized) then
allocate(vec(count))
initialized = .true.
end if
!populate the elements:
call json_get(element, value=vec(i))
end subroutine get_int_from_array
end subroutine json_get_integer_vec_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_integer_vec_with_path]], where "path" is kind=CDK
subroutine wrap_json_get_integer_vec_with_path(me, path, vec, found)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: path
integer(IK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_get_integer_vec_with_path(me,path=to_unicode(path),vec=vec,found=found)
end subroutine wrap_json_get_integer_vec_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a double value from a [[json_value]].
subroutine json_get_double(me, value)
implicit none
type(json_value),pointer :: me
real(RK),intent(out) :: value
value = 0.0_RK
if ( exception_thrown ) return
select case (me%var_type)
case (json_integer)
value = me%int_value
case (json_double)
value = me%dbl_value
case (json_logical)
if (me%log_value) then
value = 1.0_RK
else
value = 0.0_RK
end if
case default
call throw_exception('Error in json_get_double:'//&
' Unable to resolve value to double: '//me%name)
end select
end subroutine json_get_double
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a double value from a [[json_value]], given the path.
subroutine json_get_double_with_path(me, path, value, found)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: path
real(RK),intent(out) :: value
logical(LK),intent(out),optional :: found
type(json_value),pointer :: p
value = 0.0_RK
if ( exception_thrown ) then
if ( present(found) ) found = .false.
return
end if
nullify(p)
call json_get_by_path(me=me, path=path, p=p)
if (.not. associated(p)) then
call throw_exception('Error in json_get_double:'//&
' Unable to resolve path: '//trim(path))
else
call json_get_double(p,value)
nullify(p)
end if
if (exception_thrown) then
if (present(found)) then
found = .false.
call json_clear_exceptions()
end if
else
if (present(found)) found = .true.
end if
end subroutine json_get_double_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_double_with_path]], where "path" is kind=CDK
subroutine wrap_json_get_double_with_path(me, path, value, found)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: path
real(RK),intent(out) :: value
logical(LK),intent(out),optional :: found
call json_get_double_with_path(me,to_unicode(path),value,found)
end subroutine wrap_json_get_double_with_path
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 5/14/2014
!
! Get a double vector from a [[json_value]].
subroutine json_get_double_vec(me, vec)
implicit none
type(json_value),pointer :: me
real(RK),dimension(:),allocatable,intent(out) :: vec
logical(LK) :: initialized
initialized = .false.
if (allocated(vec)) deallocate(vec)
!the callback function is called for each element of the array:
call json_get(me, array_callback=get_double_from_array)
contains
! callback function for double
subroutine get_double_from_array(element, i, count)
implicit none
type(json_value),pointer,intent(in) :: element
integer(IK),intent(in) :: i !index
integer(IK),intent(in) :: count !size of array
!size the output array:
if (.not. initialized) then
allocate(vec(count))
initialized = .true.
end if
!populate the elements:
call json_get(element, value=vec(i))
end subroutine get_double_from_array
end subroutine json_get_double_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a double vector from a [[json_value]], given the path.
subroutine json_get_double_vec_with_path(me, path, vec, found)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: path
real(RK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
logical(LK) :: initialized
initialized = .false.
if (allocated(vec)) deallocate(vec)
!the callback function is called for each element of the array:
call json_get(me, path=path, array_callback=get_double_from_array, found=found)
contains
! callback function for double
subroutine get_double_from_array(element, i, count)
implicit none
type(json_value),pointer,intent(in) :: element
integer(IK),intent(in) :: i !index
integer(IK),intent(in) :: count !size of array
!size the output array:
if (.not. initialized) then
allocate(vec(count))
initialized = .true.
end if
!populate the elements:
call json_get(element, value=vec(i))
end subroutine get_double_from_array
end subroutine json_get_double_vec_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_double_vec_with_path]], where "path" is kind=CDK
subroutine wrap_json_get_double_vec_with_path(me, path, vec, found)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: path
real(RK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_get_double_vec_with_path(me, to_unicode(path), vec, found)
end subroutine wrap_json_get_double_vec_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a logical value from a [[json_value]].
subroutine json_get_logical(me, value)
implicit none
type(json_value),pointer,intent(in) :: me
logical(LK) :: value
value = .false.
if ( exception_thrown ) return
select case (me%var_type)
case (json_integer)
value = (me%int_value > 0)
case (json_logical)
value = me % log_value
case default
call throw_exception('Error in json_get_logical:'//&
' Unable to resolve value to logical: '//me%name)
end select
end subroutine json_get_logical
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a logical value from a [[json_value]], given the path.
subroutine json_get_logical_with_path(me, path, value, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),intent(in) :: path
logical(LK) :: value
logical(LK),intent(out),optional :: found
type(json_value),pointer :: p
value = .false.
if ( exception_thrown) then
if ( present(found) ) found = .false.
return
end if
nullify(p)
call json_get_by_path(me=me, path=path, p=p)
if (.not. associated(p)) then
call throw_exception('Error in json_get_logical:'//&
' Unable to resolve path: '//trim(path))
else
call json_get_logical(p,value)
nullify(p)
end if
if (exception_thrown) then
if (present(found)) then
found = .false.
call json_clear_exceptions()
end if
else
if (present(found)) found = .true.
end if
end subroutine json_get_logical_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_logical_with_path]], where "path" is kind=CDK
subroutine wrap_json_get_logical_with_path(me, path, value, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: path
logical(LK) :: value
logical(LK),intent(out),optional :: found
call json_get_logical_with_path(me,to_unicode(path),value,found)
end subroutine wrap_json_get_logical_with_path
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 5/14/2014
!
! Get a logical vector from [[json_value]].
subroutine json_get_logical_vec(me, vec)
implicit none
type(json_value),pointer,intent(in) :: me
logical(LK),dimension(:),allocatable,intent(out) :: vec
logical(LK) :: initialized
initialized = .false.
if (allocated(vec)) deallocate(vec)
!the callback function is called for each element of the array:
call json_get(me, array_callback=get_logical_from_array)
contains
! callback function for logical
subroutine get_logical_from_array(element, i, count)
implicit none
type(json_value),pointer,intent(in) :: element
integer(IK),intent(in) :: i !index
integer(IK),intent(in) :: count !size of array
!size the output array:
if (.not. initialized) then
allocate(vec(count))
initialized = .true.
end if
!populate the elements:
call json_get(element, value=vec(i))
end subroutine get_logical_from_array
end subroutine json_get_logical_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a logical vector from a [[json_value]], given the path.
subroutine json_get_logical_vec_with_path(me, path, vec, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),intent(in) :: path
logical(LK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
logical(LK) :: initialized
initialized = .false.
if (allocated(vec)) deallocate(vec)
!the callback function is called for each element of the array:
call json_get(me, path=path, array_callback=get_logical_from_array, found=found)
contains
! callback function for logical
subroutine get_logical_from_array(element, i, count)
implicit none
type(json_value),pointer,intent(in) :: element
integer(IK),intent(in) :: i !index
integer(IK),intent(in) :: count !size of array
!size the output array:
if (.not. initialized) then
allocate(vec(count))
initialized = .true.
end if
!populate the elements:
call json_get(element, value=vec(i))
end subroutine get_logical_from_array
end subroutine json_get_logical_vec_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_logical_vec_with_path]], where "path" is kind=CDK
subroutine wrap_json_get_logical_vec_with_path(me, path, vec, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: path
logical(LK),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_get_logical_vec_with_path(me,to_unicode(path),vec,found)
end subroutine wrap_json_get_logical_vec_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a character string from a [[json_value]].
subroutine json_get_string(me, value)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=:),allocatable,intent(out) :: value
character(kind=CK ,len=:),allocatable :: s,pre,post
integer(IK) :: j,jprev,n
character(kind=CK,len=1) :: c
value = ''
if ( exception_thrown) return
select case (me%var_type)
case (json_string)
if (allocated(me%str_value)) then
!get the value as is:
s = me%str_value
! Now, have to remove the escape characters:
!
! '\"' quotation mark
! '\\' reverse solidus
! '\/' solidus
! '\b' backspace
! '\f' formfeed
! '\n' newline (LF)
! '\r' carriage return (CR)
! '\t' horizontal tab
! '\uXXXX' 4 hexadecimal digits
!
!initialize:
n = len(s)
j = 1
do
jprev = j !initialize
j = index(s(j:n),backslash) !look for an escape character
if (j>0) then !an escape character was found
!index in full string of the escape character:
j = j + (jprev-1)
if (j<n) then
!save the bit before the escape character:
if (j>1) then
pre = s( 1 : j-1 )
else
pre = ''
end if
!character after the escape character:
c = s( j+1 : j+1 )
if (any(c == [quotation_mark,backslash,slash, &
to_unicode(['b','f','n','r','t'])])) then
!save the bit after the escape characters:
if (j+2<n) then
post = s(j+2:n)
else
post = ''
end if
select case(c)
case (quotation_mark,backslash,slash)
!use c as is
case (CK_'b')
c = bspace
case (CK_'f')
c = formfeed
case (CK_'n')
c = newline
case (CK_'r')
c = carriage_return
case (CK_'t')
c = horizontal_tab
end select
s = pre//c//post
n = n-1 !backslash character has been
! removed from the string
else if (c == 'u') then !expecting 4 hexadecimal digits after
!the escape character [\uXXXX]
!for now, we are just printing them as is
![not checking to see if it is a valid hex value]
if (j+5<=n) then
j=j+4
else
call throw_exception('Error in json_get_string:'//&
' Invalid hexadecimal sequence'//&
' in string: '//trim(c))
exit
end if
else
!unknown escape character
call throw_exception('Error in json_get_string:'//&
' unknown escape sequence in string "'//&
trim(s)//'" ['//backslash//c//']')
exit
end if
j=j+1 !go to the next character
if (j>=n) exit !finished
else
!an escape character is the last character in
! the string [this may not be valid syntax,
! but just keep it]
exit
end if
else
exit !no more escape characters in the string
end if
end do
if (exception_thrown) then
if (allocated(value)) deallocate(value)
else
value = s
end if
else
call throw_exception('Error in json_get_string:'//&
' me%value not allocated')
end if
case default
call throw_exception('Error in json_get_string:'//&
' Unable to resolve value to characters: '//me%name)
! Note: for the other cases, we could do val to string conversions.
end select
!cleanup:
if (allocated(s)) deallocate(s)
if (allocated(pre)) deallocate(pre)
if (allocated(post)) deallocate(post)
end subroutine json_get_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a character string from a [[json_value]], given the path.
subroutine json_get_string_with_path(me, path, value, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),intent(in) :: path
character(kind=CK,len=:),allocatable,intent(out) :: value
logical(LK),intent(out),optional :: found
type(json_value),pointer :: p
value = ''
if ( exception_thrown ) then
if ( present(found) ) found = .false.
return
end if
nullify(p)
call json_get_by_path(me=me, path=path, p=p)
if (.not. associated(p)) then
call throw_exception('Error in json_get_string:'//&
' Unable to resolve path: '//trim(path))
else
call json_get_string(p,value)
nullify(p)
end if
if (allocated(value) .and. .not. exception_thrown) then
if (present(found)) found = .true.
else
if (present(found)) then
found = .false.
call json_clear_exceptions()
end if
end if
!cleanup:
if (associated(p)) nullify(p)
end subroutine json_get_string_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_string_with_path]], where "path" is kind=CDK
subroutine wrap_json_get_string_with_path(me, path, value, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: path
character(kind=CK,len=:),allocatable,intent(out) :: value
logical(LK),intent(out),optional :: found
call json_get_string_with_path(me,to_unicode(path),value,found)
end subroutine wrap_json_get_string_with_path
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 5/14/2014
!
! Get a string vector from a [[json_file(type)]].
subroutine json_get_string_vec(me, vec)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
logical(LK) :: initialized
initialized = .false.
if (allocated(vec)) deallocate(vec)
!the callback function is called for each element of the array:
call json_get(me, array_callback=get_chars_from_array)
contains
! callback function for chars
subroutine get_chars_from_array(element, i, count)
implicit none
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
!size the output array:
if (.not. initialized) then
allocate(vec(count))
initialized = .true.
end if
!populate the elements:
call json_get(element, value=cval)
if (allocated(cval)) then
vec(i) = cval
deallocate(cval)
else
vec(i) = ''
end if
end subroutine get_chars_from_array
end subroutine json_get_string_vec
!*****************************************************************************************
!*****************************************************************************************
!>
! Get a string vector from a [[json_file(type)]], given the path.
subroutine json_get_string_vec_with_path(me, path, vec, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),intent(in) :: path
character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
logical(LK) :: initialized
initialized = .false.
if (allocated(vec)) deallocate(vec)
!the callback function is called for each element of the array:
call json_get(me, path=path, array_callback=get_chars_from_array, found=found)
contains
! callback function for chars
subroutine get_chars_from_array(element, i, count)
implicit none
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
!size the output array:
if (.not. initialized) then
allocate(vec(count))
initialized = .true.
end if
!populate the elements:
call json_get(element, value=cval)
if (allocated(cval)) then
vec(i) = cval
deallocate(cval)
else
vec(i) = ''
end if
end subroutine get_chars_from_array
end subroutine json_get_string_vec_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_string_vec_with_path]], where "path" is kind=CDK
subroutine wrap_json_get_string_vec_with_path(me, path, vec, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: path
character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
logical(LK),intent(out),optional :: found
call json_get_string_vec_with_path(me,to_unicode(path),vec,found)
end subroutine wrap_json_get_string_vec_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! This routine calls the user-supplied [[array_callback_func]] subroutine
! for each element in the array.
!
!@note For integer, double, logical, and character arrays,
! higher-level routines are provided (see [[json_get]]), so
! this routine does not have to be used for those cases.
subroutine json_get_array(me, array_callback)
implicit none
type(json_value),pointer,intent(in) :: me
procedure(array_callback_func) :: array_callback
type(json_value),pointer :: element
integer(IK) :: i, count
if ( exception_thrown ) return
nullify(element)
select case (me%var_type)
case (json_array)
count = json_count(me)
element => me%children
do i = 1, count ! callback for each child
call array_callback(element, i, count)
element => element%next
end do
case default
call throw_exception('Error in json_get_array:'//&
' Resolved value is not an array ')
end select
!cleanup:
if (associated(element)) nullify(element)
end subroutine json_get_array
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 09/02/2015
!
! Traverse a JSON structure.
! This routine calls the user-specified [[traverse_callback_func]]
! for each element of the structure.
!
recursive subroutine json_traverse(me,traverse_callback)
implicit none
type(json_value),pointer,intent(in) :: me
procedure(traverse_callback_func) :: traverse_callback
type(json_value),pointer :: element !! a child element
integer(IK) :: i !! counter
integer(IK) :: icount !! number of children
logical(LK) :: finished !! can be used to stop the process
if (exception_thrown) return
call traverse_callback(me,finished) ! first call for this object
if (finished) return
!for arrays and objects, have to also call for all children:
if (me%var_type==json_array .or. me%var_type==json_object) then
icount = json_count(me) ! number of children
if (icount>0) then
element => me%children ! first one
do i = 1, icount ! call for each child
call json_traverse(element,traverse_callback)
if (finished) exit
element => element%next
end do
end if
nullify(element)
end if
end subroutine json_traverse
!*****************************************************************************************
!*****************************************************************************************
!>
! This routine calls the user-supplied array_callback subroutine
! for each element in the array (specified by the path).
subroutine json_get_array_with_path(me, path, array_callback, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CK,len=*),intent(in) :: path
procedure(array_callback_func) :: array_callback
logical(LK),intent(out),optional :: found
type(json_value),pointer :: p
if ( exception_thrown ) then
if ( present(found) ) found = .false.
return
end if
nullify(p)
! resolve the path to the value
call json_get_by_path(me=me, path=path, p=p)
if (.not. associated(p)) then
call throw_exception('Error in json_get_array:'//&
' Unable to resolve path: '//trim(path))
else
call json_get_array(me=p,array_callback=array_callback)
nullify(p)
end if
if ( exception_thrown ) then
if ( present(found) ) then
found = .false.
call json_clear_exceptions()
end if
else
if ( present(found) ) found = .true.
end if
end subroutine json_get_array_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_get_array_with_path]], where "path" is kind=CDK
subroutine wrap_json_get_array_with_path(me, path, array_callback, found)
implicit none
type(json_value),pointer,intent(in) :: me
character(kind=CDK,len=*),intent(in) :: path
procedure(array_callback_func) :: array_callback
logical(LK),intent(out),optional :: found
call json_get_array_with_path(me, to_unicode(path), array_callback, found)
end subroutine wrap_json_get_array_with_path
!*****************************************************************************************
!*****************************************************************************************
!>
! Parse the JSON file and populate the [[json_value]] tree.
!
!# Inputs
!
! The inputs can be:
!
! * file and unit : the specified unit is used to read JSON from file.
! [note if unit is already open, then the filename is ignored]
! * file : JSON is read from file using internal unit number
!
!# Example
!
!```fortran
! type(json_value),pointer :: p
! call json_parse(file='myfile.json', p=p)
!```
!
!# History
! * Jacob Williams : 01/13/2015 : added read from string option.
! * Izaak Beekman : 03/08/2015 : moved read from string to separate
! subroutine, and error annotation
! to separate subroutine.
!
!@note When calling this routine, any exceptions thrown from previous
! calls will automatically be cleared.
subroutine json_parse_file(file, p, unit)
implicit none
character(kind=CDK,len=*),intent(in) :: file !! JSON file name
type(json_value),pointer :: p !! output structure
integer(IK),intent(in),optional :: unit !! file unit number (/= 0)
integer(IK) :: iunit, istat
logical(LK) :: is_open
!clear any exceptions and initialize:
call json_initialize()
if ( present(unit) ) then
if (unit==0) then
call throw_exception('Error in json_parse_file: unit number must not be 0.')
return
end if
iunit = unit
!check to see if the file is already open
! if it is, then use it, otherwise open the file with the name given.
inquire(unit=iunit, opened=is_open, iostat=istat)
if (istat==0 .and. .not. is_open) then
! open the file
open ( unit = iunit, &
file = file, &
status = 'OLD', &
action = 'READ', &
form = form_spec, &
access = access_spec, &
iostat = istat &
FILE_ENCODING )
else
!if the file is already open, then we need to make sure
! that it is open with the correct form/access/etc...
end if
else
! open the file with a new unit number:
open ( newunit = iunit, &
file = file, &
status = 'OLD', &
action = 'READ', &
form = form_spec, &
access = access_spec, &
iostat = istat &
FILE_ENCODING )
end if
if (istat==0) then
! create the value and associate the pointer
call json_value_create(p)
! Note: the name of the root json_value doesn't really matter,
! but we'll allocate something here just in case.
p%name = trim(file) !use the file name
! parse as a value
call parse_value(unit=iunit, str=CK_'', value=p)
if (exception_thrown) call annotate_invalid_json(iunit,CK_'')
! close the file if necessary
close(unit=iunit, iostat=istat)
else
call throw_exception('Error in json_parse_file: Error opening file: '//trim(file))
nullify(p)
end if
end subroutine json_parse_file
!*****************************************************************************************
!*****************************************************************************************
!>
! Parse the JSON string and populate the [[json_value]] tree.
!
!# See also
! * [[json_parse_file]]
subroutine json_parse_string(p, str)
implicit none
type(json_value),pointer :: p !! output structure
character(kind=CK,len=*),intent(in) :: str !! string with JSON data
integer(IK),parameter :: iunit = 0 !indicates that json data will be read from buffer
if ( .not. exception_thrown ) then
!clear any exceptions and initialize:
call json_initialize()
! create the value and associate the pointer
call json_value_create(p)
! Note: the name of the root json_value doesn't really matter,
! but we'll allocate something here just in case.
p%name = ''
! parse as a value
call parse_value(unit=iunit, str=str, value=p)
if (exception_thrown) call annotate_invalid_json(iunit,str)
end if
end subroutine json_parse_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Alternate version of [[json_parse_string]], where "str" is kind=CDK.
subroutine wrap_json_parse_string(p, str)
implicit none
type(json_value),pointer :: p !! output structure
character(kind=CDK,len=*),intent(in) :: str !! string with JSON data
call json_parse_string(p,to_unicode(str))
end subroutine wrap_json_parse_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Generate a warning message if there was an error parsing a JSON
! file or string.
subroutine annotate_invalid_json(iunit,str)
implicit none
integer(IK),intent(in) :: iunit !! file unit number
character(kind=CK,len=*),intent(in) :: str !! string with JSON data
character(kind=CK,len=:),allocatable :: line, arrow_str
character(kind=CK,len=10) :: line_str, char_str
integer(IK) :: i, i_nl_prev, i_nl
!
! If there was an error reading the file, then
! print the line where the error occurred:
!
if (exception_thrown) then
!the counters for the current line and the last character read:
call integer_to_string(line_count, line_str)
call integer_to_string(char_count, char_str)
!draw the arrow string that points to the current character:
arrow_str = repeat('-',max( 0, char_count - 1) )//'^'
if (line_count>0 .and. char_count>0) then
if (iunit/=0) then
if (use_unformatted_stream) then
call get_current_line_from_file_stream(iunit,line)
else
call get_current_line_from_file_sequential(iunit,line)
end if
else
!get the current line from the string:
! [this is done by counting the newline characters]
i_nl_prev = 0 !index of previous newline character
i_nl = 2 !just in case line_count = 0
do i=1,line_count
i_nl = index(str(i_nl_prev+1:),newline)
if (i_nl==0) then !last line - no newline character
i_nl = len(str)+1
exit
end if
i_nl = i_nl + i_nl_prev !index of current newline character
i_nl_prev = i_nl !update for next iteration
end do
line = str(i_nl_prev+1 : i_nl-1) !extract current line
end if
else
!in this case, it was an empty line or file
line = ''
end if
!create the error message:
err_message = err_message//newline//&
'line: '//trim(adjustl(line_str))//', '//&
'character: '//trim(adjustl(char_str))//newline//&
trim(line)//newline//arrow_str
if (allocated(line)) deallocate(line)
end if
end subroutine annotate_invalid_json
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Rewind the file to the beginning of the current line, and return this line.
! The file is assumed to be opened.
! This is the SEQUENTIAL version (see also [[get_current_line_from_file_stream]]).
subroutine get_current_line_from_file_sequential(iunit,line)
implicit none
integer(IK),intent(in) :: iunit !! file unit number
character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
integer(IK),parameter :: n_chunk = 256 ! chunk size [arbitrary]
character(kind=CDK,len=*),parameter :: nfmt = '(A256)' ! corresponding format statement
character(kind=CK,len=n_chunk) :: chunk
integer(IK) :: istat,isize
!initialize:
line = ''
!rewind to beginning of the current record:
backspace(iunit, iostat=istat)
!loop to read in all the characters in the current record.
![the line is read in chunks until the end of the line is reached]
if (istat==0) then
do
isize=0
read(iunit,fmt=nfmt,advance='NO',size=isize,iostat=istat) chunk
if (istat==0) then
line = line//chunk
else
if (isize>0 .and. isize<=n_chunk) line = line//chunk(1:isize)
exit
end if
end do
end if
end subroutine get_current_line_from_file_sequential
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Rewind the file to the beginning of the current line, and return this line.
! The file is assumed to be opened.
! This is the STREAM version (see also [[get_current_line_from_file_sequential]]).
subroutine get_current_line_from_file_stream(iunit,line)
implicit none
integer(IK),intent(in) :: iunit !! file unit number
character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
integer(IK) :: istart,iend,ios
character(kind=CK,len=1) :: c
!updated for the new STREAM version:
istart = ipos
do
if (istart<=1) then
istart = 1
exit
end if
read(iunit,pos=istart,iostat=ios) c
if (c==newline .or. ios/=0) then
if (istart/=1) istart = istart - 1
exit
end if
istart = istart-1 !rewind until the beginning of the line
end do
iend = ipos
do
read(iunit,pos=iend,iostat=ios) c
if (c==newline .or. ios/=0) exit
iend=iend+1
end do
allocate( character(kind=CK,len=iend-istart+1) :: line )
read(iunit,pos=istart,iostat=ios) line
end subroutine get_current_line_from_file_stream
!*****************************************************************************************
!*****************************************************************************************
!>
! Core parsing routine.
recursive subroutine parse_value(unit, str, value)
implicit none
integer(IK),intent(in) :: unit !! file unit number
character(kind=CK,len=*),intent(in) :: str !! string containing JSON data (only used if unit=0)
type(json_value),pointer :: value !! JSON data that is extracted
logical(LK) :: eof
character(kind=CK,len=1) :: c
character(kind=CK,len=:),allocatable :: tmp !this is a work-around for a bug
! in the gfortran 4.9 compiler.
if (.not. exception_thrown) then
!the routine is being called incorrectly.
if (.not. associated(value)) then
call throw_exception('Error in parse_value: value pointer not associated.')
end if
! pop the next non whitespace character off the file
c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
if (eof) then
return
else
select case (c)
case (start_object)
! start object
call to_object(value) !allocate class
call parse_object(unit, str, value)
case (start_array)
! start array
call to_array(value) !allocate class
call parse_array(unit, str, value)
case (end_array)
! end an empty array
call push_char(c)
nullify(value)
case (quotation_mark)
! string
call to_string(value) !allocate class
select case (value%var_type)
case (json_string)
call parse_string(unit, str, tmp) !write to a tmp variable because of
value%str_value = tmp ! a bug in 4.9 gfortran compiler.
deallocate(tmp) !
end select
case (CK_'t') !true_str(1:1) gfortran bug work around
!true
call parse_for_chars(unit, str, true_str(2:))
!allocate class and set value:
if (.not. exception_thrown) call to_logical(value,.true.)
case (CK_'f') !false_str(1:1) gfortran bug work around
!false
call parse_for_chars(unit, str, false_str(2:))
!allocate class and set value:
if (.not. exception_thrown) call to_logical(value,.false.)
case (CK_'n') !null_str(1:1) gfortran bug work around
!null
call parse_for_chars(unit, str, null_str(2:))
if (.not. exception_thrown) call to_null(value) !allocate class
case(CK_'-', CK_'0': CK_'9')
call push_char(c)
call parse_number(unit, str, value)
case default
call throw_exception('Error in parse_value:'//&
' Unexpected character while parsing value. "'//&
c//'"')
end select
end if
end if
end subroutine parse_value
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Allocate a [[json_value]] pointer and make it a logical(LK) variable.
! The pointer should not already be allocated.
!
!# Example
!```fortran
! type(json_value),pointer :: p
! call json_create(p,'value',.true.)
!```
subroutine json_value_create_logical(me,val,name)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name !! variable name
logical(LK),intent(in) :: val !! variable value
call json_value_create(me)
call to_logical(me,val,name)
end subroutine json_value_create_logical
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! Wrapper for [[json_value_create_logical]] so [[json_create_logical]] can
! be called with name of character kind 'DEFAULT' or 'ISO_10646'
subroutine wrap_json_value_create_logical(me,val,name)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
logical(LK),intent(in) :: val
call json_value_create_logical(me,val,to_unicode(name))
end subroutine wrap_json_value_create_logical
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Allocate a [[json_value]] pointer and make it an integer(IK) variable.
! The pointer should not already be allocated.
!
!# Example
!```fortran
! type(json_value),pointer :: p
! call json_create(p,'value',1)
!```
subroutine json_value_create_integer(me,val,name)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name
integer(IK),intent(in) :: val
call json_value_create(me)
call to_integer(me,val,name)
end subroutine json_value_create_integer
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! A wrapper procedure for [[json_value_create_integer]] so that [[json_create_integer]]
! may be called with either a 'DEFAULT' or 'ISO_10646' character kind 'name'
! actual argument.
subroutine wrap_json_value_create_integer(me,val,name)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
integer(IK),intent(in) :: val
call json_value_create_integer(me,val,to_unicode(name))
end subroutine wrap_json_value_create_integer
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Allocate a [[json_value]] pointer and make it a real(RK) variable.
! The pointer should not already be allocated.
!
!# Example
!```fortran
! type(json_value),pointer :: p
! call json_create(p,'value',1.0d0)
!```
subroutine json_value_create_double(me,val,name)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name
real(RK),intent(in) :: val
call json_value_create(me)
call to_double(me,val,name)
end subroutine json_value_create_double
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! A wrapper for [[json_value_create_double]] so that [[json_create_double]] may be
! called with an actual argument corresponding to the dummy argument, 'name'
! that may be of 'DEFAULT' or 'ISO_10646' character kind.
subroutine wrap_json_value_create_double(me,val,name)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
real(RK),intent(in) :: val
call json_value_create_double(me,val,to_unicode(name))
end subroutine wrap_json_value_create_double
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Allocate a json_value pointer and make it a string variable.
! The pointer should not already be allocated.
!
!# Example
!```fortran
! type(json_value),pointer :: p
! call json_create(p,'value','hello')
!```
subroutine json_value_create_string(me,val,name)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name
character(kind=CK,len=*),intent(in) :: val
call json_value_create(me)
call to_string(me,val,name)
end subroutine json_value_create_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! Wrap [[json_value_create_string]] so that [[json_create_string]] may be called with actual
! character string arguments for 'name' and 'val' that are BOTH of 'DEFAULT' or
! 'ISO_10646' character kind.
subroutine wrap_json_value_create_string(me,val,name)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
character(kind=CDK,len=*),intent(in) :: val
call json_value_create_string(me,to_unicode(val),to_unicode(name))
end subroutine wrap_json_value_create_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Allocate a json_value pointer and make it a null variable.
! The pointer should not already be allocated.
!
!# Example
!```fortran
! type(json_value),pointer :: p
! call json_create(p,'value')
!```
subroutine json_value_create_null(me,name)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name
call json_value_create(me)
call to_null(me,name)
end subroutine json_value_create_null
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! Wrap [[json_value_create_null]] so that [[json_create_null]] may be called with an actual
! argument corresponding to the dummy argument 'name' that is either of 'DEFAULT' or
! 'ISO_10646' character kind.
subroutine wrap_json_value_create_null(me,name)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
call json_value_create_null(me,to_unicode(name))
end subroutine wrap_json_value_create_null
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Allocate a [[json_value]] pointer and make it an object variable.
! The pointer should not already be allocated.
!
!# Example
!```fortran
! type(json_value),pointer :: p
! call json_create(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.
subroutine json_value_create_object(me,name)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name
call json_value_create(me)
call to_object(me,name)
end subroutine json_value_create_object
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! Wrap [[json_value_create_object]] so that [[json_create_object]] may be called with an actual
! argument corresponding to the dummy argument 'name' that is of either 'DEFAULT' or
! 'ISO_10646' character kind.
subroutine wrap_json_value_create_object(me,name)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
call json_value_create_object(me,to_unicode(name))
end subroutine wrap_json_value_create_object
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Allocate a [[json_value]] pointer and make it an array variable.
! The pointer should not already be allocated.
!
!# Example
!```fortran
! type(json_value),pointer :: p
! call json_create(p,'arrayname')
!```
subroutine json_value_create_array(me,name)
implicit none
type(json_value),pointer :: me
character(kind=CK,len=*),intent(in) :: name
call json_value_create(me)
call to_array(me,name)
end subroutine json_value_create_array
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! A wrapper for [[json_value_create_array]] so that [[json_create_array]] may be called with
! an actual argument, corresponding to the dummy argument 'name', that is either of
! 'DEFAULT' or 'ISO_10646' character kind.
subroutine wrap_json_value_create_array(me,name)
implicit none
type(json_value),pointer :: me
character(kind=CDK,len=*),intent(in) :: name
call json_value_create_array(me,to_unicode(name))
end subroutine wrap_json_value_create_array
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Change the [[json_value]] variable to a logical.
subroutine to_logical(me,val,name)
implicit none
type(json_value),intent(inout) :: me
logical(LK),intent(in),optional :: val !! if the value is also to be set (if not present, then .false. is used).
character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
!set type and value:
call destroy_json_data(me)
me%var_type = json_logical
allocate(me%log_value)
if (present(val)) then
me%log_value = val
else
me%log_value = .false. !default value
end if
!name:
if (present(name)) me%name = trim(name)
end subroutine to_logical
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Change the [[json_value]] variable to an integer.
subroutine to_integer(me,val,name)
implicit none
type(json_value),intent(inout) :: me
integer(IK),intent(in),optional :: val !! if the value is also to be set (if not present, then 0 is used).
character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
!set type and value:
call destroy_json_data(me)
me%var_type = json_integer
allocate(me%int_value)
if (present(val)) then
me%int_value = val
else
me%int_value = 0 !default value
end if
!name:
if (present(name)) me%name = trim(name)
end subroutine to_integer
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Change the [[json_value]] variable to a double.
subroutine to_double(me,val,name)
implicit none
type(json_value),intent(inout) :: me
real(RK),intent(in),optional :: val !! if the value is also to be set (if not present, then 0.0_rk is used).
character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
!set type and value:
call destroy_json_data(me)
me%var_type = json_double
allocate(me%dbl_value)
if (present(val)) then
me%dbl_value = val
else
me%dbl_value = 0.0_RK !default value
end if
!name:
if (present(name)) me%name = trim(name)
end subroutine to_double
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Change the [[json_value]] variable to a string.
!
!# Modified
! * Izaak Beekman : 02/24/2015
!
subroutine to_string(me,val,name)
implicit none
type(json_value),intent(inout) :: me
character(kind=CK,len=*),intent(in),optional :: val !! if the value is also to be set (if not present, then '' is used).
character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
!set type and value:
call destroy_json_data(me)
me%var_type = json_string
if (present(val)) then
me%str_value = val
else
me%str_value = '' !default value
end if
!name:
if (present(name)) me%name = trim(name)
end subroutine to_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Change the [[json_value]] variable to a null.
subroutine to_null(me,name)
implicit none
type(json_value),intent(inout) :: me
character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
!set type and value:
call destroy_json_data(me)
me%var_type = json_null
!name:
if (present(name)) me%name = trim(name)
end subroutine to_null
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Change the [[json_value]] variable to an object.
subroutine to_object(me,name)
implicit none
type(json_value),intent(inout) :: me
character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
!set type and value:
call destroy_json_data(me)
me%var_type = json_object
!name:
if (present(name)) me%name = trim(name)
end subroutine to_object
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Change the [[json_value]] variable to an array.
subroutine to_array(me,name)
implicit none
type(json_value),intent(inout) :: me
character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
!set type and value:
call destroy_json_data(me)
me%var_type = json_array
!name:
if (present(name)) me%name = trim(name)
end subroutine to_array
!*****************************************************************************************
!*****************************************************************************************
!>
! Core parsing routine.
recursive subroutine parse_object(unit, str, parent)
implicit none
integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
type(json_value),pointer :: parent !! the parsed object will be added as a child of this
type(json_value),pointer :: pair
logical(LK) :: eof
character(kind=CK,len=1) :: c
character(kind=CK,len=:),allocatable :: tmp !! this is a work-around for a bug
!! in the gfortran 4.9 compiler.
if (.not. exception_thrown) then
!the routine is being called incorrectly.
if (.not. associated(parent)) then
call throw_exception('Error in parse_object: parent pointer not associated.')
end if
nullify(pair) !probably not necessary
! pair name
c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
if (eof) then
call throw_exception('Error in parse_object:'//&
' Unexpected end of file while parsing start of object.')
return
else if (end_object == c) then
! end of an empty object
return
else if (quotation_mark == c) then
call json_value_create(pair)
call parse_string(unit, str, tmp) !write to a tmp variable because of
pair % name = tmp ! a bug in 4.9 gfortran compiler.
deallocate(tmp)
if (exception_thrown) then
call json_destroy(pair)
return
end if
else
call throw_exception('Error in parse_object: Expecting string: "'//c//'"')
return
end if
! pair value
c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
if (eof) then
call throw_exception('Error in parse_object:'//&
' Unexpected end of file while parsing object member.')
return
else if (colon_char == c) then
! parse the value
call parse_value(unit, str, pair)
if (exception_thrown) then
call json_destroy(pair)
return
else
call json_add(parent, pair)
end if
else
call throw_exception('Error in parse_object:'//&
' Expecting : and then a value: '//c)
return
end if
! another possible pair
c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
if (eof) then
call throw_exception('Error in parse_object: '//&
'End of file encountered when parsing an object')
return
else if (delimiter == c) then
! read the next member
call parse_object(unit = unit, str=str, parent = parent)
else if (end_object == c) then
! end of object
return
else
call throw_exception('Error in parse_object: Expecting end of object: '//c)
return
end if
end if
end subroutine parse_object
!*****************************************************************************************
!*****************************************************************************************
!>
! Core parsing routine.
recursive subroutine parse_array(unit, str, array)
implicit none
integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
type(json_value),pointer :: array
type(json_value),pointer :: element
logical(LK) :: eof
character(kind=CK,len=1) :: c
do
if (exception_thrown) exit
! try to parse an element value
nullify(element)
call json_value_create(element)
call parse_value(unit, str, element)
if (exception_thrown) then
if (associated(element)) call json_destroy(element)
exit
end if
! parse value will disassociate an empty array value
if (associated(element)) call json_add(array, element)
! popped the next character
c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
if (eof) then
! The file ended before array was finished:
call throw_exception('Error in parse_array: '//&
'End of file encountered when parsing an array.')
exit
else if (delimiter == c) then
! parse the next element
cycle
else if (end_array == c) then
! end of array
exit
else
call throw_exception('Error in parse_array: '//&
'Unexpected character encountered when parsing array.')
exit
end if
end do
end subroutine parse_array
!*****************************************************************************************
!*****************************************************************************************
!>
! Parses a string while reading a JSON file.
!
!# History
! * Jacob Williams : 6/16/2014 : Added hex validation.
subroutine parse_string(unit, str, string)
implicit none
integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
character(kind=CK,len=:),allocatable,intent(out) :: string
logical(LK) :: eof, is_hex, escape
character(kind=CK,len=1) :: c, last
character(kind=CK,len=4) :: hex
integer(IK) :: i
integer(IK) :: ip !! index to put next character,
!! to speed up by reducing the number of character string reallocations.
!at least return a blank string if there is a problem:
string = repeat(space, chunk_size)
if (.not. exception_thrown) then
!initialize:
ip = 1
last = space
is_hex = .false.
escape = .false.
i = 0
do
!get the next character from the file:
c = pop_char(unit, str=str, eof = eof, skip_ws = .false.)
if (eof) then
call throw_exception('Error in parse_string: Expecting end of string')
return
else if (c==quotation_mark .and. last /= backslash) then
if (is_hex) call throw_exception('Error in parse_string:'//&
' incomplete hex string: \u'//trim(hex))
exit
else
!if the string is not big enough, then add another chunk:
if (ip>len(string)) string = string // repeat(space, chunk_size)
!append to string:
string(ip:ip) = c
ip = ip + 1
!hex validation:
if (is_hex) then !accumulate the four characters after '\u'
i=i+1
hex(i:i) = c
if (i==4) then
if (valid_json_hex(hex)) then
i = 0
hex = ''
is_hex = .false.
else
call throw_exception('Error in parse_string:'//&
' invalid hex string: \u'//trim(hex))
exit
end if
end if
else
!when the '\u' string is encountered, then
! start accumulating the hex string (should be the next 4 characters)
if (escape) then
escape = .false.
is_hex = (c=='u') !the next four characters are the hex string
else
escape = (c==backslash)
end if
end if
!update for next char:
last = c
end if
end do
!trim the string if necessary:
if (ip<len(string)+1) then
if (ip==1) then
string = ''
else
string = string(1:ip-1)
end if
end if
end if
end subroutine parse_string
!*****************************************************************************************
!*****************************************************************************************
!>
! Core parsing routine.
subroutine parse_for_chars(unit, str, chars)
implicit none
integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
character(kind=CK,len=*),intent(in) :: chars !! the string to check for.
integer(IK) :: i, length
logical(LK) :: eof
character(kind=CK,len=1) :: c
if (.not. exception_thrown) then
length = len_trim(chars)
do i = 1, length
c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
if (eof) then
call throw_exception('Error in parse_for_chars:'//&
' Unexpected end of file while parsing array.')
return
else if (c /= chars(i:i)) then
call throw_exception('Error in parse_for_chars:'//&
' Unexpected character.: "'//c//'" '//chars(i:i))
return
end if
end do
end if
end subroutine parse_for_chars
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 1/20/2014
!
! Read a numerical value from the file (or string).
! The routine will determine if it is an integer or a double, and
! allocate the type accordingly.
!
!@note Complete rewrite of the original FSON routine, which had some problems.
subroutine parse_number(unit, str, value)
implicit none
integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
type(json_value),pointer :: value
character(kind=CK,len=:),allocatable :: tmp
character(kind=CK,len=1) :: c
logical(LK) :: eof
real(RK) :: rval
integer(IK) :: ival
logical(LK) :: first
logical(LK) :: is_integer
!to speed up by reducing the number of character string reallocations:
integer(IK) :: ip !index to put next character
if (.not. exception_thrown) then
tmp = repeat(space, chunk_size)
ip = 1
first = .true.
is_integer = .true. !assume it may be an integer, unless otherwise determined
!read one character at a time and accumulate the string:
do
!get the next character:
c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
if (eof) then
call throw_exception('Error in parse_number:'//&
' Unexpected end of file while parsing number.')
return
else
select case (c)
case(CK_'-',CK_'+') !note: allowing a '+' as the first character here.
if (is_integer .and. (.not. first)) is_integer = .false.
!add it to the string:
!tmp = tmp // c !...original
if (ip>len(tmp)) tmp = tmp // repeat(space, chunk_size)
tmp(ip:ip) = c
ip = ip + 1
case(CK_'.',CK_'E',CK_'e') !can be present in real numbers
if (is_integer) is_integer = .false.
!add it to the string:
!tmp = tmp // c !...original
if (ip>len(tmp)) tmp = tmp // repeat(space, chunk_size)
tmp(ip:ip) = c
ip = ip + 1
case(CK_'0':CK_'9') !valid characters for numbers
!add it to the string:
!tmp = tmp // c !...original
if (ip>len(tmp)) tmp = tmp // repeat(space, chunk_size)
tmp(ip:ip) = c
ip = ip + 1
case default
!push back the last character read:
call push_char(c)
!string to value:
if (is_integer) then
ival = string_to_integer(tmp)
call to_integer(value,ival)
else
rval = string_to_double(tmp)
call to_double(value,rval)
end if
exit !finished
end select
end if
if (first) first = .false.
end do
!cleanup:
if (allocated(tmp)) deallocate(tmp)
end if
end subroutine parse_number
!*****************************************************************************************
!*****************************************************************************************
!>
! Get the next character from the file (or string).
!
!# See also
! * [[push_char]]
!
!@note This routine ignores non-printing ASCII characters (iachar<=31) that are in strings.
recursive function pop_char(unit, str, eof, skip_ws) result(popped)
implicit none
character(kind=CK,len=1) :: popped !! the popped character.
integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string) -- only used if unit=0
logical(LK),intent(out) :: eof !! true if the end of the file has been reached.
logical(LK),intent(in),optional :: skip_ws !! to ignore whitespace.
integer(IK) :: ios,str_len
character(kind=CK,len=1) :: c
logical(LK) :: ignore
if (.not. exception_thrown) then
eof = .false.
if (.not. present(skip_ws)) then
ignore = .false.
else
ignore = skip_ws
end if
do
if (pushed_index > 0) then
! there is a character pushed back on, most likely from the number parsing
! NOTE: this can only occur if reading from a file when use_unformatted_stream=.false.
c = pushed_char(pushed_index:pushed_index)
pushed_index = pushed_index - 1
else
if (unit/=0) then !read from the file
!read the next character:
if (use_unformatted_stream) then
read(unit=unit,pos=ipos,iostat=ios) c
else
read(unit=unit,fmt='(A1)',advance='NO',iostat=ios) c
end if
ipos = ipos + 1
!....note: maybe try read the file in chunks...
!.... or use asynchronous read with double buffering
! (see Modern Fortran: Style and Usage)
else !read from the string
str_len = len(str) !length of the string
if (ipos<=str_len) then
c = str(ipos:ipos)
ios = 0
else
ios = IOSTAT_END !end of the string
end if
ipos = ipos + 1
end if
char_count = char_count + 1 !character count in the current line
if (IS_IOSTAT_END(ios)) then !end of file
char_count = 0
eof = .true.
exit
elseif (IS_IOSTAT_EOR(ios) .or. c==newline) then !end of record
char_count = 0
line_count = line_count + 1
cycle
end if
end if
if (any(c == control_chars)) then
! non printing ascii characters
cycle
else if (ignore .and. c == space) then
cycle
else
popped = c
exit
end if
end do
end if
end function pop_char
!*****************************************************************************************
!*****************************************************************************************
!>
! Core routine.
!
!# See also
! * [[pop_char]]
!
!# History
! * Jacob Williams : 5/3/2015 : replaced original version of this routine.
subroutine push_char(c)
implicit none
character(kind=CK,len=1),intent(in) :: c
character(kind=CK,len=max_numeric_str_len) :: istr
if (.not. exception_thrown) then
if (use_unformatted_stream) then
!in this case, c is ignored, and we just
!decrement the stream position counter:
ipos = ipos - 1
else
pushed_index = pushed_index + 1
if (pushed_index>0 .and. pushed_index<=len(pushed_char)) then
pushed_char(pushed_index:pushed_index) = c
else
call integer_to_string(pushed_index,istr)
call throw_exception('Error in push_char: '//&
'invalid valid of pushed_index: '//trim(istr))
end if
end if
end if
end subroutine push_char
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/4/2013
!
! Convert an integer to a string.
pure subroutine integer_to_string(ival,str)
implicit none
integer(IK),intent(in) :: ival !! integer value.
character(kind=CK,len=*),intent(out) :: str !! ival converted to a string.
integer(IK) :: istat
write(str,fmt=int_fmt,iostat=istat) ival
if (istat==0) then
str = adjustl(str)
else
str = repeat(star,len(str))
end if
end subroutine integer_to_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date: 12/4/2013
!
! Convert a real value to a string.
!
!# Modified
! * Izaak Beekman : 02/24/2015 : added the compact option.
subroutine real_to_string(rval,str)
implicit none
real(RK),intent(in) :: rval !! real value.
character(kind=CK,len=*),intent(out) :: str !! rval converted to a string.
integer(IK) :: istat
!default format:
write(str,fmt=real_fmt,iostat=istat) rval
if (istat==0) then
!in this case, the default string will be compacted,
! so that the same value is displayed with fewer characters.
if (compact_real) call compact_real_string(str)
else
str = repeat(star,len(str))
end if
end subroutine real_to_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
! date: 02/24/2015
!
! Compact a string representing a real number, so that
! the same value is displayed with fewer characters.
!
!# See also
! * [[real_to_string]]
subroutine compact_real_string(str)
implicit none
character(kind=CK,len=*),intent(inout) :: str !! string representation of a real number.
character(kind=CK,len=len(str)) :: significand, expnt
character(kind=CK,len=2) :: separator
integer(IK) :: exp_start,decimal_pos,sig_trim,exp_trim,i
str = adjustl(str)
exp_start = scan(str,CK_'eEdD')
if (exp_start == 0) exp_start = scan(str,CK_'-+',back=.true.)
decimal_pos = scan(str,CK_'.')
if (exp_start /= 0) separator = str(exp_start:exp_start)
if ( exp_start < decimal_pos ) then !possibly signed, exponent-less float
significand = str
sig_trim = len(trim(significand))
do i = len(trim(significand)),decimal_pos+2,-1 !look from right to left at 0s
!but save one after the decimal place
if (significand(i:i) == '0') then
sig_trim = i-1
else
exit
end if
end do
str = trim(significand(1:sig_trim))
else if (exp_start > decimal_pos) then !float has exponent
significand = str(1:exp_start-1)
sig_trim = len(trim(significand))
do i = len(trim(significand)),decimal_pos+2,-1 !look from right to left at 0s
if (significand(i:i) == '0') then
sig_trim = i-1
else
exit
end if
end do
expnt = adjustl(str(exp_start+1:))
if (expnt(1:1) == '+' .or. expnt(1:1) == '-') then
separator = trim(adjustl(separator))//expnt(1:1)
exp_start = exp_start + 1
expnt = adjustl(str(exp_start+1:))
end if
exp_trim = 1
do i = 1,(len(trim(expnt))-1) !look at exponent leading zeros saving last
if (expnt(i:i) == '0') then
exp_trim = i+1
else
exit
end if
end do
str = trim(adjustl(significand(1:sig_trim)))// &
trim(adjustl(separator))// &
trim(adjustl(expnt(exp_trim:)))
!else ! mal-formed real, BUT this code should be unreachable
end if
end subroutine compact_real_string
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
! date:6/14/2014
!
! Returns true if the string is a valid 4-digit hex string.
!
!# Examples
!```fortran
! valid_json_hex('0000') !returns true
! valid_json_hex('ABC4') !returns true
! valid_json_hex('AB') !returns false (< 4 characters)
! valid_json_hex('WXYZ') !returns false (invalid characters)
!```
pure function valid_json_hex(str) result(valid)
implicit none
logical(LK) :: valid !! is str a value 4-digit hex string
character(kind=CK,len=*),intent(in) :: str !! the string to check.
integer(IK) :: n,i
!an array of the valid hex characters:
character(kind=CK,len=1),dimension(22),parameter :: valid_chars = &
[ (achar(i),i=48,57), & ! decimal digits
(achar(i),i=65,70), & ! capital A-F
(achar(i),i=97,102) ] ! lowercase a-f
!initialize
valid = .false.
!check all the characters in the string:
n = len(str)
if (n==4) then
do i=1,n
if (.not. any(str(i:i)==valid_chars)) return
end do
valid = .true. !all are in the set, so it is OK
end if
end function valid_json_hex
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! Convert string to unicode (CDK to CK).
pure function to_uni(str)
implicit none
character(kind=CDK,len=*), intent(in) :: str
character(kind=CK,len=len(str)) :: to_uni
to_uni = str
end function to_uni
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! Convert array of strings to unicode (CDK to CK).
!
!@note JW: may be able to remove this by making [[to_uni]] PURE ELEMENTAL ?
pure function to_uni_vec(str)
implicit none
character(kind=CDK,len=*), dimension(:), intent(in) :: str
character(kind=CK,len=len(str)), dimension(size(str)) :: to_uni_vec
to_uni_vec = str
end function to_uni_vec
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! CK//CDK operator.
function ucs4_join_default(ucs4_str,def_str) result(res)
implicit none
character(kind=CK, len=*), intent(in) :: ucs4_str
character(kind=CDK,len=*), intent(in) :: def_str
character(kind=CK,len=(len(ucs4_str)+len(def_str))) :: res
res = ucs4_str//to_unicode(def_str)
end function ucs4_join_default
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! CDK//CK operator.
function default_join_ucs4(def_str,ucs4_str) result(res)
implicit none
character(kind=CDK,len=*), intent(in) :: def_str
character(kind=CK, len=*), intent(in) :: ucs4_str
character(kind=CK,len=(len(def_str)+len(ucs4_str))) :: res
res = to_unicode(def_str)//ucs4_str
end function default_join_ucs4
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! CK==CDK operator.
function ucs4_comp_default(ucs4_str,def_str) result(res)
implicit none
character(kind=CK, len=*), intent(in) :: ucs4_str
character(kind=CDK,len=*), intent(in) :: def_str
logical(LK) :: res
res = ( ucs4_str == to_unicode(def_str) )
end function ucs4_comp_default
!*****************************************************************************************
!*****************************************************************************************
!> author: Izaak Beekman
!
! CDK==CK operator.
function default_comp_ucs4(def_str,ucs4_str) result(res)
implicit none
character(kind=CDK,len=*), intent(in) :: def_str
character(kind=CK, len=*), intent(in) :: ucs4_str
logical(LK) :: res
res = ( to_unicode(def_str) == ucs4_str)
end function default_comp_ucs4
!*****************************************************************************************
!*****************************************************************************************
!> author: Jacob Williams
!
! Print any error message, and then clear the exceptions.
!
!@note This routine is used by the unit tests.
! It was originally in json_example.f90, and was
! moved here 2/26/2015 by Izaak Beekman.
subroutine json_print_error_message(io_unit)
implicit none
integer, intent(in), optional :: io_unit
character(kind=CK,len=:),allocatable :: error_msg
logical :: status_ok
!get error message:
call json_check_for_errors(status_ok, error_msg)
!print it if there is one:
if (.not. status_ok) then
if (present(io_unit)) then
write(io_unit,'(A)') error_msg
else
write(*,'(A)') error_msg
end if
deallocate(error_msg)
call json_clear_exceptions()
end if
end subroutine json_print_error_message
!*****************************************************************************************
!*****************************************************************************************
end module json_module
!*****************************************************************************************