Simulation Core
選択できるのは25トピックまでです。 トピックは、先頭が英数字で、英数字とダッシュ('-')を使用した35文字以内のものにしてください。
 
 
 
 
 
 

11720 行
418 KiB

  1. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90"
  2. !*****************************************************************************************
  3. !> author: Jacob Williams
  4. ! license: BSD
  5. !
  6. ! This module provides a low-level interface for manipulation of JSON data.
  7. ! The two public entities are [[json_value]], and [[json_core(type)]].
  8. ! The [[json_file_module]] provides a higher-level interface to some
  9. ! of these routines.
  10. !
  11. !### License
  12. ! * JSON-Fortran is released under a BSD-style license.
  13. ! See the [LICENSE](https://github.com/jacobwilliams/json-fortran/blob/master/LICENSE)
  14. ! file for details.
  15. module json_value_module
  16. use,intrinsic :: iso_fortran_env, only: iostat_end,error_unit,output_unit
  17. use,intrinsic :: ieee_arithmetic
  18. use json_kinds
  19. use json_parameters
  20. use json_string_utilities
  21. implicit none
  22. private
  23. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_macros.inc" 1
  24. ! JSON-Fortran preprocessor macros.
  25. !
  26. ! License
  27. ! JSON-Fortran is released under a BSD-style license.
  28. ! See the [LICENSE](https://github.com/jacobwilliams/json-fortran/blob/master/LICENSE)
  29. ! file for details.
  30. !*********************************************************
  31. ! File encoding preprocessor macro.
  32. !
  33. # 15
  34. ! don't ask for utf-8 file encoding unless using UCS4
  35. ! this may let us use unformatted stream io to read in files more quickly
  36. ! even with unicode support turned on `inquire( ... encoding=FL_ENCODING)`
  37. ! may be able to detect json files in which each character is exactly one
  38. ! byte
  39. !*********************************************************
  40. !*********************************************************
  41. ! This C preprocessor macro will take a procedure name as an
  42. ! input, and output either that same procedure name if the
  43. ! code is compiled without USE_UCS4 being defined or it will
  44. ! expand the procedure name to the original procedure name,
  45. ! followed by a comma and then the original procedure name
  46. ! with 'wrap_' prepended to it. This is suitable for creating
  47. ! overloaded interfaces that will accept UCS4 character actual
  48. ! arguments as well as DEFAULT/ASCII character arguments,
  49. ! based on whether or not ISO 10646 is supported and requested.
  50. !
  51. # 55
  52. !*********************************************************
  53. # 28 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  54. !*********************************************************
  55. !>
  56. ! If Unicode is not enabled, then
  57. ! JSON files are opened using access='STREAM' and
  58. ! form='UNFORMATTED'. This allows the file to
  59. ! be read faster.
  60. !
  61. # 38
  62. logical,parameter :: use_unformatted_stream = .true.
  63. !*********************************************************
  64. !*********************************************************
  65. !>
  66. ! If Unicode is not enabled, then
  67. ! JSON files are opened using access='STREAM' and
  68. ! form='UNFORMATTED'. This allows the file to
  69. ! be read faster.
  70. !
  71. # 52
  72. character(kind=CDK,len=*),parameter :: access_spec = 'STREAM'
  73. !*********************************************************
  74. !*********************************************************
  75. !>
  76. ! If Unicode is not enabled, then
  77. ! JSON files are opened using access='STREAM' and
  78. ! form='UNFORMATTED'. This allows the file to
  79. ! be read faster.
  80. !
  81. # 66
  82. character(kind=CDK,len=*),parameter :: form_spec = 'UNFORMATTED'
  83. !*********************************************************
  84. !*********************************************************
  85. !>
  86. ! Type used to construct the linked-list JSON structure.
  87. ! Normally, this should always be a pointer variable.
  88. ! This type should only be used by an instance of [[json_core(type)]].
  89. !
  90. !### Example
  91. !
  92. ! The following test program:
  93. !
  94. !````fortran
  95. ! program test
  96. ! use json_module
  97. ! implicit none
  98. ! type(json_core) :: json
  99. ! type(json_value),pointer :: p
  100. ! call json%create_object(p,'') !create the root
  101. ! call json%add(p,'year',1805) !add some data
  102. ! call json%add(p,'value',1.0_RK) !add some data
  103. ! call json%print(p,'test.json') !write it to a file
  104. ! call json%destroy(p) !cleanup
  105. ! end program test
  106. !````
  107. !
  108. ! Produces the JSON file **test.json**:
  109. !
  110. !````json
  111. ! {
  112. ! "year": 1805,
  113. ! "value": 0.1E+1
  114. ! }
  115. !````
  116. !
  117. !@warning Pointers of this type should only be allocated
  118. ! using the methods from [[json_core(type)]].
  119. type,public :: json_value
  120. !force the constituents to be stored contiguously
  121. ![note: on Intel, the order of the variables below
  122. ! is significant to avoid the misaligned field warnings]
  123. sequence
  124. private
  125. !for the linked list:
  126. type(json_value),pointer :: previous => null() !! previous item in the list
  127. type(json_value),pointer :: next => null() !! next item in the list
  128. type(json_value),pointer :: parent => null() !! parent item of this
  129. type(json_value),pointer :: children => null() !! first child item of this
  130. type(json_value),pointer :: tail => null() !! last child item of this
  131. character(kind=CK,len=:),allocatable :: name !! variable name (unescaped)
  132. real(RK),allocatable :: dbl_value !! real data for this variable
  133. logical(LK),allocatable :: log_value !! logical data for this variable
  134. character(kind=CK,len=:),allocatable :: str_value !! string data for this variable
  135. !! (unescaped)
  136. integer(IK),allocatable :: int_value !! integer data for this variable
  137. integer(IK) :: var_type = json_unknown !! variable type
  138. integer(IK),private :: n_children = 0 !! number of children
  139. end type json_value
  140. !*********************************************************
  141. !*********************************************************
  142. !>
  143. ! To access the core routines for manipulation
  144. ! of [[json_value]] pointer variables. This class allows
  145. ! for thread safe use of the module.
  146. !
  147. !### Usage
  148. !````fortran
  149. ! program test
  150. ! use json_module, wp=>json_RK
  151. ! implicit none
  152. ! type(json_core) :: json !<--have to declare this
  153. ! type(json_value),pointer :: p
  154. ! call json%create_object(p,'') !create the root
  155. ! call json%add(p,'year',1805) !add some data
  156. ! call json%add(p,'value',1.0_wp) !add some data
  157. ! call json%print(p,'test.json') !write it to a file
  158. ! call json%destroy(p) !cleanup
  159. ! end program test
  160. !````
  161. type,public :: json_core
  162. private
  163. integer(IK) :: spaces_per_tab = 2 !! number of spaces for indenting
  164. logical(LK) :: compact_real = .true. !! to use the "compact" form of real
  165. !! numbers for output
  166. character(kind=CDK,len=:),allocatable :: real_fmt !! the format string to use
  167. !! for converting real numbers to strings.
  168. !! It can be set in [[json_initialize]],
  169. !! and used in [[json_value_print]]
  170. !! If not set, then `default_real_fmt`
  171. !! is used instead.
  172. logical(LK) :: is_verbose = .false. !! if true, all exceptions are
  173. !! immediately printed to console.
  174. logical(LK) :: stop_on_error = .false. !! if true, then the program is
  175. !! stopped immediately when an
  176. !! exception is raised.
  177. logical(LK) :: exception_thrown = .false. !! The error flag. Will be set to true
  178. !! when an error is thrown in the class.
  179. !! Many of the methods will check this
  180. !! and return immediately if it is true.
  181. character(kind=CK,len=:),allocatable :: err_message
  182. !! the error message.
  183. !! if `exception_thrown=False` then
  184. !! this variable is not allocated.
  185. integer(IK) :: char_count = 0 !! character position in the current line
  186. integer(IK) :: line_count = 1 !! lines read counter
  187. integer(IK) :: pushed_index = 0 !! used when parsing lines in file
  188. character(kind=CK,len=pushed_char_size) :: pushed_char = CK_'' !! used when parsing
  189. !! lines in file
  190. integer(IK) :: ipos = 1 !! for allocatable strings: next character to read
  191. logical(LK) :: strict_type_checking = .false. !! if true, then no type conversions are done
  192. !! in the `get` routines if the actual variable
  193. !! type is different from the return type (for
  194. !! example, integer to real).
  195. logical(LK) :: trailing_spaces_significant = .false. !! for name and path comparisons, if trailing
  196. !! space is to be considered significant.
  197. logical(LK) :: case_sensitive_keys = .true. !! if name and path comparisons
  198. !! are case sensitive.
  199. logical(LK) :: no_whitespace = .false. !! when printing a JSON string, don't include
  200. !! non-significant spaces or line breaks.
  201. !! If true, the entire structure will be
  202. !! printed on one line.
  203. logical(LK) :: unescaped_strings = .true. !! If false, then the escaped
  204. !! string is returned from [[json_get_string]]
  205. !! and similar routines. If true [default],
  206. !! then the string is returned unescaped.
  207. logical(LK) :: allow_comments = .true. !! if true, any comments will be ignored when
  208. !! parsing a file. The comment tokens are defined
  209. !! by the `comment_char` character variable.
  210. character(kind=CK,len=:),allocatable :: comment_char !! comment tokens when
  211. !! `allow_comments` is true.
  212. !! Examples: '`!`' or '`#`'.
  213. !! Default is `CK_'/!#'`.
  214. integer(IK) :: path_mode = 1_IK !! How the path strings are interpreted in the
  215. !! `get_by_path` routines:
  216. !!
  217. !! * 1 -- Default mode (see [[json_get_by_path_default]])
  218. !! * 2 -- as RFC 6901 "JSON Pointer" paths
  219. !! (see [[json_get_by_path_rfc6901]])
  220. !! * 3 -- JSONPath "bracket-notation"
  221. !! see [[json_get_by_path_jsonpath_bracket]])
  222. character(kind=CK,len=1) :: path_separator = dot !! The `path` separator to use
  223. !! in the "default" mode for
  224. !! the paths in the various
  225. !! `get_by_path` routines.
  226. !! Note: if `path_mode/=1`
  227. !! then this is ignored.
  228. logical(LK) :: compress_vectors = .false. !! If true, then arrays of integers,
  229. !! nulls, reals, & logicals are
  230. !! printed all on one line.
  231. !! [Note: `no_whitespace` will
  232. !! override this option if necessary]
  233. logical(LK) :: allow_duplicate_keys = .true. !! If False, then after parsing, if any
  234. !! duplicate keys are found, an error is
  235. !! thrown. A call to [[json_value_validate]]
  236. !! will also check for duplicates. If True
  237. !! [default] then no special checks are done
  238. logical(LK) :: escape_solidus = .false. !! If True then the solidus "`/`" is always escaped
  239. !! ("`\/`") when serializing JSON.
  240. !! If False [default], then it is not escaped.
  241. !! Note that this option does not affect parsing
  242. !! (both escaped and unescaped versions are still
  243. !! valid in all cases).
  244. integer(IK) :: null_to_real_mode = 2_IK !! if `strict_type_checking=false`:
  245. !!
  246. !! * 1 : an exception will be raised if
  247. !! try to retrieve a `null` as a real.
  248. !! * 2 : a `null` retrieved as a real
  249. !! will return NaN. [default]
  250. !! * 3 : a `null` retrieved as a real
  251. !! will return 0.0.
  252. logical(LK) :: non_normals_to_null = .false. !! How to serialize NaN, Infinity,
  253. !! and -Infinity real values:
  254. !!
  255. !! * If true : as JSON `null` values
  256. !! * If false : as strings (e.g., "NaN",
  257. !! "Infinity", "-Infinity") [default]
  258. logical(LK) :: use_quiet_nan = .true. !! if true [default], `null_to_real_mode=2`
  259. !! and [[string_to_real]] will use
  260. !! `ieee_quiet_nan` for NaN values. If false,
  261. !! `ieee_signaling_nan` will be used.
  262. logical(LK) :: strict_integer_type_checking = .true.
  263. !! * If false, when parsing JSON, if an integer numeric value
  264. !! cannot be converted to an integer (`integer(IK)`),
  265. !! then an attempt is then make to convert it
  266. !! to a real (`real(RK)`).
  267. !! * If true [default], an exception will be raised if an integer
  268. !! value cannot be read when parsing JSON.
  269. integer :: ichunk = 0 !! index in `chunk` for [[pop_char]]
  270. !! when `use_unformatted_stream=True`
  271. integer :: filesize = 0 !! the file size when when `use_unformatted_stream=True`
  272. character(kind=CK,len=:),allocatable :: chunk !! a chunk read from a stream file
  273. !! when `use_unformatted_stream=True`
  274. contains
  275. private
  276. !>
  277. ! Return a child of a [[json_value]] structure.
  278. generic,public :: get_child => json_value_get_child_by_index, &
  279. json_value_get_child,&
  280. json_value_get_child_by_name
  281. procedure,private :: json_value_get_child_by_index
  282. procedure,private :: json_value_get_child_by_name
  283. procedure,private :: json_value_get_child
  284. !>
  285. ! Add objects to a linked list of [[json_value]]s.
  286. !
  287. !@note It might make more sense to call this `add_child`.
  288. generic,public :: add => json_value_add_member, &
  289. json_value_add_null, &
  290. json_value_add_integer, &
  291. json_value_add_integer_vec, &
  292. json_value_add_real32, &
  293. json_value_add_real32_vec, &
  294. json_value_add_real, &
  295. json_value_add_real_vec, &
  296. # 326
  297. json_value_add_logical, &
  298. json_value_add_logical_vec, &
  299. json_value_add_string, &
  300. json_value_add_string_vec
  301. # 336
  302. procedure,private :: json_value_add_member
  303. procedure,private :: json_value_add_integer
  304. procedure,private :: json_value_add_null
  305. procedure,private :: json_value_add_integer_vec
  306. procedure,private :: json_value_add_real32
  307. procedure,private :: json_value_add_real32_vec
  308. procedure,private :: json_value_add_real
  309. procedure,private :: json_value_add_real_vec
  310. # 351
  311. procedure,private :: json_value_add_logical
  312. procedure,private :: json_value_add_logical_vec
  313. procedure,private :: json_value_add_string
  314. procedure,private :: json_value_add_string_vec
  315. # 361
  316. !>
  317. ! These are like the `add` methods, except if a variable with the
  318. ! same path is already present, then its value is simply updated.
  319. ! Note that currently, these only work for scalar variables.
  320. ! These routines can also change the variable's type (but an error will be
  321. ! thrown if the existing variable is not a scalar).
  322. !
  323. !### See also
  324. ! * [[json_core(type):add_by_path]] - this one can be used to change
  325. ! arrays and objects to scalars if so desired.
  326. !
  327. !@note Unlike some routines, the `found` output is not optional,
  328. ! so it doesn't present exceptions from being thrown.
  329. !
  330. !@note These have been mostly supplanted by the [[json_core(type):add_by_path]]
  331. ! methods, which do a similar thing (and can be used for
  332. ! scalars and vectors, etc.)
  333. generic,public :: update => json_update_logical,&
  334. json_update_real32,&
  335. json_update_real,&
  336. # 387
  337. json_update_integer,&
  338. json_update_string
  339. # 394
  340. procedure,private :: json_update_logical
  341. procedure,private :: json_update_real32
  342. procedure,private :: json_update_real
  343. # 402
  344. procedure,private :: json_update_integer
  345. procedure,private :: json_update_string
  346. # 408
  347. !>
  348. ! Add variables to a [[json_value]] linked list
  349. ! by specifying their paths.
  350. !
  351. !### Example
  352. !
  353. !````fortran
  354. ! use, intrinsic :: iso_fortran_env, only: output_unit
  355. ! use json_module, wp=>json_RK
  356. ! type(json_core) :: json
  357. ! type(json_value) :: p
  358. ! call json%create_object(p,'root') ! create the root
  359. ! ! now add some variables using the paths:
  360. ! call json%add_by_path(p,'inputs.t', 0.0_wp )
  361. ! call json%add_by_path(p,'inputs.x(1)', 100.0_wp)
  362. ! call json%add_by_path(p,'inputs.x(2)', 200.0_wp)
  363. ! call json%print(p) ! now print to console
  364. !````
  365. !
  366. !### Notes
  367. ! * This uses [[json_create_by_path]]
  368. !
  369. !### See also
  370. ! * The `json_core%update` methods.
  371. ! * [[json_create_by_path]]
  372. generic,public :: add_by_path => json_add_member_by_path,&
  373. json_add_integer_by_path,&
  374. json_add_real32_by_path,&
  375. json_add_real_by_path,&
  376. # 444
  377. json_add_logical_by_path,&
  378. json_add_string_by_path,&
  379. json_add_integer_vec_by_path,&
  380. json_add_real32_vec_by_path,&
  381. json_add_real_vec_by_path,&
  382. # 454
  383. json_add_logical_vec_by_path,&
  384. json_add_string_vec_by_path
  385. # 462
  386. procedure :: json_add_member_by_path
  387. procedure :: json_add_integer_by_path
  388. procedure :: json_add_real32_by_path
  389. procedure :: json_add_real_by_path
  390. # 471
  391. procedure :: json_add_logical_by_path
  392. procedure :: json_add_string_by_path
  393. procedure :: json_add_integer_vec_by_path
  394. procedure :: json_add_real32_vec_by_path
  395. procedure :: json_add_real_vec_by_path
  396. # 481
  397. procedure :: json_add_logical_vec_by_path
  398. procedure :: json_add_string_vec_by_path
  399. # 489
  400. !>
  401. ! Create a [[json_value]] linked list using the
  402. ! path to the variables. Optionally return a
  403. ! pointer to the variable.
  404. !
  405. ! (This will create a `null` variable)
  406. !
  407. !### See also
  408. ! * [[json_core(type):add_by_path]]
  409. generic,public :: create => json_create_by_path
  410. procedure :: json_create_by_path
  411. !>
  412. ! Get data from a [[json_value]] linked list.
  413. !
  414. !@note There are two versions (e.g. [[json_get_integer]] and [[json_get_integer_by_path]]).
  415. ! The first one gets the value from the [[json_value]] passed into the routine,
  416. ! while the second one gets the value from the [[json_value]] found by parsing the
  417. ! path. The path version is split up into unicode and non-unicode versions.
  418. generic,public :: get => &
  419. json_get_by_path, &
  420. json_get_integer, json_get_integer_by_path, &
  421. json_get_integer_vec, json_get_integer_vec_by_path, &
  422. json_get_real32, json_get_real32_by_path, &
  423. json_get_real32_vec, json_get_real32_vec_by_path, &
  424. json_get_real, json_get_real_by_path, &
  425. json_get_real_vec, json_get_real_vec_by_path, &
  426. # 525
  427. json_get_logical, json_get_logical_by_path, &
  428. json_get_logical_vec, json_get_logical_vec_by_path, &
  429. json_get_string, json_get_string_by_path, &
  430. json_get_string_vec, json_get_string_vec_by_path, &
  431. json_get_alloc_string_vec, json_get_alloc_string_vec_by_path,&
  432. json_get_array, json_get_array_by_path
  433. procedure,private :: json_get_integer
  434. procedure,private :: json_get_integer_vec
  435. procedure,private :: json_get_real32
  436. procedure,private :: json_get_real32_vec
  437. procedure,private :: json_get_real
  438. procedure,private :: json_get_real_vec
  439. # 544
  440. procedure,private :: json_get_logical
  441. procedure,private :: json_get_logical_vec
  442. procedure,private :: json_get_string
  443. procedure,private :: json_get_string_vec
  444. procedure,private :: json_get_alloc_string_vec
  445. procedure,private :: json_get_array
  446. procedure,private :: json_get_by_path
  447. procedure,private :: json_get_integer_by_path
  448. procedure,private :: json_get_integer_vec_by_path
  449. procedure,private :: json_get_real32_by_path
  450. procedure,private :: json_get_real32_vec_by_path
  451. procedure,private :: json_get_real_by_path
  452. procedure,private :: json_get_real_vec_by_path
  453. # 563
  454. procedure,private :: json_get_logical_by_path
  455. procedure,private :: json_get_logical_vec_by_path
  456. procedure,private :: json_get_string_by_path
  457. procedure,private :: json_get_string_vec_by_path
  458. procedure,private :: json_get_array_by_path
  459. procedure,private :: json_get_alloc_string_vec_by_path
  460. procedure,private :: json_get_by_path_default
  461. procedure,private :: json_get_by_path_rfc6901
  462. procedure,private :: json_get_by_path_jsonpath_bracket
  463. !>
  464. ! Print the [[json_value]] to an output unit or file.
  465. !
  466. !### Example
  467. !
  468. !````fortran
  469. ! type(json_core) :: json
  470. ! type(json_value) :: p
  471. ! !...
  472. ! call json%print(p,'test.json') !this is [[json_print_to_filename]]
  473. !````
  474. generic,public :: print => json_print_to_console,&
  475. json_print_to_unit,&
  476. json_print_to_filename
  477. procedure :: json_print_to_console
  478. procedure :: json_print_to_unit
  479. procedure :: json_print_to_filename
  480. !>
  481. ! Destructor routine for a [[json_value]] pointer.
  482. ! This must be called explicitly if it is no longer needed,
  483. ! before it goes out of scope. Otherwise, a memory leak will result.
  484. !
  485. !### Example
  486. !
  487. ! Destroy the [[json_value]] pointer before the variable goes out of scope:
  488. !````fortran
  489. ! subroutine example1()
  490. ! type(json_core) :: json
  491. ! type(json_value),pointer :: p
  492. ! call json%create_object(p,'')
  493. ! call json%add(p,'year',2015)
  494. ! call json%print(p)
  495. ! call json%destroy(p)
  496. ! end subroutine example1
  497. !````
  498. !
  499. ! Note: it should NOT be called for a [[json_value]] pointer than has already been
  500. ! added to another [[json_value]] structure, since doing so may render the
  501. ! other structure invalid. Consider the following example:
  502. !````fortran
  503. ! subroutine example2(p)
  504. ! type(json_core) :: json
  505. ! type(json_value),pointer,intent(out) :: p
  506. ! type(json_value),pointer :: q
  507. ! call json%create_object(p,'')
  508. ! call json%add(p,'year',2015)
  509. ! call json%create_object(q,'q')
  510. ! call json%add(q,'val',1)
  511. ! call json%add(p, q) !add q to p structure
  512. ! ! do NOT call json%destroy(q) here, because q is
  513. ! ! now part of the output structure p. p should be destroyed
  514. ! ! somewhere upstream by the caller of this routine.
  515. ! nullify(q) !OK, but not strictly necessary
  516. ! end subroutine example2
  517. !````
  518. generic,public :: destroy => json_value_destroy,destroy_json_core
  519. procedure :: json_value_destroy
  520. procedure :: destroy_json_core
  521. !>
  522. ! If the child variable is present, then remove it.
  523. generic,public :: remove_if_present => json_value_remove_if_present
  524. procedure :: json_value_remove_if_present
  525. !>
  526. ! Allocate a [[json_value]] pointer and make it a real variable.
  527. ! The pointer should not already be allocated.
  528. !
  529. !### Example
  530. !
  531. !````fortran
  532. ! type(json_core) :: json
  533. ! type(json_value),pointer :: p
  534. ! call json%create_real(p,'value',1.0_RK)
  535. !````
  536. !
  537. !### Note
  538. ! * [[json_core(type):create_real]] is just an alias
  539. ! to this one for backward compatibility.
  540. generic,public :: create_real => json_value_create_real
  541. procedure :: json_value_create_real
  542. generic,public :: create_real => json_value_create_real32
  543. procedure :: json_value_create_real32
  544. # 663
  545. !>
  546. ! This is equivalent to [[json_core(type):create_real]],
  547. ! and is here only for backward compatibility.
  548. generic,public :: create_double => json_value_create_real
  549. generic,public :: create_double => json_value_create_real32
  550. # 674
  551. !>
  552. ! Allocate a [[json_value]] pointer and make it an array variable.
  553. ! The pointer should not already be allocated.
  554. !
  555. !### Example
  556. !
  557. !````fortran
  558. ! type(json_core) :: json
  559. ! type(json_value),pointer :: p
  560. ! call json%create_array(p,'arrayname')
  561. !````
  562. generic,public :: create_array => json_value_create_array
  563. procedure :: json_value_create_array
  564. !>
  565. ! Allocate a [[json_value]] pointer and make it an object variable.
  566. ! The pointer should not already be allocated.
  567. !
  568. !### Example
  569. !
  570. !````fortran
  571. ! type(json_core) :: json
  572. ! type(json_value),pointer :: p
  573. ! call json%create_object(p,'objectname')
  574. !````
  575. !
  576. !@note The name is not significant for the root structure or an array element.
  577. ! In those cases, an empty string can be used.
  578. generic,public :: create_object => json_value_create_object
  579. procedure :: json_value_create_object
  580. !>
  581. ! Allocate a json_value pointer and make it a null variable.
  582. ! The pointer should not already be allocated.
  583. !
  584. !### Example
  585. !
  586. !````fortran
  587. ! type(json_core) :: json
  588. ! type(json_value),pointer :: p
  589. ! call json%create_null(p,'value')
  590. !````
  591. generic,public :: create_null => json_value_create_null
  592. procedure :: json_value_create_null
  593. !>
  594. ! Allocate a json_value pointer and make it a string variable.
  595. ! The pointer should not already be allocated.
  596. !
  597. !### Example
  598. !
  599. !````fortran
  600. ! type(json_core) :: json
  601. ! type(json_value),pointer :: p
  602. ! call json%create_string(p,'value','foobar')
  603. !````
  604. generic,public :: create_string => json_value_create_string
  605. procedure :: json_value_create_string
  606. !>
  607. ! Allocate a json_value pointer and make it an integer variable.
  608. ! The pointer should not already be allocated.
  609. !
  610. !### Example
  611. !
  612. !````fortran
  613. ! type(json_core) :: json
  614. ! type(json_value),pointer :: p
  615. ! call json%create_integer(p,42,'value')
  616. !````
  617. generic,public :: create_integer => json_value_create_integer
  618. procedure :: json_value_create_integer
  619. !>
  620. ! Allocate a json_value pointer and make it a logical variable.
  621. ! The pointer should not already be allocated.
  622. !
  623. !### Example
  624. !
  625. !````fortran
  626. ! type(json_core) :: json
  627. ! type(json_value),pointer :: p
  628. ! call json%create_logical(p,'value',.true.)
  629. !````
  630. generic,public :: create_logical => json_value_create_logical
  631. procedure :: json_value_create_logical
  632. !>
  633. ! Parse the JSON file and populate the [[json_value]] tree.
  634. generic,public :: load => json_parse_file
  635. procedure :: json_parse_file
  636. !>
  637. ! Print the [[json_value]] structure to an allocatable string
  638. procedure,public :: serialize => json_value_to_string
  639. !>
  640. ! The same as `serialize`, but only here for backward compatibility
  641. procedure,public :: print_to_string => json_value_to_string
  642. !>
  643. ! Parse the JSON string and populate the [[json_value]] tree.
  644. generic,public :: deserialize => json_parse_string
  645. procedure :: json_parse_string
  646. !>
  647. ! Same as `load` and `deserialize` but only here for backward compatibility.
  648. generic,public :: parse => json_parse_file, &
  649. json_parse_string
  650. !>
  651. ! Throw an exception.
  652. generic,public :: throw_exception => json_throw_exception
  653. procedure :: json_throw_exception
  654. !>
  655. ! Rename a [[json_value]] variable.
  656. generic,public :: rename => json_value_rename,&
  657. json_rename_by_path
  658. procedure :: json_value_rename
  659. procedure :: json_rename_by_path
  660. # 802
  661. !>
  662. ! get info about a [[json_value]]
  663. generic,public :: info => json_info, json_info_by_path
  664. procedure :: json_info
  665. procedure :: json_info_by_path
  666. !>
  667. ! get string info about a [[json_value]]
  668. generic,public :: string_info => json_string_info
  669. procedure :: json_string_info
  670. !>
  671. ! get matrix info about a [[json_value]]
  672. generic,public :: matrix_info => json_matrix_info, json_matrix_info_by_path
  673. procedure :: json_matrix_info
  674. procedure :: json_matrix_info_by_path
  675. !>
  676. ! insert a new element after an existing one,
  677. ! updating the JSON structure accordingly
  678. generic,public :: insert_after => json_value_insert_after, &
  679. json_value_insert_after_child_by_index
  680. procedure :: json_value_insert_after
  681. procedure :: json_value_insert_after_child_by_index
  682. !>
  683. ! get the path to a JSON variable in a structure:
  684. generic,public :: get_path => json_get_path
  685. procedure :: json_get_path
  686. !>
  687. ! verify if a path is valid
  688. ! (i.e., a variable with this path exists in the file).
  689. generic,public :: valid_path => json_valid_path
  690. procedure :: json_valid_path
  691. procedure,public :: remove => json_value_remove !! Remove a [[json_value]] from a
  692. !! linked-list structure.
  693. procedure,public :: replace => json_value_replace !! Replace a [[json_value]] in a
  694. !! linked-list structure.
  695. procedure,public :: reverse => json_value_reverse !! Reverse the order of the children
  696. !! of an array of object.
  697. procedure,public :: check_for_errors => json_check_for_errors !! check for error and get error message
  698. procedure,public :: clear_exceptions => json_clear_exceptions !! clear exceptions
  699. procedure,public :: count => json_count !! count the number of children
  700. procedure,public :: clone => json_clone !! clone a JSON structure (deep copy)
  701. procedure,public :: failed => json_failed !! check for error
  702. procedure,public :: get_parent => json_get_parent !! get pointer to json_value parent
  703. procedure,public :: get_next => json_get_next !! get pointer to json_value next
  704. procedure,public :: get_previous => json_get_previous !! get pointer to json_value previous
  705. procedure,public :: get_tail => json_get_tail !! get pointer to json_value tail
  706. procedure,public :: initialize => json_initialize !! to initialize some parsing parameters
  707. procedure,public :: traverse => json_traverse !! to traverse all elements of a JSON
  708. !! structure
  709. procedure,public :: print_error_message => json_print_error_message !! simply routine to print error
  710. !! messages
  711. procedure,public :: swap => json_value_swap !! Swap two [[json_value]] pointers
  712. !! in a structure (or two different
  713. !! structures).
  714. procedure,public :: is_child_of => json_value_is_child_of !! Check if a [[json_value]] is a
  715. !! descendant of another.
  716. procedure,public :: validate => json_value_validate !! Check that a [[json_value]] linked
  717. !! list is valid (i.e., is properly
  718. !! constructed). This may be useful
  719. !! if it has been constructed externally.
  720. procedure,public :: check_for_duplicate_keys &
  721. => json_check_all_for_duplicate_keys !! Check entire JSON structure
  722. !! for duplicate keys (recursively)
  723. procedure,public :: check_children_for_duplicate_keys &
  724. => json_check_children_for_duplicate_keys !! Check a `json_value` object's
  725. !! children for duplicate keys
  726. !other private routines:
  727. procedure :: name_equal
  728. procedure :: name_strings_equal
  729. procedure :: json_value_print
  730. procedure :: string_to_int
  731. procedure :: string_to_dble
  732. procedure :: prepare_parser => json_prepare_parser
  733. procedure :: parse_end => json_parse_end
  734. procedure :: parse_value
  735. procedure :: parse_number
  736. procedure :: parse_string
  737. procedure :: parse_for_chars
  738. procedure :: parse_object
  739. procedure :: parse_array
  740. procedure :: annotate_invalid_json
  741. procedure :: pop_char
  742. procedure :: push_char
  743. procedure :: get_current_line_from_file_stream
  744. procedure,nopass :: get_current_line_from_file_sequential
  745. procedure :: convert
  746. procedure :: to_string
  747. procedure :: to_logical
  748. procedure :: to_integer
  749. procedure :: to_real
  750. procedure :: to_null
  751. procedure :: to_object
  752. procedure :: to_array
  753. procedure,nopass :: json_value_clone_func
  754. procedure :: is_vector => json_is_vector
  755. end type json_core
  756. !*********************************************************
  757. !*********************************************************
  758. !>
  759. ! Structure constructor to initialize a
  760. ! [[json_core(type)]] object
  761. !
  762. !### Example
  763. !
  764. !```fortran
  765. ! type(json_file) :: json_core
  766. ! json_core = json_core()
  767. !```
  768. interface json_core
  769. module procedure initialize_json_core
  770. end interface
  771. !*********************************************************
  772. !*************************************************************************************
  773. abstract interface
  774. subroutine json_array_callback_func(json, element, i, count)
  775. !! Array element callback function. Used by [[json_get_array]]
  776. import :: json_value,json_core,IK
  777. implicit none
  778. class(json_core),intent(inout) :: json
  779. type(json_value),pointer,intent(in) :: element
  780. integer(IK),intent(in) :: i !! index
  781. integer(IK),intent(in) :: count !! size of array
  782. end subroutine json_array_callback_func
  783. subroutine json_traverse_callback_func(json,p,finished)
  784. !! Callback function used by [[json_traverse]]
  785. import :: json_value,json_core,LK
  786. implicit none
  787. class(json_core),intent(inout) :: json
  788. type(json_value),pointer,intent(in) :: p
  789. logical(LK),intent(out) :: finished !! set true to stop traversing
  790. end subroutine json_traverse_callback_func
  791. end interface
  792. public :: json_array_callback_func
  793. public :: json_traverse_callback_func
  794. !*************************************************************************************
  795. contains
  796. !*****************************************************************************************
  797. !*****************************************************************************************
  798. !> author: Jacob Williams
  799. ! date: 4/17/2016
  800. !
  801. ! Destructor for the [[json_core(type)]] type.
  802. subroutine destroy_json_core(me)
  803. implicit none
  804. class(json_core),intent(out) :: me
  805. end subroutine destroy_json_core
  806. !*****************************************************************************************
  807. !*****************************************************************************************
  808. !> author: Jacob Williams
  809. ! date: 4/26/2016
  810. !
  811. ! Function constructor for a [[json_core(type)]].
  812. ! This is just a wrapper for [[json_initialize]].
  813. !
  814. !@note [[initialize_json_core]], [[json_initialize]],
  815. ! [[initialize_json_core_in_file]], and [[initialize_json_file]]
  816. ! all have a similar interface.
  817. function initialize_json_core(&
  818. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_initialize_dummy_arguments.inc" 1
  819. ! The dummy argument list for the various `initialize` subroutines.
  820. !
  821. ! See also: json_initialize_argument.inc
  822. verbose,&
  823. compact_reals,&
  824. print_signs,&
  825. real_format,&
  826. spaces_per_tab,&
  827. strict_type_checking,&
  828. trailing_spaces_significant,&
  829. case_sensitive_keys,&
  830. no_whitespace,&
  831. unescape_strings,&
  832. comment_char,&
  833. path_mode,&
  834. path_separator,&
  835. compress_vectors,&
  836. allow_duplicate_keys,&
  837. escape_solidus,&
  838. stop_on_error,&
  839. null_to_real_mode,&
  840. non_normal_mode,&
  841. use_quiet_nan, &
  842. strict_integer_type_checking &
  843. # 983 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  844. ) result(json_core_object)
  845. implicit none
  846. type(json_core) :: json_core_object
  847. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_initialize_arguments.inc" 1
  848. ! The argument list for the various `initialize` subroutines.
  849. !
  850. ! See also: json_initialize_dummy_arguments.inc
  851. logical(LK),intent(in),optional :: verbose
  852. !! mainly useful for debugging (default is false)
  853. logical(LK),intent(in),optional :: compact_reals
  854. !! to compact the real number strings for output (default is true)
  855. logical(LK),intent(in),optional :: print_signs
  856. !! always print numeric sign (default is false)
  857. character(kind=CDK,len=*),intent(in),optional :: real_format
  858. !! Real number format: 'E' [default], '*', 'G', 'EN', or 'ES'
  859. integer(IK),intent(in),optional :: spaces_per_tab
  860. !! number of spaces per tab for indenting (default is 2)
  861. logical(LK),intent(in),optional :: strict_type_checking
  862. !! if true, no integer, double, or logical type
  863. !! conversions are done for the `get` routines
  864. !! (default is false).
  865. logical(LK),intent(in),optional :: trailing_spaces_significant
  866. !! for name and path comparisons, is trailing
  867. !! space to be considered significant.
  868. !! (default is false)
  869. logical(LK),intent(in),optional :: case_sensitive_keys
  870. !! for name and path comparisons, are they
  871. !! case sensitive. (default is true)
  872. logical(LK),intent(in),optional :: no_whitespace
  873. !! if true, printing the JSON structure is
  874. !! done without adding any non-significant
  875. !! spaces or linebreaks (default is false)
  876. logical(LK),intent(in),optional :: unescape_strings
  877. !! If false, then the raw escaped
  878. !! string is returned from [[json_get_string]]
  879. !! and similar routines. If true [default],
  880. !! then the string is returned unescaped.
  881. character(kind=CK,len=*),intent(in),optional :: comment_char
  882. !! If present, these characters are used
  883. !! to denote comments in the JSON file,
  884. !! which will be ignored if present.
  885. !! Example: `!`, `#`, or `/!#`. Setting this
  886. !! to a blank string disables the
  887. !! ignoring of comments. (Default is `/!#`).
  888. integer(IK),intent(in),optional :: path_mode
  889. !! How the path strings are interpreted in the
  890. !! `get_by_path` routines:
  891. !!
  892. !! * 1 : Default mode (see [[json_get_by_path_default]])
  893. !! * 2 : as RFC 6901 "JSON Pointer" paths
  894. !! (see [[json_get_by_path_rfc6901]])
  895. !! * 3 : JSONPath "bracket-notation"
  896. !! see [[json_get_by_path_jsonpath_bracket]])
  897. character(kind=CK,len=1),intent(in),optional :: path_separator
  898. !! The `path` separator to use
  899. !! in the "default" mode for
  900. !! the paths in the various
  901. !! `get_by_path` routines.
  902. !! Example: `.` [default] or `%`.
  903. !! Note: if `path_mode/=1`
  904. !! then this is ignored.
  905. logical(LK),intent(in),optional :: compress_vectors
  906. !! If true, then arrays of integers,
  907. !! nulls, doubles, and logicals are
  908. !! printed all on one line.
  909. !! [Note: `no_whitespace` will
  910. !! override this option if necessary].
  911. !! (Default is False).
  912. logical(LK),intent(in),optional :: allow_duplicate_keys
  913. !! * If True [default] then no special checks
  914. !! are done to check for duplicate keys.
  915. !! * If False, then after parsing, if any duplicate
  916. !! keys are found, an error is thrown. A call to
  917. !! [[json_value_validate]] will also check for
  918. !! duplicates.
  919. logical(LK),intent(in),optional :: escape_solidus
  920. !! * If True then the solidus "`/`" is always escaped
  921. !! "`\/`" when serializing JSON
  922. !! * If False [default], then it is not escaped.
  923. !!
  924. !! Note that this option does not affect parsing
  925. !! (both escaped and unescaped are still valid in
  926. !! all cases).
  927. logical(LK),intent(in),optional :: stop_on_error
  928. !! If an exception is raised, then immediately quit.
  929. !! (Default is False).
  930. integer(IK),intent(in),optional :: null_to_real_mode
  931. !! if `strict_type_checking=false`:
  932. !!
  933. !! * 1 : an exception will be raised if
  934. !! try to retrieve a `null` as a real.
  935. !! * 2 : a `null` retrieved as a real
  936. !! will return a NaN. [default]
  937. !! * 3 : a `null` retrieved as a real
  938. !! will return 0.0.
  939. integer(IK),intent(in),optional :: non_normal_mode
  940. !! How to serialize NaN, Infinity, and
  941. !! -Infinity real values:
  942. !!
  943. !! * 1 : as strings (e.g., "NaN",
  944. !! "Infinity", "-Infinity") [default]
  945. !! * 2 : as JSON `null` values
  946. logical(LK),intent(in),optional :: use_quiet_nan
  947. !! * If true [default], `null_to_real_mode=2`
  948. !! and [[string_to_real]] will use
  949. !! `ieee_quiet_nan` for NaN values.
  950. !! * If false,
  951. !! `ieee_signaling_nan` will be used.
  952. logical(LK),intent(in),optional :: strict_integer_type_checking
  953. !! * If false, when parsing JSON, if an integer numeric value
  954. !! cannot be converted to an integer (`integer(IK)`),
  955. !! then an attempt is then make to convert it
  956. !! to a real (`real(RK)`).
  957. !! * If true, an exception will be raised if the integer
  958. !! value cannot be read.
  959. !!
  960. !! (default is true)
  961. # 989 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  962. call json_core_object%initialize(&
  963. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_initialize_dummy_arguments.inc" 1
  964. ! The dummy argument list for the various `initialize` subroutines.
  965. !
  966. ! See also: json_initialize_argument.inc
  967. verbose,&
  968. compact_reals,&
  969. print_signs,&
  970. real_format,&
  971. spaces_per_tab,&
  972. strict_type_checking,&
  973. trailing_spaces_significant,&
  974. case_sensitive_keys,&
  975. no_whitespace,&
  976. unescape_strings,&
  977. comment_char,&
  978. path_mode,&
  979. path_separator,&
  980. compress_vectors,&
  981. allow_duplicate_keys,&
  982. escape_solidus,&
  983. stop_on_error,&
  984. null_to_real_mode,&
  985. non_normal_mode,&
  986. use_quiet_nan, &
  987. strict_integer_type_checking &
  988. # 992 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  989. )
  990. end function initialize_json_core
  991. !*****************************************************************************************
  992. !*****************************************************************************************
  993. !> author: Jacob Williams
  994. ! date: 12/4/2013
  995. !
  996. ! Initialize the [[json_core(type)]] instance.
  997. !
  998. ! The routine may be called before any of the [[json_core(type)]] methods are used in
  999. ! order to specify certain parameters. If it is not called, then the defaults
  1000. ! are used. This routine is also called internally by various routines.
  1001. ! It can also be called to clear exceptions, or to reset some
  1002. ! of the variables (note that only the arguments present are changed).
  1003. !
  1004. !### Modified
  1005. ! * Izaak Beekman : 02/24/2015
  1006. !
  1007. !@note [[initialize_json_core]], [[json_initialize]],
  1008. ! [[initialize_json_core_in_file]], and [[initialize_json_file]]
  1009. ! all have a similar interface.
  1010. subroutine json_initialize(me,&
  1011. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_initialize_dummy_arguments.inc" 1
  1012. ! The dummy argument list for the various `initialize` subroutines.
  1013. !
  1014. ! See also: json_initialize_argument.inc
  1015. verbose,&
  1016. compact_reals,&
  1017. print_signs,&
  1018. real_format,&
  1019. spaces_per_tab,&
  1020. strict_type_checking,&
  1021. trailing_spaces_significant,&
  1022. case_sensitive_keys,&
  1023. no_whitespace,&
  1024. unescape_strings,&
  1025. comment_char,&
  1026. path_mode,&
  1027. path_separator,&
  1028. compress_vectors,&
  1029. allow_duplicate_keys,&
  1030. escape_solidus,&
  1031. stop_on_error,&
  1032. null_to_real_mode,&
  1033. non_normal_mode,&
  1034. use_quiet_nan, &
  1035. strict_integer_type_checking &
  1036. # 1018 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  1037. )
  1038. implicit none
  1039. class(json_core),intent(inout) :: me
  1040. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_initialize_arguments.inc" 1
  1041. ! The argument list for the various `initialize` subroutines.
  1042. !
  1043. ! See also: json_initialize_dummy_arguments.inc
  1044. logical(LK),intent(in),optional :: verbose
  1045. !! mainly useful for debugging (default is false)
  1046. logical(LK),intent(in),optional :: compact_reals
  1047. !! to compact the real number strings for output (default is true)
  1048. logical(LK),intent(in),optional :: print_signs
  1049. !! always print numeric sign (default is false)
  1050. character(kind=CDK,len=*),intent(in),optional :: real_format
  1051. !! Real number format: 'E' [default], '*', 'G', 'EN', or 'ES'
  1052. integer(IK),intent(in),optional :: spaces_per_tab
  1053. !! number of spaces per tab for indenting (default is 2)
  1054. logical(LK),intent(in),optional :: strict_type_checking
  1055. !! if true, no integer, double, or logical type
  1056. !! conversions are done for the `get` routines
  1057. !! (default is false).
  1058. logical(LK),intent(in),optional :: trailing_spaces_significant
  1059. !! for name and path comparisons, is trailing
  1060. !! space to be considered significant.
  1061. !! (default is false)
  1062. logical(LK),intent(in),optional :: case_sensitive_keys
  1063. !! for name and path comparisons, are they
  1064. !! case sensitive. (default is true)
  1065. logical(LK),intent(in),optional :: no_whitespace
  1066. !! if true, printing the JSON structure is
  1067. !! done without adding any non-significant
  1068. !! spaces or linebreaks (default is false)
  1069. logical(LK),intent(in),optional :: unescape_strings
  1070. !! If false, then the raw escaped
  1071. !! string is returned from [[json_get_string]]
  1072. !! and similar routines. If true [default],
  1073. !! then the string is returned unescaped.
  1074. character(kind=CK,len=*),intent(in),optional :: comment_char
  1075. !! If present, these characters are used
  1076. !! to denote comments in the JSON file,
  1077. !! which will be ignored if present.
  1078. !! Example: `!`, `#`, or `/!#`. Setting this
  1079. !! to a blank string disables the
  1080. !! ignoring of comments. (Default is `/!#`).
  1081. integer(IK),intent(in),optional :: path_mode
  1082. !! How the path strings are interpreted in the
  1083. !! `get_by_path` routines:
  1084. !!
  1085. !! * 1 : Default mode (see [[json_get_by_path_default]])
  1086. !! * 2 : as RFC 6901 "JSON Pointer" paths
  1087. !! (see [[json_get_by_path_rfc6901]])
  1088. !! * 3 : JSONPath "bracket-notation"
  1089. !! see [[json_get_by_path_jsonpath_bracket]])
  1090. character(kind=CK,len=1),intent(in),optional :: path_separator
  1091. !! The `path` separator to use
  1092. !! in the "default" mode for
  1093. !! the paths in the various
  1094. !! `get_by_path` routines.
  1095. !! Example: `.` [default] or `%`.
  1096. !! Note: if `path_mode/=1`
  1097. !! then this is ignored.
  1098. logical(LK),intent(in),optional :: compress_vectors
  1099. !! If true, then arrays of integers,
  1100. !! nulls, doubles, and logicals are
  1101. !! printed all on one line.
  1102. !! [Note: `no_whitespace` will
  1103. !! override this option if necessary].
  1104. !! (Default is False).
  1105. logical(LK),intent(in),optional :: allow_duplicate_keys
  1106. !! * If True [default] then no special checks
  1107. !! are done to check for duplicate keys.
  1108. !! * If False, then after parsing, if any duplicate
  1109. !! keys are found, an error is thrown. A call to
  1110. !! [[json_value_validate]] will also check for
  1111. !! duplicates.
  1112. logical(LK),intent(in),optional :: escape_solidus
  1113. !! * If True then the solidus "`/`" is always escaped
  1114. !! "`\/`" when serializing JSON
  1115. !! * If False [default], then it is not escaped.
  1116. !!
  1117. !! Note that this option does not affect parsing
  1118. !! (both escaped and unescaped are still valid in
  1119. !! all cases).
  1120. logical(LK),intent(in),optional :: stop_on_error
  1121. !! If an exception is raised, then immediately quit.
  1122. !! (Default is False).
  1123. integer(IK),intent(in),optional :: null_to_real_mode
  1124. !! if `strict_type_checking=false`:
  1125. !!
  1126. !! * 1 : an exception will be raised if
  1127. !! try to retrieve a `null` as a real.
  1128. !! * 2 : a `null` retrieved as a real
  1129. !! will return a NaN. [default]
  1130. !! * 3 : a `null` retrieved as a real
  1131. !! will return 0.0.
  1132. integer(IK),intent(in),optional :: non_normal_mode
  1133. !! How to serialize NaN, Infinity, and
  1134. !! -Infinity real values:
  1135. !!
  1136. !! * 1 : as strings (e.g., "NaN",
  1137. !! "Infinity", "-Infinity") [default]
  1138. !! * 2 : as JSON `null` values
  1139. logical(LK),intent(in),optional :: use_quiet_nan
  1140. !! * If true [default], `null_to_real_mode=2`
  1141. !! and [[string_to_real]] will use
  1142. !! `ieee_quiet_nan` for NaN values.
  1143. !! * If false,
  1144. !! `ieee_signaling_nan` will be used.
  1145. logical(LK),intent(in),optional :: strict_integer_type_checking
  1146. !! * If false, when parsing JSON, if an integer numeric value
  1147. !! cannot be converted to an integer (`integer(IK)`),
  1148. !! then an attempt is then make to convert it
  1149. !! to a real (`real(RK)`).
  1150. !! * If true, an exception will be raised if the integer
  1151. !! value cannot be read.
  1152. !!
  1153. !! (default is true)
  1154. # 1024 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  1155. character(kind=CDK,len=10) :: w !! max string length
  1156. character(kind=CDK,len=10) :: d !! real precision digits
  1157. character(kind=CDK,len=10) :: e !! real exponent digits
  1158. character(kind=CDK,len=2) :: sgn !! sign flag: `ss` or `sp`
  1159. character(kind=CDK,len=2) :: rl_edit_desc !! `G`, `E`, `EN`, or `ES`
  1160. integer(IK) :: istat !! `iostat` flag for
  1161. !! write statements
  1162. logical(LK) :: sgn_prnt !! print sign flag
  1163. character(kind=CK,len=max_integer_str_len) :: istr !! for integer to
  1164. !! string conversion
  1165. !reset exception to false:
  1166. call me%clear_exceptions()
  1167. !Just in case, clear these global variables also:
  1168. me%pushed_index = 0
  1169. me%pushed_char = CK_''
  1170. me%char_count = 0
  1171. me%line_count = 1
  1172. me%ipos = 1
  1173. if (use_unformatted_stream) then
  1174. me%filesize = 0
  1175. me%ichunk = 0
  1176. me%chunk = repeat(space, stream_chunk_size) ! default chunk size
  1177. end if
  1178. # 1055
  1179. !various optional inputs:
  1180. if (present(spaces_per_tab)) &
  1181. me%spaces_per_tab = spaces_per_tab
  1182. if (present(stop_on_error)) &
  1183. me%stop_on_error = stop_on_error
  1184. if (present(verbose)) &
  1185. me%is_verbose = verbose
  1186. if (present(strict_type_checking)) &
  1187. me%strict_type_checking = strict_type_checking
  1188. if (present(trailing_spaces_significant)) &
  1189. me%trailing_spaces_significant = trailing_spaces_significant
  1190. if (present(case_sensitive_keys)) &
  1191. me%case_sensitive_keys = case_sensitive_keys
  1192. if (present(no_whitespace)) &
  1193. me%no_whitespace = no_whitespace
  1194. if (present(unescape_strings)) &
  1195. me%unescaped_strings = unescape_strings
  1196. if (present(path_mode)) then
  1197. if (path_mode==1_IK .or. path_mode==2_IK .or. path_mode==3_IK) then
  1198. me%path_mode = path_mode
  1199. else
  1200. me%path_mode = 1_IK ! just to have a valid value
  1201. call me%throw_exception('Invalid path_mode.')
  1202. end if
  1203. end if
  1204. ! if we are allowing comments in the file:
  1205. ! [an empty string disables comments]
  1206. if (present(comment_char)) then
  1207. me%allow_comments = comment_char/=CK_''
  1208. me%comment_char = trim(adjustl(comment_char))
  1209. end if
  1210. ! path separator:
  1211. if (present(path_separator)) then
  1212. me%path_separator = path_separator
  1213. end if
  1214. ! printing vectors in compressed form:
  1215. if (present(compress_vectors)) then
  1216. me%compress_vectors = compress_vectors
  1217. end if
  1218. ! checking for duplicate keys:
  1219. if (present(allow_duplicate_keys)) then
  1220. me%allow_duplicate_keys = allow_duplicate_keys
  1221. end if
  1222. ! if escaping the forward slash:
  1223. if (present(escape_solidus)) then
  1224. me%escape_solidus = escape_solidus
  1225. end if
  1226. ! how to handle null to read conversions:
  1227. if (present(null_to_real_mode)) then
  1228. select case (null_to_real_mode)
  1229. case(1_IK:3_IK)
  1230. me%null_to_real_mode = null_to_real_mode
  1231. case default
  1232. me%null_to_real_mode = 2_IK ! just to have a valid value
  1233. call integer_to_string(null_to_real_mode,int_fmt,istr)
  1234. call me%throw_exception('Invalid null_to_real_mode: '//istr)
  1235. end select
  1236. end if
  1237. ! how to handle NaN and Infinities:
  1238. if (present(non_normal_mode)) then
  1239. select case (non_normal_mode)
  1240. case(1_IK) ! use strings
  1241. me%non_normals_to_null = .false.
  1242. case(2_IK) ! use null
  1243. me%non_normals_to_null = .true.
  1244. case default
  1245. call integer_to_string(non_normal_mode,int_fmt,istr)
  1246. call me%throw_exception('Invalid non_normal_mode: '//istr)
  1247. end select
  1248. end if
  1249. if (present(use_quiet_nan)) then
  1250. me%use_quiet_nan = use_quiet_nan
  1251. end if
  1252. if (present(strict_integer_type_checking)) then
  1253. me%strict_integer_type_checking = strict_integer_type_checking
  1254. end if
  1255. !Set the format for real numbers:
  1256. ! [if not changing it, then it remains the same]
  1257. if ( (.not. allocated(me%real_fmt)) .or. & ! if this hasn't been done yet
  1258. present(compact_reals) .or. &
  1259. present(print_signs) .or. &
  1260. present(real_format) ) then
  1261. !allow the special case where real format is '*':
  1262. ! [this overrides the other options]
  1263. if (present(real_format)) then
  1264. if (real_format==star) then
  1265. if (present(compact_reals)) then
  1266. ! we will also allow for compact reals with
  1267. ! '*' format, if both arguments are present.
  1268. me%compact_real = compact_reals
  1269. else
  1270. me%compact_real = .false.
  1271. end if
  1272. me%real_fmt = star
  1273. return
  1274. end if
  1275. end if
  1276. if (present(compact_reals)) me%compact_real = compact_reals
  1277. !set defaults
  1278. sgn_prnt = .false.
  1279. if ( present( print_signs) ) sgn_prnt = print_signs
  1280. if ( sgn_prnt ) then
  1281. sgn = 'sp'
  1282. else
  1283. sgn = 'ss'
  1284. end if
  1285. rl_edit_desc = 'E'
  1286. if ( present( real_format ) ) then
  1287. select case ( real_format )
  1288. case ('g','G','e','E','en','EN','es','ES')
  1289. rl_edit_desc = real_format
  1290. case default
  1291. call me%throw_exception('Invalid real format, "' // &
  1292. trim(real_format) // '", passed to json_initialize.'// &
  1293. new_line('a') // 'Acceptable formats are: "G", "E", "EN", and "ES".' )
  1294. end select
  1295. end if
  1296. ! set the default output/input format for reals:
  1297. write(w,'(ss,I0)',iostat=istat) max_numeric_str_len
  1298. if (istat==0) write(d,'(ss,I0)',iostat=istat) real_precision
  1299. if (istat==0) write(e,'(ss,I0)',iostat=istat) real_exponent_digits
  1300. if (istat==0) then
  1301. me%real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) //&
  1302. trim(w) // '.' // trim(d) // 'E' // trim(e) // ')'
  1303. else
  1304. me%real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) // &
  1305. '27.17E4)' !just use this one (should never happen)
  1306. end if
  1307. end if
  1308. end subroutine json_initialize
  1309. !*****************************************************************************************
  1310. !*****************************************************************************************
  1311. !> author: Jacob Williams
  1312. !
  1313. ! Returns true if `name` is equal to `p%name`, using the specified
  1314. ! settings for case sensitivity and trailing whitespace.
  1315. !
  1316. !### History
  1317. ! * 4/30/2016 : original version
  1318. ! * 8/25/2017 : now just a wrapper for [[name_strings_equal]]
  1319. function name_equal(json,p,name) result(is_equal)
  1320. implicit none
  1321. class(json_core),intent(inout) :: json
  1322. type(json_value),intent(in) :: p !! the json object
  1323. character(kind=CK,len=*),intent(in) :: name !! the name to check for
  1324. logical(LK) :: is_equal !! true if the string are
  1325. !! lexically equal
  1326. if (allocated(p%name)) then
  1327. ! call the low-level routines for the name strings:
  1328. is_equal = json%name_strings_equal(p%name,name)
  1329. else
  1330. is_equal = name == CK_'' ! check a blank name
  1331. end if
  1332. end function name_equal
  1333. !*****************************************************************************************
  1334. !*****************************************************************************************
  1335. !> author: Jacob Williams
  1336. ! date: 8/25/2017
  1337. !
  1338. ! Returns true if the name strings `name1` is equal to `name2`, using
  1339. ! the specified settings for case sensitivity and trailing whitespace.
  1340. function name_strings_equal(json,name1,name2) result(is_equal)
  1341. implicit none
  1342. class(json_core),intent(inout) :: json
  1343. character(kind=CK,len=*),intent(in) :: name1 !! the name to check
  1344. character(kind=CK,len=*),intent(in) :: name2 !! the name to check
  1345. logical(LK) :: is_equal !! true if the string are
  1346. !! lexically equal
  1347. !must be the same length if we are treating
  1348. !trailing spaces as significant, so do a
  1349. !quick test of this first:
  1350. if (json%trailing_spaces_significant) then
  1351. is_equal = len(name1) == len(name2)
  1352. if (.not. is_equal) return
  1353. end if
  1354. if (json%case_sensitive_keys) then
  1355. is_equal = name1 == name2
  1356. else
  1357. is_equal = lowercase_string(name1) == lowercase_string(name2)
  1358. end if
  1359. end function name_strings_equal
  1360. !*****************************************************************************************
  1361. !*****************************************************************************************
  1362. !> author: Jacob Williams
  1363. ! date: 10/31/2015
  1364. !
  1365. ! Create a deep copy of a [[json_value]] linked-list structure.
  1366. !
  1367. !### Notes
  1368. !
  1369. ! * If `from` has children, then they are also cloned.
  1370. ! * The parent of `from` is not linked to `to`.
  1371. ! * If `from` is an element of an array, then the previous and
  1372. ! next entries are not cloned (only that element and it's children, if any).
  1373. !
  1374. !### Example
  1375. !
  1376. !````fortran
  1377. ! program test
  1378. ! use json_module
  1379. ! implicit none
  1380. ! type(json_core) :: json
  1381. ! type(json_value),pointer :: j1, j2
  1382. ! call json%load('../files/inputs/test1.json',j1)
  1383. ! call json%clone(j1,j2) !now have two independent copies
  1384. ! call json%destroy(j1) !destroys j1, but j2 remains
  1385. ! call json%print(j2,'j2.json')
  1386. ! call json%destroy(j2)
  1387. ! end program test
  1388. !````
  1389. subroutine json_clone(json,from,to)
  1390. implicit none
  1391. class(json_core),intent(inout) :: json
  1392. type(json_value),pointer :: from !! this is the structure to clone
  1393. type(json_value),pointer :: to !! the clone is put here
  1394. !! (it must not already be associated)
  1395. !call the main function:
  1396. call json%json_value_clone_func(from,to)
  1397. end subroutine json_clone
  1398. !*****************************************************************************************
  1399. !*****************************************************************************************
  1400. !> author: Jacob Williams
  1401. ! date: 10/31/2015
  1402. !
  1403. ! Recursive deep copy function called by [[json_clone]].
  1404. !
  1405. !@note If new data is added to the [[json_value]] type,
  1406. ! then this would need to be updated.
  1407. recursive subroutine json_value_clone_func(from,to,parent,previous,tail)
  1408. implicit none
  1409. type(json_value),pointer :: from !! this is the structure to clone
  1410. type(json_value),pointer :: to !! the clone is put here (it
  1411. !! must not already be associated)
  1412. type(json_value),pointer,optional :: parent !! to%parent
  1413. type(json_value),pointer,optional :: previous !! to%previous
  1414. logical,optional :: tail !! if "to" is the tail of
  1415. !! its parent's children
  1416. nullify(to)
  1417. if (associated(from)) then
  1418. allocate(to)
  1419. !copy over the data variables:
  1420. ! [note: the allocate() statements don't work here for the
  1421. ! deferred-length characters in gfortran-4.9]
  1422. if (allocated(from%name)) to%name = from%name
  1423. if (allocated(from%dbl_value)) allocate(to%dbl_value,source=from%dbl_value)
  1424. if (allocated(from%log_value)) allocate(to%log_value,source=from%log_value)
  1425. if (allocated(from%str_value)) to%str_value = from%str_value
  1426. if (allocated(from%int_value)) allocate(to%int_value,source=from%int_value)
  1427. to%var_type = from%var_type
  1428. to%n_children = from%n_children
  1429. ! allocate and associate the pointers as necessary:
  1430. if (present(parent)) to%parent => parent
  1431. if (present(previous)) to%previous => previous
  1432. if (present(tail)) then
  1433. if (tail .and. associated(to%parent)) to%parent%tail => to
  1434. end if
  1435. if (associated(from%next) .and. associated(to%parent)) then
  1436. ! we only clone the next entry in an array
  1437. ! if the parent has also been cloned
  1438. call json_value_clone_func(from = from%next,&
  1439. to = to%next,&
  1440. previous = to,&
  1441. parent = to%parent,&
  1442. tail = (.not. associated(from%next%next)))
  1443. end if
  1444. if (associated(from%children)) then
  1445. call json_value_clone_func(from = from%children,&
  1446. to = to%children,&
  1447. parent = to,&
  1448. tail = (.not. associated(from%children%next)))
  1449. end if
  1450. end if
  1451. end subroutine json_value_clone_func
  1452. !*****************************************************************************************
  1453. !*****************************************************************************************
  1454. !> author: Jacob Williams
  1455. !
  1456. ! Destroy the data within a [[json_value]], and reset type to `json_unknown`.
  1457. pure subroutine destroy_json_data(d)
  1458. implicit none
  1459. type(json_value),intent(inout) :: d
  1460. d%var_type = json_unknown
  1461. if (allocated(d%log_value)) deallocate(d%log_value)
  1462. if (allocated(d%int_value)) deallocate(d%int_value)
  1463. if (allocated(d%dbl_value)) deallocate(d%dbl_value)
  1464. if (allocated(d%str_value)) deallocate(d%str_value)
  1465. end subroutine destroy_json_data
  1466. !*****************************************************************************************
  1467. !*****************************************************************************************
  1468. !> author: Jacob Williams
  1469. ! date: 2/13/2014
  1470. !
  1471. ! Returns information about a [[json_value]].
  1472. subroutine json_info(json,p,var_type,n_children,name)
  1473. implicit none
  1474. class(json_core),intent(inout) :: json
  1475. type(json_value),pointer :: p
  1476. integer(IK),intent(out),optional :: var_type !! variable type
  1477. integer(IK),intent(out),optional :: n_children !! number of children
  1478. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1479. if (.not. json%exception_thrown .and. associated(p)) then
  1480. if (present(var_type)) var_type = p%var_type
  1481. if (present(n_children)) n_children = json%count(p)
  1482. if (present(name)) then
  1483. if (allocated(p%name)) then
  1484. name = p%name
  1485. else
  1486. name = CK_''
  1487. end if
  1488. end if
  1489. else ! error
  1490. if (.not. json%exception_thrown) then
  1491. call json%throw_exception('Error in json_info: '//&
  1492. 'pointer is not associated.' )
  1493. end if
  1494. if (present(var_type)) var_type = json_unknown
  1495. if (present(n_children)) n_children = 0
  1496. if (present(name)) name = CK_''
  1497. end if
  1498. end subroutine json_info
  1499. !*****************************************************************************************
  1500. !*****************************************************************************************
  1501. !> author: Jacob Williams
  1502. ! date: 12/18/2016
  1503. !
  1504. ! Returns information about character strings returned from a [[json_value]].
  1505. subroutine json_string_info(json,p,ilen,max_str_len,found)
  1506. implicit none
  1507. class(json_core),intent(inout) :: json
  1508. type(json_value),pointer :: p
  1509. integer(IK),dimension(:),allocatable,intent(out),optional :: ilen !! if `p` is an array, this
  1510. !! is the actual length
  1511. !! of each character
  1512. !! string in the array.
  1513. !! if not an array, this
  1514. !! is returned unallocated.
  1515. integer(IK),intent(out),optional :: max_str_len !! The maximum length required to
  1516. !! hold the string representation returned
  1517. !! by a call to a `get` routine. If a scalar,
  1518. !! this is just the length of the scalar. If
  1519. !! a vector, this is the maximum length of
  1520. !! any element.
  1521. logical(LK),intent(out),optional :: found !! true if there were no errors.
  1522. !! if not present, an error will
  1523. !! throw an exception
  1524. character(kind=CK,len=:),allocatable :: cval !! for getting values as strings.
  1525. logical(LK) :: initialized !! if the output array has been sized
  1526. logical(LK) :: get_max_len !! if we are returning the `max_str_len`
  1527. logical(LK) :: get_ilen !! if we are returning the `ilen` array
  1528. integer(IK) :: var_type !! variable type
  1529. get_max_len = present(max_str_len)
  1530. get_ilen = present(ilen)
  1531. if (.not. json%exception_thrown) then
  1532. if (present(found)) found = .true.
  1533. initialized = .false.
  1534. if (get_max_len) max_str_len = 0
  1535. select case (p%var_type)
  1536. case (json_array) ! it's an array
  1537. ! call routine for each element
  1538. call json%get(p, array_callback=get_string_lengths)
  1539. case default ! not an array
  1540. if (json%strict_type_checking) then
  1541. ! only allowing strings to be returned
  1542. ! as strings, so we can check size directly
  1543. call json%info(p,var_type=var_type)
  1544. if (var_type==json_string) then
  1545. if (allocated(p%str_value) .and. get_max_len) &
  1546. max_str_len = len(p%str_value)
  1547. else
  1548. ! it isn't a string, so there is no length
  1549. call json%throw_exception('Error in json_string_info: '//&
  1550. 'When strict_type_checking is true '//&
  1551. 'the variable must be a character string.',&
  1552. found)
  1553. end if
  1554. else
  1555. ! in this case, we have to get the value
  1556. ! as a string to know what size it is.
  1557. call json%get(p, value=cval)
  1558. if (.not. json%exception_thrown) then
  1559. if (allocated(cval) .and. get_max_len) &
  1560. max_str_len = len(cval)
  1561. end if
  1562. end if
  1563. end select
  1564. end if
  1565. if (json%exception_thrown) then
  1566. if (present(found)) then
  1567. call json%clear_exceptions()
  1568. found = .false.
  1569. end if
  1570. if (get_max_len) max_str_len = 0
  1571. if (get_ilen) then
  1572. if (allocated(ilen)) deallocate(ilen)
  1573. end if
  1574. end if
  1575. contains
  1576. subroutine get_string_lengths(json, element, i, count)
  1577. !! callback function to call for each element in the array.
  1578. implicit none
  1579. class(json_core),intent(inout) :: json
  1580. type(json_value),pointer,intent(in) :: element
  1581. integer(IK),intent(in) :: i !! index
  1582. integer(IK),intent(in) :: count !! size of array
  1583. character(kind=CK,len=:),allocatable :: cval
  1584. integer(IK) :: var_type
  1585. if (json%exception_thrown) return
  1586. if (.not. initialized) then
  1587. if (get_ilen) allocate(ilen(count))
  1588. initialized = .true.
  1589. end if
  1590. if (json%strict_type_checking) then
  1591. ! only allowing strings to be returned
  1592. ! as strings, so we can check size directly
  1593. call json%info(element,var_type=var_type)
  1594. if (var_type==json_string) then
  1595. if (allocated(element%str_value)) then
  1596. if (get_max_len) then
  1597. if (len(element%str_value)>max_str_len) &
  1598. max_str_len = len(element%str_value)
  1599. end if
  1600. if (get_ilen) ilen(i) = len(element%str_value)
  1601. else
  1602. if (get_ilen) ilen(i) = 0
  1603. end if
  1604. else
  1605. ! it isn't a string, so there is no length
  1606. call json%throw_exception('Error in json_string_info: '//&
  1607. 'When strict_type_checking is true '//&
  1608. 'the array must contain only '//&
  1609. 'character strings.',found)
  1610. end if
  1611. else
  1612. ! in this case, we have to get the value
  1613. ! as a string to know what size it is.
  1614. call json%get(element, value=cval)
  1615. if (json%exception_thrown) return
  1616. if (allocated(cval)) then
  1617. if (get_max_len) then
  1618. if (len(cval)>max_str_len) max_str_len = len(cval)
  1619. end if
  1620. if (get_ilen) ilen(i) = len(cval)
  1621. else
  1622. if (get_ilen) ilen(i) = 0
  1623. end if
  1624. end if
  1625. end subroutine get_string_lengths
  1626. end subroutine json_string_info
  1627. !*****************************************************************************************
  1628. !*****************************************************************************************
  1629. !
  1630. ! Returns information about a [[json_value]], given the path.
  1631. !
  1632. !### See also
  1633. ! * [[json_info]]
  1634. !
  1635. !@note If `found` is present, no exceptions will be thrown if an
  1636. ! error occurs. Otherwise, an exception will be thrown if the
  1637. ! variable is not found.
  1638. subroutine json_info_by_path(json,p,path,found,var_type,n_children,name)
  1639. implicit none
  1640. class(json_core),intent(inout) :: json
  1641. type(json_value),pointer,intent(in) :: p !! a JSON linked list
  1642. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  1643. logical(LK),intent(out),optional :: found !! true if it was found
  1644. integer(IK),intent(out),optional :: var_type !! variable type
  1645. integer(IK),intent(out),optional :: n_children !! number of children
  1646. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1647. type(json_value),pointer :: p_var !! temporary pointer
  1648. logical(LK) :: ok !! if the variable was found
  1649. # 1629
  1650. call json%get(p,path,p_var,found)
  1651. !check if it was found:
  1652. if (present(found)) then
  1653. ok = found
  1654. else
  1655. ok = .not. json%exception_thrown
  1656. end if
  1657. if (.not. ok) then
  1658. if (present(var_type)) var_type = json_unknown
  1659. if (present(n_children)) n_children = 0
  1660. if (present(name)) name = CK_''
  1661. else
  1662. !get info:
  1663. # 1657
  1664. call json%info(p_var,var_type,n_children,name)
  1665. end if
  1666. end subroutine json_info_by_path
  1667. !*****************************************************************************************
  1668. !*****************************************************************************************
  1669. !>
  1670. ! Alternate version of [[json_info_by_path]] where "path" is kind=CDK.
  1671. subroutine wrap_json_info_by_path(json,p,path,found,var_type,n_children,name)
  1672. implicit none
  1673. class(json_core),intent(inout) :: json
  1674. type(json_value),pointer,intent(in) :: p !! a JSON linked list
  1675. character(kind=CDK,len=*),intent(in) :: path !! path to the variable
  1676. logical(LK),intent(out),optional :: found !! true if it was found
  1677. integer(IK),intent(out),optional :: var_type !! variable type
  1678. integer(IK),intent(out),optional :: n_children !! number of children
  1679. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1680. call json%info(p,to_unicode(path),found,var_type,n_children,name)
  1681. end subroutine wrap_json_info_by_path
  1682. !*****************************************************************************************
  1683. !*****************************************************************************************
  1684. !> author: Jacob Williams
  1685. ! date: 10/16/2015
  1686. !
  1687. ! Alternate version of [[json_info]] that returns matrix
  1688. ! information about a [[json_value]].
  1689. !
  1690. ! A [[json_value]] is a valid rank 2 matrix if all of the following are true:
  1691. !
  1692. ! * The var_type is *json_array*
  1693. ! * Each child is also a *json_array*, each of which has the same number of elements
  1694. ! * Each individual element has the same variable type (integer, logical, etc.)
  1695. !
  1696. ! The idea here is that if it is a valid matrix, it can be interoperable with
  1697. ! a Fortran rank 2 array of the same type.
  1698. !
  1699. !### Example
  1700. !
  1701. ! The following example is an array with `var_type=json_integer`,
  1702. ! `n_sets=3`, and `set_size=4`
  1703. !
  1704. !```json
  1705. ! {
  1706. ! "matrix": [
  1707. ! [1,2,3,4],
  1708. ! [5,6,7,8],
  1709. ! [9,10,11,12]
  1710. ! ]
  1711. ! }
  1712. !```
  1713. subroutine json_matrix_info(json,p,is_matrix,var_type,n_sets,set_size,name)
  1714. implicit none
  1715. class(json_core),intent(inout) :: json
  1716. type(json_value),pointer :: p !! a JSON linked list
  1717. logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
  1718. integer(IK),intent(out),optional :: var_type !! variable type of data in the matrix
  1719. !! (if all elements have the same type)
  1720. integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
  1721. !! rows if using row-major order)
  1722. integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
  1723. !! cols if using row-major order)
  1724. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1725. type(json_value),pointer :: p_row !! for getting a set
  1726. type(json_value),pointer :: p_element !! for getting an element in a set
  1727. integer(IK) :: vartype !! json variable type of `p`
  1728. integer(IK) :: row_vartype !! json variable type of a row
  1729. integer(IK) :: element_vartype !! json variable type of an element in a row
  1730. integer(IK) :: nr !! number of children of `p`
  1731. integer(IK) :: nc !! number of elements in first child of `p`
  1732. integer(IK) :: icount !! number of elements in a set
  1733. integer(IK) :: i !! counter
  1734. integer(IK) :: j !! counter
  1735. # 1745
  1736. !get info about the variable:
  1737. # 1758
  1738. call json%info(p,vartype,nr,name)
  1739. is_matrix = (vartype==json_array)
  1740. if (is_matrix) then
  1741. main : do i=1,nr
  1742. nullify(p_row)
  1743. call json%get_child(p,i,p_row)
  1744. if (.not. associated(p_row)) then
  1745. is_matrix = .false.
  1746. call json%throw_exception('Error in json_matrix_info: '//&
  1747. 'Malformed JSON linked list')
  1748. exit main
  1749. end if
  1750. call json%info(p_row,var_type=row_vartype,n_children=icount)
  1751. if (row_vartype==json_array) then
  1752. if (i==1) nc = icount !number of columns in first row
  1753. if (icount==nc) then !make sure each row has the same number of columns
  1754. !see if all the variables in this row are the same type:
  1755. do j=1,icount
  1756. nullify(p_element)
  1757. call json%get_child(p_row,j,p_element)
  1758. if (.not. associated(p_element)) then
  1759. is_matrix = .false.
  1760. call json%throw_exception('Error in json_matrix_info: '//&
  1761. 'Malformed JSON linked list')
  1762. exit main
  1763. end if
  1764. call json%info(p_element,var_type=element_vartype)
  1765. if (i==1 .and. j==1) vartype = element_vartype !type of first element
  1766. !in the row
  1767. if (vartype/=element_vartype) then
  1768. !not all variables are the same time
  1769. is_matrix = .false.
  1770. exit main
  1771. end if
  1772. end do
  1773. else
  1774. is_matrix = .false.
  1775. exit main
  1776. end if
  1777. else
  1778. is_matrix = .false.
  1779. exit main
  1780. end if
  1781. end do main
  1782. end if
  1783. if (is_matrix) then
  1784. if (present(var_type)) var_type = vartype
  1785. if (present(n_sets)) n_sets = nr
  1786. if (present(set_size)) set_size = nc
  1787. else
  1788. if (present(var_type)) var_type = json_unknown
  1789. if (present(n_sets)) n_sets = 0
  1790. if (present(set_size)) set_size = 0
  1791. end if
  1792. end subroutine json_matrix_info
  1793. !*****************************************************************************************
  1794. !*****************************************************************************************
  1795. !>
  1796. ! Returns matrix information about a [[json_value]], given the path.
  1797. !
  1798. !### See also
  1799. ! * [[json_matrix_info]]
  1800. !
  1801. !@note If `found` is present, no exceptions will be thrown if an
  1802. ! error occurs. Otherwise, an exception will be thrown if the
  1803. ! variable is not found.
  1804. subroutine json_matrix_info_by_path(json,p,path,is_matrix,found,&
  1805. var_type,n_sets,set_size,name)
  1806. implicit none
  1807. class(json_core),intent(inout) :: json
  1808. type(json_value),pointer :: p !! a JSON linked list
  1809. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  1810. logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
  1811. logical(LK),intent(out),optional :: found !! true if it was found
  1812. integer(IK),intent(out),optional :: var_type !! variable type of data in
  1813. !! the matrix (if all elements have
  1814. !! the same type)
  1815. integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
  1816. !! rows if using row-major order)
  1817. integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
  1818. !! cols if using row-major order)
  1819. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1820. type(json_value),pointer :: p_var
  1821. logical(LK) :: ok
  1822. # 1860
  1823. call json%get(p,path,p_var,found)
  1824. !check if it was found:
  1825. if (present(found)) then
  1826. ok = found
  1827. else
  1828. ok = .not. json%exception_thrown
  1829. end if
  1830. if (.not. ok) then
  1831. if (present(var_type)) var_type = json_unknown
  1832. if (present(n_sets)) n_sets = 0
  1833. if (present(set_size)) set_size = 0
  1834. if (present(name)) name = CK_''
  1835. else
  1836. !get info about the variable:
  1837. # 1889
  1838. call json%matrix_info(p_var,is_matrix,var_type,n_sets,set_size,name)
  1839. if (json%exception_thrown .and. present(found)) then
  1840. found = .false.
  1841. call json%clear_exceptions()
  1842. end if
  1843. end if
  1844. end subroutine json_matrix_info_by_path
  1845. !*****************************************************************************************
  1846. !*****************************************************************************************
  1847. !>
  1848. ! Alternate version of [[json_matrix_info_by_path]] where "path" is kind=CDK.
  1849. subroutine wrap_json_matrix_info_by_path(json,p,path,is_matrix,found,&
  1850. var_type,n_sets,set_size,name)
  1851. implicit none
  1852. class(json_core),intent(inout) :: json
  1853. type(json_value),pointer :: p !! a JSON linked list
  1854. character(kind=CDK,len=*),intent(in) :: path !! path to the variable
  1855. logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
  1856. logical(LK),intent(out),optional :: found !! true if it was found
  1857. integer(IK),intent(out),optional :: var_type !! variable type of data in
  1858. !! the matrix (if all elements have
  1859. !! the same type)
  1860. integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
  1861. !! rows if using row-major order)
  1862. integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
  1863. !! cols if using row-major order)
  1864. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1865. call json%matrix_info(p,to_unicode(path),is_matrix,found,var_type,n_sets,set_size,name)
  1866. end subroutine wrap_json_matrix_info_by_path
  1867. !*****************************************************************************************
  1868. !*****************************************************************************************
  1869. !> author: Jacob Williams
  1870. ! date: 4/29/2016
  1871. !
  1872. ! Rename a [[json_value]].
  1873. subroutine json_value_rename(json,p,name)
  1874. implicit none
  1875. class(json_core),intent(inout) :: json
  1876. type(json_value),pointer,intent(in) :: p
  1877. character(kind=CK,len=*),intent(in) :: name !! new variable name
  1878. if (json%trailing_spaces_significant) then
  1879. p%name = name
  1880. else
  1881. p%name = trim(name)
  1882. end if
  1883. end subroutine json_value_rename
  1884. !*****************************************************************************************
  1885. !*****************************************************************************************
  1886. !> author: Jacob Williams
  1887. ! date: 4/29/2016
  1888. !
  1889. ! Alternate version of [[json_value_rename]], where `name` is kind=CDK.
  1890. subroutine wrap_json_value_rename(json,p,name)
  1891. implicit none
  1892. class(json_core),intent(inout) :: json
  1893. type(json_value),pointer,intent(in) :: p
  1894. character(kind=CDK,len=*),intent(in) :: name !! new variable name
  1895. call json%rename(p,to_unicode(name))
  1896. end subroutine wrap_json_value_rename
  1897. !*****************************************************************************************
  1898. !*****************************************************************************************
  1899. !> author: Jacob Williams
  1900. ! date: 12/4/2013
  1901. !
  1902. ! Clear exceptions in the [[json_core(type)]].
  1903. pure subroutine json_clear_exceptions(json)
  1904. implicit none
  1905. class(json_core),intent(inout) :: json
  1906. !clear the flag and message:
  1907. json%exception_thrown = .false.
  1908. if (allocated(json%err_message)) deallocate(json%err_message)
  1909. end subroutine json_clear_exceptions
  1910. !*****************************************************************************************
  1911. !*****************************************************************************************
  1912. !> author: Jacob Williams
  1913. ! date: 12/4/2013
  1914. !
  1915. ! Throw an exception in the [[json_core(type)]].
  1916. ! This routine sets the error flag, and prevents any subsequent routine
  1917. ! from doing anything, until [[json_clear_exceptions]] is called.
  1918. !
  1919. !@note If `is_verbose` is true, this will also print a
  1920. ! traceback if the Intel compiler is used.
  1921. !
  1922. !@note If `stop_on_error` is true, then the program is stopped.
  1923. subroutine json_throw_exception(json,msg,found)
  1924. use ifcore, only: tracebackqq
  1925. implicit none
  1926. class(json_core),intent(inout) :: json
  1927. character(kind=CK,len=*),intent(in) :: msg !! the error message
  1928. logical(LK),intent(inout),optional :: found !! if the caller is handling the
  1929. !! exception with an optimal return
  1930. !! argument. If so, `json%stop_on_error`
  1931. !! is ignored.
  1932. logical(LK) :: stop_on_error
  1933. json%exception_thrown = .true.
  1934. json%err_message = trim(msg)
  1935. stop_on_error = json%stop_on_error .and. .not. present(found)
  1936. if (stop_on_error) then
  1937. ! for Intel, we raise a traceback and quit
  1938. call tracebackqq(string=trim(msg), user_exit_code=0)
  1939. # 2032
  1940. elseif (json%is_verbose) then
  1941. write(output_unit,'(A)') '***********************'
  1942. write(output_unit,'(A)') 'JSON-Fortran Exception: '//trim(msg)
  1943. !#if defined __GFORTRAN__
  1944. ! call backtrace() ! (have to compile with -fbacktrace -fall-intrinsics flags)
  1945. !#endif
  1946. call tracebackqq(user_exit_code=-1) ! print a traceback and return
  1947. write(output_unit,'(A)') '***********************'
  1948. end if
  1949. end subroutine json_throw_exception
  1950. !*****************************************************************************************
  1951. !*****************************************************************************************
  1952. !>
  1953. ! Alternate version of [[json_throw_exception]], where `msg` is kind=CDK.
  1954. subroutine wrap_json_throw_exception(json,msg,found)
  1955. implicit none
  1956. class(json_core),intent(inout) :: json
  1957. character(kind=CDK,len=*),intent(in) :: msg !! the error message
  1958. logical(LK),intent(inout),optional :: found !! if the caller is handling the
  1959. !! exception with an optimal return
  1960. !! argument. If so, `json%stop_on_error`
  1961. !! is ignored.
  1962. call json%throw_exception(to_unicode(msg),found)
  1963. end subroutine wrap_json_throw_exception
  1964. !*****************************************************************************************
  1965. !*****************************************************************************************
  1966. !> author: Jacob Williams
  1967. ! date: 12/4/2013
  1968. !
  1969. ! Retrieve error code from the [[json_core(type)]].
  1970. ! This should be called after `parse` to check for errors.
  1971. ! If an error is thrown, before using the class again, [[json_initialize]]
  1972. ! should be called to clean up before it is used again.
  1973. !
  1974. !### Example
  1975. !
  1976. !````fortran
  1977. ! type(json_file) :: json
  1978. ! logical :: status_ok
  1979. ! character(kind=CK,len=:),allocatable :: error_msg
  1980. ! call json%load(filename='myfile.json')
  1981. ! call json%check_for_errors(status_ok, error_msg)
  1982. ! if (.not. status_ok) then
  1983. ! write(*,*) 'Error: '//error_msg
  1984. ! call json%clear_exceptions()
  1985. ! call json%destroy()
  1986. ! end if
  1987. !````
  1988. !
  1989. !### See also
  1990. ! * [[json_failed]]
  1991. ! * [[json_throw_exception]]
  1992. subroutine json_check_for_errors(json,status_ok,error_msg)
  1993. implicit none
  1994. class(json_core),intent(in) :: json
  1995. logical(LK),intent(out),optional :: status_ok !! true if there were no errors
  1996. character(kind=CK,len=:),allocatable,intent(out),optional :: error_msg !! the error message.
  1997. !! (not allocated if
  1998. !! there were no errors)
  1999. # 2114
  2000. if (present(status_ok)) status_ok = .not. json%exception_thrown
  2001. if (present(error_msg)) then
  2002. if (json%exception_thrown) then
  2003. ! if an exception has been thrown,
  2004. ! then this will always be allocated
  2005. ! [see json_throw_exception]
  2006. # 2126
  2007. error_msg = json%err_message
  2008. end if
  2009. end if
  2010. end subroutine json_check_for_errors
  2011. !*****************************************************************************************
  2012. !*****************************************************************************************
  2013. !> author: Jacob Williams
  2014. ! date: 12/5/2013
  2015. !
  2016. ! Logical function to indicate if an exception has been thrown in a [[json_core(type)]].
  2017. !
  2018. !### Example
  2019. !
  2020. !````fortran
  2021. ! type(json_core) :: json
  2022. ! type(json_value),pointer :: p
  2023. ! logical :: status_ok
  2024. ! character(len=:),allocatable :: error_msg
  2025. ! call json%load(filename='myfile.json',p)
  2026. ! if (json%failed()) then
  2027. ! call json%check_for_errors(status_ok, error_msg)
  2028. ! write(*,*) 'Error: '//error_msg
  2029. ! call json%clear_exceptions()
  2030. ! call json%destroy(p)
  2031. ! end if
  2032. !````
  2033. !
  2034. ! Note that [[json_file]] contains a wrapper for this routine, which is used like:
  2035. !````fortran
  2036. ! type(json_file) :: f
  2037. ! logical :: status_ok
  2038. ! character(len=:),allocatable :: error_msg
  2039. ! call f%load(filename='myfile.json')
  2040. ! if (f%failed()) then
  2041. ! call f%check_for_errors(status_ok, error_msg)
  2042. ! write(*,*) 'Error: '//error_msg
  2043. ! call f%clear_exceptions()
  2044. ! call f%destroy()
  2045. ! end if
  2046. !````
  2047. !
  2048. !### See also
  2049. ! * [[json_check_for_errors]]
  2050. pure function json_failed(json) result(failed)
  2051. implicit none
  2052. class(json_core),intent(in) :: json
  2053. logical(LK) :: failed !! will be true if an exception
  2054. !! has been thrown.
  2055. failed = json%exception_thrown
  2056. end function json_failed
  2057. !*****************************************************************************************
  2058. !*****************************************************************************************
  2059. !>
  2060. ! Allocate a [[json_value]] pointer variable.
  2061. ! This should be called before adding data to it.
  2062. !
  2063. !### Example
  2064. !
  2065. !````fortran
  2066. ! type(json_value),pointer :: var
  2067. ! call json_value_create(var)
  2068. ! call json%to_real(var,1.0_RK)
  2069. !````
  2070. !
  2071. !### Notes
  2072. ! 1. This routine does not check for exceptions.
  2073. ! 2. The pointer should not already be allocated, or a memory leak will occur.
  2074. subroutine json_value_create(p)
  2075. implicit none
  2076. type(json_value),pointer :: p
  2077. nullify(p)
  2078. allocate(p)
  2079. end subroutine json_value_create
  2080. !*****************************************************************************************
  2081. !*****************************************************************************************
  2082. !> author: Jacob Williams
  2083. ! date: 1/22/2014
  2084. !
  2085. ! Destroy a [[json_value]] linked-list structure.
  2086. !
  2087. !@note The original FSON version of this
  2088. ! routine was not properly freeing the memory.
  2089. ! It was rewritten.
  2090. !
  2091. !@note This routine destroys this variable, it's children, and
  2092. ! (if `destroy_next` is true) the subsequent elements in
  2093. ! an object or array. It does not destroy the parent or
  2094. ! previous elements.
  2095. !
  2096. !@Note There is some protection here to enable destruction of
  2097. ! improperly-created linked lists. However, likely there
  2098. ! are cases not handled. Use the [[json_value_validate]]
  2099. ! method to validate a JSON structure that was manually
  2100. ! created using [[json_value]] pointers.
  2101. pure recursive subroutine json_value_destroy(json,p,destroy_next)
  2102. implicit none
  2103. class(json_core),intent(inout) :: json
  2104. type(json_value),pointer :: p !! variable to destroy
  2105. logical(LK),intent(in),optional :: destroy_next !! if true, then `p%next`
  2106. !! is also destroyed (default is true)
  2107. logical(LK) :: des_next !! local copy of `destroy_next`
  2108. !! optional argument
  2109. type(json_value),pointer :: child !! for getting child elements
  2110. logical :: circular !! to check to malformed linked lists
  2111. if (associated(p)) then
  2112. if (present(destroy_next)) then
  2113. des_next = destroy_next
  2114. else
  2115. des_next = .true.
  2116. end if
  2117. if (allocated(p%name)) deallocate(p%name)
  2118. call destroy_json_data(p)
  2119. if (associated(p%next)) then
  2120. ! check for circular references:
  2121. if (associated(p, p%next)) nullify(p%next)
  2122. end if
  2123. if (associated(p%children)) then
  2124. do while (p%n_children > 0)
  2125. child => p%children
  2126. if (associated(child)) then
  2127. p%children => p%children%next
  2128. p%n_children = p%n_children - 1
  2129. ! check children for circular references:
  2130. circular = (associated(p%children) .and. &
  2131. associated(p%children,child))
  2132. call json%destroy(child,destroy_next=.false.)
  2133. if (circular) exit
  2134. else
  2135. ! it is a malformed JSON object. But, we will
  2136. ! press ahead with the destroy process, since
  2137. ! otherwise, there would be no way to destroy it.
  2138. exit
  2139. end if
  2140. end do
  2141. nullify(p%children)
  2142. nullify(child)
  2143. end if
  2144. if (associated(p%next) .and. des_next) call json%destroy(p%next)
  2145. nullify(p%previous)
  2146. nullify(p%parent)
  2147. nullify(p%tail)
  2148. if (associated(p)) deallocate(p)
  2149. nullify(p)
  2150. end if
  2151. end subroutine json_value_destroy
  2152. !*****************************************************************************************
  2153. !*****************************************************************************************
  2154. !> author: Jacob Williams
  2155. ! date: 9/9/2014
  2156. !
  2157. ! Remove a [[json_value]] (and all its children)
  2158. ! from a linked-list structure, preserving the rest of the structure.
  2159. !
  2160. !### Examples
  2161. !
  2162. ! To extract an object from one JSON structure, and add it to another:
  2163. !````fortran
  2164. ! type(json_core) :: json
  2165. ! type(json_value),pointer :: json1,json2,p
  2166. ! logical :: found
  2167. ! !create and populate json1 and json2
  2168. ! call json%get(json1,'name',p,found) ! get pointer to name element of json1
  2169. ! call json%remove(p,destroy=.false.) ! remove it from json1 (don't destroy)
  2170. ! call json%add(json2,p) ! add it to json2
  2171. !````
  2172. !
  2173. ! To remove an object from a JSON structure (and destroy it):
  2174. !````fortran
  2175. ! type(json_core) :: json
  2176. ! type(json_value),pointer :: json1,p
  2177. ! logical :: found
  2178. ! !create and populate json1
  2179. ! call json%get(json1,'name',p,found) ! get pointer to name element of json1
  2180. ! call json%remove(p) ! remove and destroy it
  2181. !````
  2182. !
  2183. !### History
  2184. ! * Jacob Williams : 12/28/2014 : added destroy optional argument.
  2185. ! * Jacob Williams : 12/04/2020 : bug fix.
  2186. subroutine json_value_remove(json,p,destroy)
  2187. implicit none
  2188. class(json_core),intent(inout) :: json
  2189. type(json_value),pointer :: p
  2190. logical(LK),intent(in),optional :: destroy !! Option to destroy `p` after it is removed:
  2191. !!
  2192. !! * If `destroy` is not present, it is also destroyed.
  2193. !! * If `destroy` is present and true, it is destroyed.
  2194. !! * If `destroy` is present and false, it is not destroyed.
  2195. type(json_value),pointer :: parent !! pointer to parent
  2196. type(json_value),pointer :: previous !! pointer to previous
  2197. type(json_value),pointer :: next !! pointer to next
  2198. logical(LK) :: destroy_it !! if `p` should be destroyed
  2199. if (associated(p)) then
  2200. !optional input argument:
  2201. if (present(destroy)) then
  2202. destroy_it = destroy
  2203. else
  2204. destroy_it = .true.
  2205. end if
  2206. if (associated(p%parent)) then
  2207. parent => p%parent
  2208. if (associated(p%next)) then
  2209. !there are later items in the list:
  2210. next => p%next
  2211. if (associated(p%previous)) then
  2212. !there are earlier items in the list
  2213. previous => p%previous
  2214. previous%next => next
  2215. next%previous => previous
  2216. else
  2217. !this is the first item in the list
  2218. parent%children => next
  2219. nullify(next%previous)
  2220. end if
  2221. else
  2222. if (associated(p%previous)) then
  2223. !there are earlier items in the list:
  2224. previous => p%previous
  2225. nullify(previous%next)
  2226. parent%tail => previous
  2227. else
  2228. !this is the only item in the list:
  2229. nullify(parent%children)
  2230. nullify(parent%tail)
  2231. end if
  2232. end if
  2233. ! nullify all pointers to original structure:
  2234. nullify(p%next)
  2235. nullify(p%previous)
  2236. nullify(p%parent)
  2237. parent%n_children = parent%n_children - 1
  2238. end if
  2239. if (destroy_it) call json%destroy(p)
  2240. end if
  2241. end subroutine json_value_remove
  2242. !*****************************************************************************************
  2243. !*****************************************************************************************
  2244. !>
  2245. ! Replace `p1` with `p2` in a JSON structure.
  2246. !
  2247. !@note The replacement is done using an insert and remove
  2248. ! See [[json_value_insert_after]] and [[json_value_remove]]
  2249. ! for details.
  2250. subroutine json_value_replace(json,p1,p2,destroy)
  2251. implicit none
  2252. class(json_core),intent(inout) :: json
  2253. type(json_value),pointer :: p1 !! the item to replace
  2254. type(json_value),pointer :: p2 !! item to take the place of `p1`
  2255. logical(LK),intent(in),optional :: destroy !! Should `p1` also be destroyed
  2256. !! (default is True). Normally,
  2257. !! this should be true to avoid
  2258. !! a memory leak.
  2259. logical(LK) :: destroy_p1 !! if `p1` is to be destroyed
  2260. if (present(destroy)) then
  2261. destroy_p1 = destroy
  2262. else
  2263. destroy_p1 = .true. ! default
  2264. end if
  2265. call json%insert_after(p1,p2)
  2266. call json%remove(p1,destroy_p1)
  2267. end subroutine json_value_replace
  2268. !*****************************************************************************************
  2269. !*****************************************************************************************
  2270. !> author: Jacob Williams
  2271. ! date: 4/11/2017
  2272. !
  2273. ! Reverse the order of the children of an array or object.
  2274. subroutine json_value_reverse(json,p)
  2275. implicit none
  2276. class(json_core),intent(inout) :: json
  2277. type(json_value),pointer :: p
  2278. type(json_value),pointer :: tmp !! temp variable for traversing the list
  2279. type(json_value),pointer :: current !! temp variable for traversing the list
  2280. integer(IK) :: var_type !! for getting the variable type
  2281. if (associated(p)) then
  2282. call json%info(p,var_type=var_type)
  2283. ! can only reverse objects or arrays
  2284. if (var_type==json_object .or. var_type==json_array) then
  2285. nullify(tmp)
  2286. current => p%children
  2287. p%tail => current
  2288. ! Swap next and previous for all nodes:
  2289. do
  2290. if (.not. associated(current)) exit
  2291. tmp => current%previous
  2292. current%previous => current%next
  2293. current%next => tmp
  2294. current => current%previous
  2295. end do
  2296. if (associated(tmp)) then
  2297. p%children => tmp%previous
  2298. end if
  2299. end if
  2300. end if
  2301. end subroutine json_value_reverse
  2302. !*****************************************************************************************
  2303. !*****************************************************************************************
  2304. !> author: Jacob Williams
  2305. ! date: 4/26/2016
  2306. !
  2307. ! Swap two elements in a JSON structure.
  2308. ! All of the children are carried along as well.
  2309. !
  2310. !@note If both are not associated, then an error is thrown.
  2311. !
  2312. !@note The assumption here is that both variables are part of a valid
  2313. ! [[json_value]] linked list (so the normal `parent`, `previous`,
  2314. ! `next`, etc. pointers are properly associated if necessary).
  2315. !
  2316. !@warning This cannot be used to swap a parent/child pair, since that
  2317. ! could lead to a circular linkage. An exception is thrown if
  2318. ! this is tried.
  2319. !
  2320. !@warning There are also other situations where using this routine may
  2321. ! produce a malformed JSON structure, such as moving an array
  2322. ! element outside of an array. This is not checked for.
  2323. !
  2324. !@note If `p1` and `p2` have a common parent, it is always safe to swap them.
  2325. subroutine json_value_swap(json,p1,p2)
  2326. implicit none
  2327. class(json_core),intent(inout) :: json
  2328. type(json_value),pointer :: p1 !! swap with `p2`
  2329. type(json_value),pointer :: p2 !! swap with `p1`
  2330. logical :: same_parent !! if `p1` and `p2` have the same parent
  2331. logical :: first_last !! if `p1` and `p2` are the first,last or
  2332. !! last,first children of a common parent
  2333. logical :: adjacent !! if `p1` and `p2` are adjacent
  2334. !! elements in an array
  2335. type(json_value),pointer :: a !! temporary variable
  2336. type(json_value),pointer :: b !! temporary variable
  2337. if (json%exception_thrown) return
  2338. !both have to be associated:
  2339. if (associated(p1) .and. associated(p2)) then
  2340. !simple check to make sure that they both
  2341. !aren't pointing to the same thing:
  2342. if (.not. associated(p1,p2)) then
  2343. !we will not allow swapping an item with one of its descendants:
  2344. if (json%is_child_of(p1,p2) .or. json%is_child_of(p2,p1)) then
  2345. call json%throw_exception('Error in json_value_swap: '//&
  2346. 'cannot swap an item with one of its descendants')
  2347. else
  2348. same_parent = ( associated(p1%parent) .and. &
  2349. associated(p2%parent) .and. &
  2350. associated(p1%parent,p2%parent) )
  2351. if (same_parent) then
  2352. first_last = (associated(p1%parent%children,p1) .and. &
  2353. associated(p2%parent%tail,p2)) .or. &
  2354. (associated(p1%parent%tail,p1) .and. &
  2355. associated(p2%parent%children,p2))
  2356. else
  2357. first_last = .false.
  2358. end if
  2359. !first, we fix children,tail pointers:
  2360. if (same_parent .and. first_last) then
  2361. !this is all we have to do for the parent in this case:
  2362. call swap_pointers(p1%parent%children,p2%parent%tail)
  2363. else if (same_parent .and. .not. first_last) then
  2364. if (associated(p1%parent%children,p1)) then
  2365. p1%parent%children => p2 ! p1 is the first child of the parent
  2366. else if (associated(p1%parent%children,p2)) then
  2367. p1%parent%children => p1 ! p2 is the first child of the parent
  2368. end if
  2369. if (associated(p1%parent%tail,p1)) then
  2370. p1%parent%tail => p2 ! p1 is the last child of the parent
  2371. else if (associated(p1%parent%tail,p2)) then
  2372. p1%parent%tail => p1 ! p2 is the last child of the parent
  2373. end if
  2374. else ! general case: different parents
  2375. if (associated(p1%parent)) then
  2376. if (associated(p1%parent%children,p1)) p1%parent%children => p2
  2377. if (associated(p1%parent%tail,p1)) p1%parent%tail => p2
  2378. end if
  2379. if (associated(p2%parent)) then
  2380. if (associated(p2%parent%children,p2)) p2%parent%children => p1
  2381. if (associated(p2%parent%tail,p2)) p2%parent%tail => p1
  2382. end if
  2383. call swap_pointers(p1%parent, p2%parent)
  2384. end if
  2385. !now, have to fix previous,next pointers:
  2386. !first, see if they are adjacent:
  2387. adjacent = associated(p1%next,p2) .or. &
  2388. associated(p2%next,p1)
  2389. if (associated(p2%next,p1)) then !p2,p1
  2390. a => p2
  2391. b => p1
  2392. else !p1,p2 (or not adjacent)
  2393. a => p1
  2394. b => p2
  2395. end if
  2396. if (associated(a%previous)) a%previous%next => b
  2397. if (associated(b%next)) b%next%previous => a
  2398. if (adjacent) then
  2399. !a comes before b in the original list
  2400. b%previous => a%previous
  2401. a%next => b%next
  2402. a%previous => b
  2403. b%next => a
  2404. else
  2405. if (associated(a%next)) a%next%previous => b
  2406. if (associated(b%previous)) b%previous%next => a
  2407. call swap_pointers(a%previous,b%previous)
  2408. call swap_pointers(a%next, b%next)
  2409. end if
  2410. end if
  2411. else
  2412. call json%throw_exception('Error in json_value_swap: '//&
  2413. 'both pointers must be associated')
  2414. end if
  2415. end if
  2416. contains
  2417. pure subroutine swap_pointers(s1,s2)
  2418. implicit none
  2419. type(json_value),pointer,intent(inout) :: s1
  2420. type(json_value),pointer,intent(inout) :: s2
  2421. type(json_value),pointer :: tmp !! temporary pointer
  2422. if (.not. associated(s1,s2)) then
  2423. tmp => s1
  2424. s1 => s2
  2425. s2 => tmp
  2426. end if
  2427. end subroutine swap_pointers
  2428. end subroutine json_value_swap
  2429. !*****************************************************************************************
  2430. !*****************************************************************************************
  2431. !> author: Jacob Williams
  2432. ! date: 4/28/2016
  2433. !
  2434. ! Returns True if `p2` is a descendant of `p1`
  2435. ! (i.e, a child, or a child of child, etc.)
  2436. function json_value_is_child_of(json,p1,p2) result(is_child_of)
  2437. implicit none
  2438. class(json_core),intent(inout) :: json
  2439. type(json_value),pointer :: p1
  2440. type(json_value),pointer :: p2
  2441. logical(LK) :: is_child_of
  2442. is_child_of = .false.
  2443. if (json%exception_thrown) return
  2444. if (associated(p1) .and. associated(p2)) then
  2445. if (associated(p1%children)) then
  2446. call json%traverse(p1%children,is_child_of_callback)
  2447. end if
  2448. end if
  2449. contains
  2450. subroutine is_child_of_callback(json,p,finished)
  2451. !! Traverse until `p` is `p2`.
  2452. implicit none
  2453. class(json_core),intent(inout) :: json
  2454. type(json_value),pointer,intent(in) :: p
  2455. logical(LK),intent(out) :: finished
  2456. is_child_of = associated(p,p2)
  2457. finished = is_child_of ! stop searching if found
  2458. end subroutine is_child_of_callback
  2459. end function json_value_is_child_of
  2460. !*****************************************************************************************
  2461. !*****************************************************************************************
  2462. !> author: Jacob Williams
  2463. ! date: 5/2/2016
  2464. !
  2465. ! Validate a [[json_value]] linked list by checking to make sure
  2466. ! all the pointers are properly associated, arrays and objects
  2467. ! have the correct number of children, and the correct data is
  2468. ! allocated for the variable types.
  2469. !
  2470. ! It recursively traverses the entire structure and checks every element.
  2471. !
  2472. !### History
  2473. ! * Jacob Williams, 8/26/2017 : added duplicate key check.
  2474. !
  2475. !@note It will return on the first error it encounters.
  2476. !
  2477. !@note This routine does not check or throw any exceptions.
  2478. ! If `json` is currently in a state of exception, it will
  2479. ! remain so after calling this routine.
  2480. subroutine json_value_validate(json,p,is_valid,error_msg)
  2481. implicit none
  2482. class(json_core),intent(inout) :: json
  2483. type(json_value),pointer,intent(in) :: p
  2484. logical(LK),intent(out) :: is_valid !! True if the structure is valid.
  2485. character(kind=CK,len=:),allocatable,intent(out) :: error_msg !! if not valid, this will contain
  2486. !! a description of the problem
  2487. logical(LK) :: has_duplicate !! to check for duplicate keys
  2488. character(kind=CK,len=:),allocatable :: path !! path to duplicate key
  2489. logical(LK) :: status_ok !! to check for existing exception
  2490. character(kind=CK,len=:),allocatable :: exception_msg !! error message for an existing exception
  2491. character(kind=CK,len=:),allocatable :: exception_msg2 !! error message for a new exception
  2492. if (associated(p)) then
  2493. is_valid = .true.
  2494. call check_if_valid(p,require_parent=associated(p%parent))
  2495. if (is_valid .and. .not. json%allow_duplicate_keys) then
  2496. ! if no errors so far, also check the
  2497. ! entire structure for duplicate keys:
  2498. ! note: check_for_duplicate_keys does call routines
  2499. ! that check and throw exceptions, so let's clear any
  2500. ! first. (save message for later)
  2501. call json%check_for_errors(status_ok, exception_msg)
  2502. call json%clear_exceptions()
  2503. call json%check_for_duplicate_keys(p,has_duplicate,path=path)
  2504. if (json%failed()) then
  2505. ! if an exception was thrown during this call,
  2506. ! then clear it but make that the error message
  2507. ! returned by this routine. Normally this should
  2508. ! never actually occur since we have already
  2509. ! validated the structure.
  2510. call json%check_for_errors(is_valid, exception_msg2)
  2511. error_msg = exception_msg2
  2512. call json%clear_exceptions()
  2513. is_valid = .false.
  2514. else
  2515. if (has_duplicate) then
  2516. error_msg = 'duplicate key found: '//path
  2517. is_valid = .false.
  2518. end if
  2519. end if
  2520. if (.not. status_ok) then
  2521. ! restore any existing exception if necessary
  2522. call json%throw_exception(exception_msg)
  2523. end if
  2524. ! cleanup:
  2525. if (allocated(path)) deallocate(path)
  2526. if (allocated(exception_msg)) deallocate(exception_msg)
  2527. if (allocated(exception_msg2)) deallocate(exception_msg2)
  2528. end if
  2529. else
  2530. error_msg = 'The pointer is not associated'
  2531. is_valid = .false.
  2532. end if
  2533. contains
  2534. recursive subroutine check_if_valid(p,require_parent)
  2535. implicit none
  2536. type(json_value),pointer,intent(in) :: p
  2537. logical,intent(in) :: require_parent !! the first one may be a root (so no parent),
  2538. !! but all descendants must have a parent.
  2539. integer(IK) :: i !! counter
  2540. type(json_value),pointer :: element
  2541. type(json_value),pointer :: previous
  2542. if (is_valid .and. associated(p)) then
  2543. ! data type:
  2544. select case (p%var_type)
  2545. case(json_null,json_object,json_array)
  2546. if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
  2547. allocated(p%dbl_value) .or. allocated(p%str_value)) then
  2548. error_msg = 'incorrect data allocated for '//&
  2549. 'json_null, json_object, or json_array variable type'
  2550. is_valid = .false.
  2551. return
  2552. end if
  2553. case(json_logical)
  2554. if (.not. allocated(p%log_value)) then
  2555. error_msg = 'log_value should be allocated for json_logical variable type'
  2556. is_valid = .false.
  2557. return
  2558. else if (allocated(p%int_value) .or. &
  2559. allocated(p%dbl_value) .or. allocated(p%str_value)) then
  2560. error_msg = 'incorrect data allocated for json_logical variable type'
  2561. is_valid = .false.
  2562. return
  2563. end if
  2564. case(json_integer)
  2565. if (.not. allocated(p%int_value)) then
  2566. error_msg = 'int_value should be allocated for json_integer variable type'
  2567. is_valid = .false.
  2568. return
  2569. else if (allocated(p%log_value) .or. &
  2570. allocated(p%dbl_value) .or. allocated(p%str_value)) then
  2571. error_msg = 'incorrect data allocated for json_integer variable type'
  2572. is_valid = .false.
  2573. return
  2574. end if
  2575. case(json_real)
  2576. if (.not. allocated(p%dbl_value)) then
  2577. error_msg = 'dbl_value should be allocated for json_real variable type'
  2578. is_valid = .false.
  2579. return
  2580. else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
  2581. allocated(p%str_value)) then
  2582. error_msg = 'incorrect data allocated for json_real variable type'
  2583. is_valid = .false.
  2584. return
  2585. end if
  2586. case(json_string)
  2587. if (.not. allocated(p%str_value)) then
  2588. error_msg = 'str_value should be allocated for json_string variable type'
  2589. is_valid = .false.
  2590. return
  2591. else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
  2592. allocated(p%dbl_value)) then
  2593. error_msg = 'incorrect data allocated for json_string variable type'
  2594. is_valid = .false.
  2595. return
  2596. end if
  2597. case default
  2598. error_msg = 'invalid JSON variable type'
  2599. is_valid = .false.
  2600. return
  2601. end select
  2602. if (require_parent .and. .not. associated(p%parent)) then
  2603. error_msg = 'parent pointer is not associated'
  2604. is_valid = .false.
  2605. return
  2606. end if
  2607. if (.not. allocated(p%name)) then
  2608. if (associated(p%parent)) then
  2609. if (p%parent%var_type/=json_array) then
  2610. error_msg = 'JSON variable must have a name if not an '//&
  2611. 'array element or the root'
  2612. is_valid = .false.
  2613. return
  2614. end if
  2615. end if
  2616. end if
  2617. if (associated(p%children) .neqv. associated(p%tail)) then
  2618. error_msg = 'both children and tail pointers must be associated'
  2619. is_valid = .false.
  2620. return
  2621. end if
  2622. ! now, check next one:
  2623. if (associated(p%next)) then
  2624. if (associated(p,p%next)) then
  2625. error_msg = 'circular linked list'
  2626. is_valid = .false.
  2627. return
  2628. else
  2629. ! if it's an element in an
  2630. ! array, then require a parent:
  2631. call check_if_valid(p%next,require_parent=.true.)
  2632. end if
  2633. end if
  2634. if (associated(p%children)) then
  2635. if (p%var_type/=json_array .and. p%var_type/=json_object) then
  2636. error_msg = 'only arrays and objects can have children'
  2637. is_valid = .false.
  2638. return
  2639. end if
  2640. ! first validate children pointers:
  2641. previous => null()
  2642. element => p%children
  2643. do i = 1_IK, p%n_children
  2644. if (.not. associated(element%parent,p)) then
  2645. error_msg = 'child''s parent pointer not properly associated'
  2646. is_valid = .false.
  2647. return
  2648. end if
  2649. if (i==1 .and. associated(element%previous)) then
  2650. error_msg = 'first child shouldn''t have a previous'
  2651. is_valid = .false.
  2652. return
  2653. end if
  2654. if (i<p%n_children .and. .not. associated(element%next)) then
  2655. error_msg = 'not enough children'
  2656. is_valid = .false.
  2657. return
  2658. end if
  2659. if (i==p%n_children .and. associated(element%next)) then
  2660. error_msg = 'too many children'
  2661. is_valid = .false.
  2662. return
  2663. end if
  2664. if (i>1) then
  2665. if (.not. associated(previous,element%previous)) then
  2666. error_msg = 'previous pointer not properly associated'
  2667. is_valid = .false.
  2668. return
  2669. end if
  2670. end if
  2671. if (i==p%n_children .and. &
  2672. .not. associated(element%parent%tail,element)) then
  2673. error_msg = 'parent''s tail pointer not properly associated'
  2674. is_valid = .false.
  2675. return
  2676. end if
  2677. if (i<p%n_children) then
  2678. !setup next case:
  2679. previous => element
  2680. element => element%next
  2681. end if
  2682. end do
  2683. !now check all the children:
  2684. call check_if_valid(p%children,require_parent=.true.)
  2685. end if
  2686. end if
  2687. end subroutine check_if_valid
  2688. end subroutine json_value_validate
  2689. !*****************************************************************************************
  2690. !*****************************************************************************************
  2691. !> author: Jacob Williams
  2692. ! date: 12/6/2014
  2693. !
  2694. ! Given the path string, remove the variable
  2695. ! from [[json_value]], if it exists.
  2696. subroutine json_value_remove_if_present(json,p,path)
  2697. implicit none
  2698. class(json_core),intent(inout) :: json
  2699. type(json_value),pointer :: p
  2700. character(kind=CK,len=*),intent(in) :: path !! the path to the variable to remove
  2701. type(json_value),pointer :: p_var
  2702. logical(LK) :: found
  2703. call json%get(p,path,p_var,found)
  2704. if (found) call json%remove(p_var)
  2705. end subroutine json_value_remove_if_present
  2706. !*****************************************************************************************
  2707. !*****************************************************************************************
  2708. !>
  2709. ! Alternate version of [[json_value_remove_if_present]], where `path` is kind=CDK.
  2710. subroutine wrap_json_value_remove_if_present(json,p,path)
  2711. implicit none
  2712. class(json_core),intent(inout) :: json
  2713. type(json_value),pointer :: p
  2714. character(kind=CDK,len=*),intent(in) :: path
  2715. call json%remove_if_present(p,to_unicode(path))
  2716. end subroutine wrap_json_value_remove_if_present
  2717. !*****************************************************************************************
  2718. !*****************************************************************************************
  2719. !> author: Jacob Williams
  2720. ! date: 12/6/2014
  2721. !
  2722. ! Given the path string, if the variable is present,
  2723. ! and is a scalar, then update its value.
  2724. ! If it is not present, then create it and set its value.
  2725. !
  2726. !@note If the variable is not a scalar, an exception will be thrown.
  2727. subroutine json_update_logical(json,p,path,val,found)
  2728. implicit none
  2729. class(json_core),intent(inout) :: json
  2730. type(json_value),pointer :: p
  2731. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2732. logical(LK),intent(in) :: val !! the new value
  2733. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2734. type(json_value),pointer :: p_var
  2735. integer(IK) :: var_type
  2736. call json%get(p,path,p_var,found)
  2737. if (found) then
  2738. call json%info(p_var,var_type)
  2739. select case (var_type)
  2740. case (json_null,json_logical,json_integer,json_real,json_string)
  2741. call json%to_logical(p_var,val) !update the value
  2742. case default
  2743. found = .false.
  2744. call json%throw_exception('Error in json_update_logical: '//&
  2745. 'the variable is not a scalar value',found)
  2746. end select
  2747. else
  2748. call json%add_by_path(p,path,val) !add the new element
  2749. end if
  2750. end subroutine json_update_logical
  2751. !*****************************************************************************************
  2752. !*****************************************************************************************
  2753. !>
  2754. ! Alternate version of [[json_update_logical]], where `path` is kind=CDK.
  2755. subroutine wrap_json_update_logical(json,p,path,val,found)
  2756. implicit none
  2757. class(json_core),intent(inout) :: json
  2758. type(json_value),pointer :: p
  2759. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2760. logical(LK),intent(in) :: val !! the new value
  2761. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2762. call json%update(p,to_unicode(path),val,found)
  2763. end subroutine wrap_json_update_logical
  2764. !*****************************************************************************************
  2765. !*****************************************************************************************
  2766. !> author: Jacob Williams
  2767. ! date: 12/6/2014
  2768. !
  2769. ! Given the path string, if the variable is present,
  2770. ! and is a scalar, then update its value.
  2771. ! If it is not present, then create it and set its value.
  2772. !
  2773. !@note If the variable is not a scalar, an exception will be thrown.
  2774. subroutine json_update_real(json,p,path,val,found)
  2775. implicit none
  2776. class(json_core),intent(inout) :: json
  2777. type(json_value),pointer :: p
  2778. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2779. real(RK),intent(in) :: val !! the new value
  2780. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2781. type(json_value),pointer :: p_var
  2782. integer(IK) :: var_type
  2783. call json%get(p,path,p_var,found)
  2784. if (found) then
  2785. call json%info(p_var,var_type)
  2786. select case (var_type)
  2787. case (json_null,json_logical,json_integer,json_real,json_string)
  2788. call json%to_real(p_var,val) !update the value
  2789. case default
  2790. found = .false.
  2791. call json%throw_exception('Error in json_update_real: '//&
  2792. 'the variable is not a scalar value',found)
  2793. end select
  2794. else
  2795. call json%add_by_path(p,path,val) !add the new element
  2796. end if
  2797. end subroutine json_update_real
  2798. !*****************************************************************************************
  2799. !*****************************************************************************************
  2800. !>
  2801. ! Alternate version of [[json_update_real]], where `path` is kind=CDK.
  2802. subroutine wrap_json_update_real(json,p,path,val,found)
  2803. implicit none
  2804. class(json_core),intent(inout) :: json
  2805. type(json_value),pointer :: p
  2806. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2807. real(RK),intent(in) :: val !! the new value
  2808. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2809. call json%update(p,to_unicode(path),val,found)
  2810. end subroutine wrap_json_update_real
  2811. !*****************************************************************************************
  2812. !*****************************************************************************************
  2813. !>
  2814. ! Alternate version of [[json_update_real]], where `val` is `real32`.
  2815. subroutine json_update_real32(json,p,path,val,found)
  2816. implicit none
  2817. class(json_core),intent(inout) :: json
  2818. type(json_value),pointer :: p
  2819. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2820. real(real32),intent(in) :: val !! the new value
  2821. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2822. call json%update(p,path,real(val,RK),found)
  2823. end subroutine json_update_real32
  2824. !*****************************************************************************************
  2825. !*****************************************************************************************
  2826. !>
  2827. ! Alternate version of [[json_update_real32]], where `path` is kind=CDK.
  2828. subroutine wrap_json_update_real32(json,p,path,val,found)
  2829. implicit none
  2830. class(json_core),intent(inout) :: json
  2831. type(json_value),pointer :: p
  2832. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2833. real(real32),intent(in) :: val !! the new value
  2834. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2835. call json%update(p,to_unicode(path),real(val,RK),found)
  2836. end subroutine wrap_json_update_real32
  2837. !*****************************************************************************************
  2838. # 3206
  2839. !*****************************************************************************************
  2840. !> author: Jacob Williams
  2841. ! date: 12/6/2014
  2842. !
  2843. ! Given the path string, if the variable is present,
  2844. ! and is a scalar, then update its value.
  2845. ! If it is not present, then create it and set its value.
  2846. !
  2847. !@note If the variable is not a scalar, an exception will be thrown.
  2848. subroutine json_update_integer(json,p,path,val,found)
  2849. implicit none
  2850. class(json_core),intent(inout) :: json
  2851. type(json_value),pointer :: p
  2852. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2853. integer(IK),intent(in) :: val !! the new value
  2854. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2855. type(json_value),pointer :: p_var
  2856. integer(IK) :: var_type
  2857. call json%get(p,path,p_var,found)
  2858. if (found) then
  2859. call json%info(p_var,var_type)
  2860. select case (var_type)
  2861. case (json_null,json_logical,json_integer,json_real,json_string)
  2862. call json%to_integer(p_var,val) !update the value
  2863. case default
  2864. found = .false.
  2865. call json%throw_exception('Error in json_update_integer: '//&
  2866. 'the variable is not a scalar value',found)
  2867. end select
  2868. else
  2869. call json%add_by_path(p,path,val) !add the new element
  2870. end if
  2871. end subroutine json_update_integer
  2872. !*****************************************************************************************
  2873. !*****************************************************************************************
  2874. !>
  2875. ! Alternate version of [[json_update_integer]], where `path` is kind=CDK.
  2876. subroutine wrap_json_update_integer(json,p,path,val,found)
  2877. implicit none
  2878. class(json_core),intent(inout) :: json
  2879. type(json_value),pointer :: p
  2880. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2881. integer(IK),intent(in) :: val !! the new value
  2882. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2883. call json%update(p,to_unicode(path),val,found)
  2884. end subroutine wrap_json_update_integer
  2885. !*****************************************************************************************
  2886. !*****************************************************************************************
  2887. !> author: Jacob Williams
  2888. ! date: 12/6/2014
  2889. !
  2890. ! Given the path string, if the variable is present,
  2891. ! and is a scalar, then update its value.
  2892. ! If it is not present, then create it and set its value.
  2893. !
  2894. !@note If the variable is not a scalar, an exception will be thrown.
  2895. subroutine json_update_string(json,p,path,val,found,trim_str,adjustl_str)
  2896. implicit none
  2897. class(json_core),intent(inout) :: json
  2898. type(json_value),pointer :: p
  2899. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2900. character(kind=CK,len=*),intent(in) :: val !! the new value
  2901. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2902. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  2903. !! (only used if `val` is present)
  2904. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  2905. !! (only used if `val` is present)
  2906. !! (note that ADJUSTL is done before TRIM)
  2907. type(json_value),pointer :: p_var
  2908. integer(IK) :: var_type
  2909. call json%get(p,path,p_var,found)
  2910. if (found) then
  2911. call json%info(p_var,var_type)
  2912. select case (var_type)
  2913. case (json_null,json_logical,json_integer,json_real,json_string)
  2914. call json%to_string(p_var,val,trim_str=trim_str,adjustl_str=adjustl_str) ! update the value
  2915. case default
  2916. found = .false.
  2917. call json%throw_exception('Error in json_update_string: '//&
  2918. 'the variable is not a scalar value',found)
  2919. end select
  2920. else
  2921. call json%add_by_path(p,path,val) !add the new element
  2922. end if
  2923. end subroutine json_update_string
  2924. !*****************************************************************************************
  2925. !*****************************************************************************************
  2926. !>
  2927. ! Alternate version of [[json_update_string]], where `path` and `value` are kind=CDK.
  2928. subroutine wrap_json_update_string(json,p,path,val,found,trim_str,adjustl_str)
  2929. implicit none
  2930. class(json_core),intent(inout) :: json
  2931. type(json_value),pointer :: p
  2932. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2933. character(kind=CDK,len=*),intent(in) :: val !! the new value
  2934. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2935. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  2936. !! (only used if `val` is present)
  2937. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  2938. !! (only used if `val` is present)
  2939. !! (note that ADJUSTL is done before TRIM)
  2940. call json%update(p,to_unicode(path),to_unicode(val),found,trim_str,adjustl_str)
  2941. end subroutine wrap_json_update_string
  2942. !*****************************************************************************************
  2943. !*****************************************************************************************
  2944. !>
  2945. ! Alternate version of [[json_update_string]], where `path` is kind=CDK.
  2946. subroutine json_update_string_name_ascii(json,p,path,val,found,trim_str,adjustl_str)
  2947. implicit none
  2948. class(json_core),intent(inout) :: json
  2949. type(json_value),pointer :: p
  2950. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2951. character(kind=CK, len=*),intent(in) :: val !! the new value
  2952. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2953. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  2954. !! (only used if `val` is present)
  2955. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  2956. !! (only used if `val` is present)
  2957. !! (note that ADJUSTL is done before TRIM)
  2958. call json%update(p,to_unicode(path),val,found,trim_str,adjustl_str)
  2959. end subroutine json_update_string_name_ascii
  2960. !*****************************************************************************************
  2961. !*****************************************************************************************
  2962. !>
  2963. ! Alternate version of [[json_update_string]], where `val` is kind=CDK.
  2964. subroutine json_update_string_val_ascii(json,p,path,val,found,trim_str,adjustl_str)
  2965. implicit none
  2966. class(json_core),intent(inout) :: json
  2967. type(json_value),pointer :: p
  2968. character(kind=CK, len=*),intent(in) :: path !! path to the variable in the structure
  2969. character(kind=CDK,len=*),intent(in) :: val !! the new value
  2970. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2971. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  2972. !! (only used if `val` is present)
  2973. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  2974. !! (only used if `val` is present)
  2975. !! (note that ADJUSTL is done before TRIM)
  2976. call json%update(p,path,to_unicode(val),found,trim_str,adjustl_str)
  2977. end subroutine json_update_string_val_ascii
  2978. !*****************************************************************************************
  2979. !*****************************************************************************************
  2980. !>
  2981. ! Adds `member` as a child of `p`.
  2982. subroutine json_value_add_member(json,p,member)
  2983. implicit none
  2984. class(json_core),intent(inout) :: json
  2985. type(json_value),pointer :: p !! `p` must be a `json_object`
  2986. !! or a `json_array`
  2987. type(json_value),pointer :: member !! the child member
  2988. !! to add to `p`
  2989. integer(IK) :: var_type !! variable type of `p`
  2990. if (.not. json%exception_thrown) then
  2991. if (associated(p)) then
  2992. call json%info(p,var_type=var_type)
  2993. select case (var_type)
  2994. case(json_object, json_array)
  2995. ! associate the parent
  2996. member%parent => p
  2997. ! add to linked list
  2998. if (associated(p%children)) then
  2999. p%tail%next => member
  3000. member%previous => p%tail
  3001. else
  3002. p%children => member
  3003. member%previous => null() !first in the list
  3004. end if
  3005. ! new member is now the last one in the list
  3006. p%tail => member
  3007. p%n_children = p%n_children + 1
  3008. case default
  3009. call json%throw_exception('Error in json_value_add_member: '//&
  3010. 'can only add child to object or array')
  3011. end select
  3012. else
  3013. call json%throw_exception('Error in json_value_add_member: '//&
  3014. 'the pointer is not associated')
  3015. end if
  3016. end if
  3017. end subroutine json_value_add_member
  3018. !*****************************************************************************************
  3019. !*****************************************************************************************
  3020. !>
  3021. ! Inserts `element` after `p`, and updates the JSON structure accordingly.
  3022. !
  3023. !### Example
  3024. !
  3025. !````fortran
  3026. ! program test
  3027. ! use json_module
  3028. ! implicit none
  3029. ! logical(json_LK) :: found
  3030. ! type(json_core) :: json
  3031. ! type(json_value),pointer :: p,new,element
  3032. ! call json%load(file='myfile.json', p=p)
  3033. ! call json%get(p,'x(3)',element,found) ! get pointer to an array element in the file
  3034. ! call json%create_integer(new,1,'') ! create a new element
  3035. ! call json%insert_after(element,new) ! insert new element after x(3)
  3036. ! call json%print(p,'myfile2.json') ! write it to a file
  3037. ! call json%destroy(p) ! cleanup
  3038. ! end program test
  3039. !````
  3040. !
  3041. !### Details
  3042. !
  3043. ! * This routine can be used to insert a new element (or set of elements)
  3044. ! into an array or object at a specific index.
  3045. ! See [[json_value_insert_after_child_by_index]]
  3046. ! * Children and subsequent elements of `element` are carried along.
  3047. ! * If the inserted elements are part of an existing list, then
  3048. ! they are removed from that list.
  3049. !
  3050. !````
  3051. ! p
  3052. ! [1] - [2] - [3] - [4]
  3053. ! |
  3054. ! [5] - [6] - [7] n=3 elements inserted
  3055. ! element last
  3056. !
  3057. ! Result is:
  3058. !
  3059. ! [1] - [2] - [5] - [6] - [7] - [3] - [4]
  3060. !
  3061. !````
  3062. subroutine json_value_insert_after(json,p,element)
  3063. implicit none
  3064. class(json_core),intent(inout) :: json
  3065. type(json_value),pointer :: p !! a value from a JSON structure
  3066. !! (presumably, this is a child of
  3067. !! an object or array).
  3068. type(json_value),pointer :: element !! the element to insert after `p`
  3069. type(json_value),pointer :: parent !! the parent of `p`
  3070. type(json_value),pointer :: next !! temp pointer for traversing structure
  3071. type(json_value),pointer :: last !! the last of the items being inserted
  3072. integer :: n !! number of items being inserted
  3073. if (.not. json%exception_thrown) then
  3074. parent => p%parent
  3075. ! set first parent of inserted list:
  3076. element%parent => parent
  3077. ! Count the number of inserted elements.
  3078. ! and set their parents.
  3079. n = 1 ! initialize counter
  3080. next => element%next
  3081. last => element
  3082. do
  3083. if (.not. associated(next)) exit
  3084. n = n + 1
  3085. next%parent => parent
  3086. last => next
  3087. next => next%next
  3088. end do
  3089. if (associated(parent)) then
  3090. ! update parent's child counter:
  3091. parent%n_children = parent%n_children + n
  3092. ! if p is last of parents children then
  3093. ! also have to update parent tail pointer:
  3094. if (associated(parent%tail,p)) then
  3095. parent%tail => last
  3096. end if
  3097. end if
  3098. if (associated(element%previous)) then
  3099. ! element is apparently part of an existing list,
  3100. ! so have to update that as well.
  3101. if (associated(element%previous%parent)) then
  3102. element%previous%parent%n_children = &
  3103. element%previous%parent%n_children - n
  3104. element%previous%parent%tail => &
  3105. element%previous ! now the last one in the list
  3106. else
  3107. ! this would be a memory leak if the previous entries
  3108. ! are not otherwise being pointed too
  3109. ! [throw an error in this case???]
  3110. end if
  3111. !remove element from the other list:
  3112. element%previous%next => null()
  3113. end if
  3114. element%previous => p
  3115. if (associated(p%next)) then
  3116. ! if there are any in the list after p:
  3117. last%next => p%next
  3118. last%next%previous => element
  3119. else
  3120. last%next => null()
  3121. end if
  3122. p%next => element
  3123. end if
  3124. end subroutine json_value_insert_after
  3125. !*****************************************************************************************
  3126. !*****************************************************************************************
  3127. !>
  3128. ! Inserts `element` after the `idx`-th child of `p`,
  3129. ! and updates the JSON structure accordingly. This is just
  3130. ! a wrapper for [[json_value_insert_after]].
  3131. subroutine json_value_insert_after_child_by_index(json,p,idx,element)
  3132. implicit none
  3133. class(json_core),intent(inout) :: json
  3134. type(json_value),pointer :: p !! a JSON object or array.
  3135. integer(IK),intent(in) :: idx !! the index of the child of `p` to
  3136. !! insert the new element after
  3137. !! (this is a 1-based Fortran
  3138. !! style array index)
  3139. type(json_value),pointer :: element !! the element to insert
  3140. type(json_value),pointer :: tmp !! for getting the `idx`-th child of `p`
  3141. if (.not. json%exception_thrown) then
  3142. ! get the idx-th child of p:
  3143. call json%get_child(p,idx,tmp)
  3144. ! call json_value_insert_after:
  3145. if (.not. json%exception_thrown) call json%insert_after(tmp,element)
  3146. end if
  3147. end subroutine json_value_insert_after_child_by_index
  3148. !*****************************************************************************************
  3149. !*****************************************************************************************
  3150. !>
  3151. ! Add a new member (`json_value` pointer) to a JSON structure, given the path.
  3152. !
  3153. !@warning If the path points to an existing variable in the structure,
  3154. ! then this routine will destroy it and replace it with the
  3155. ! new value.
  3156. subroutine json_add_member_by_path(json,me,path,p,found,was_created)
  3157. implicit none
  3158. class(json_core),intent(inout) :: json
  3159. type(json_value),pointer :: me !! the JSON structure
  3160. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3161. type(json_value),pointer,intent(in) :: p !! the value to add
  3162. logical(LK),intent(out),optional :: found !! if the variable was found
  3163. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3164. type(json_value),pointer :: tmp
  3165. character(kind=CK,len=:),allocatable :: name !! name of the variable
  3166. if ( .not. json%exception_thrown ) then
  3167. if (.not. associated(p)) then
  3168. call json%throw_exception('Error in json_add_member_by_path:'//&
  3169. ' Input pointer p is not associated.',found)
  3170. if (present(found)) then
  3171. found = .false.
  3172. call json%clear_exceptions()
  3173. end if
  3174. if ( present(was_created) ) was_created = .false.
  3175. else
  3176. ! return a pointer to the path (possibly creating it)
  3177. call json%create(me,path,tmp,found,was_created)
  3178. if (.not. associated(tmp)) then
  3179. call json%throw_exception('Error in json_add_member_by_path:'//&
  3180. ' Unable to resolve path: '//trim(path),found)
  3181. if (present(found)) then
  3182. found = .false.
  3183. call json%clear_exceptions()
  3184. end if
  3185. else
  3186. call json%info(tmp,name=name)
  3187. ! replace it with the new one:
  3188. call json%replace(tmp,p,destroy=.true.)
  3189. call json%rename(p,name)
  3190. end if
  3191. end if
  3192. else
  3193. if ( present(found) ) found = .false.
  3194. if ( present(was_created) ) was_created = .false.
  3195. end if
  3196. end subroutine json_add_member_by_path
  3197. !*****************************************************************************************
  3198. !*****************************************************************************************
  3199. !>
  3200. ! Wrapper to [[json_add_member_by_path]] where "path" is kind=CDK.
  3201. subroutine wrap_json_add_member_by_path(json,me,path,p,found,was_created)
  3202. implicit none
  3203. class(json_core),intent(inout) :: json
  3204. type(json_value),pointer :: me !! the JSON structure
  3205. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3206. type(json_value),pointer,intent(in) :: p !! the value to add
  3207. logical(LK),intent(out),optional :: found !! if the variable was found
  3208. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3209. call json%json_add_member_by_path(me,to_unicode(path),p,found,was_created)
  3210. end subroutine wrap_json_add_member_by_path
  3211. !*****************************************************************************************
  3212. !*****************************************************************************************
  3213. !>
  3214. ! Add an integer value to a [[json_value]], given the path.
  3215. !
  3216. !@warning If the path points to an existing variable in the structure,
  3217. ! then this routine will destroy it and replace it with the
  3218. ! new value.
  3219. subroutine json_add_integer_by_path(json,me,path,value,found,was_created)
  3220. implicit none
  3221. class(json_core),intent(inout) :: json
  3222. type(json_value),pointer :: me !! the JSON structure
  3223. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3224. integer(IK),intent(in) :: value !! the value to add
  3225. logical(LK),intent(out),optional :: found !! if the variable was found
  3226. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3227. type(json_value),pointer :: p
  3228. type(json_value),pointer :: tmp
  3229. character(kind=CK,len=:),allocatable :: name !! variable name
  3230. if ( .not. json%exception_thrown ) then
  3231. nullify(p)
  3232. ! return a pointer to the path (possibly creating it)
  3233. ! If the variable had to be created, then
  3234. ! it will be a json_null variable.
  3235. call json%create(me,path,p,found,was_created)
  3236. if (.not. associated(p)) then
  3237. call json%throw_exception('Error in json_add_integer_by_path:'//&
  3238. ' Unable to resolve path: '//trim(path),found)
  3239. if (present(found)) then
  3240. found = .false.
  3241. call json%clear_exceptions()
  3242. end if
  3243. else
  3244. !NOTE: a new object is created, and the old one
  3245. ! is replaced and destroyed. This is to
  3246. ! prevent memory leaks if the type is
  3247. ! being changed (for example, if an array
  3248. ! is being replaced with a scalar).
  3249. if (p%var_type==json_integer) then
  3250. p%int_value = value
  3251. else
  3252. call json%info(p,name=name)
  3253. call json%create_integer(tmp,value,name)
  3254. call json%replace(p,tmp,destroy=.true.)
  3255. end if
  3256. end if
  3257. else
  3258. if ( present(found) ) found = .false.
  3259. if ( present(was_created) ) was_created = .false.
  3260. end if
  3261. end subroutine json_add_integer_by_path
  3262. !*****************************************************************************************
  3263. !*****************************************************************************************
  3264. !>
  3265. ! Wrapper to [[json_add_integer_by_path]] where "path" is kind=CDK.
  3266. subroutine wrap_json_add_integer_by_path(json,me,path,value,found,was_created)
  3267. implicit none
  3268. class(json_core),intent(inout) :: json
  3269. type(json_value),pointer :: me !! the JSON structure
  3270. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3271. integer(IK),intent(in) :: value !! the value to add
  3272. logical(LK),intent(out),optional :: found !! if the variable was found
  3273. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3274. call json%json_add_integer_by_path(me,to_unicode(path),value,found,was_created)
  3275. end subroutine wrap_json_add_integer_by_path
  3276. !*****************************************************************************************
  3277. !*****************************************************************************************
  3278. !>
  3279. ! Add an real value to a [[json_value]], given the path.
  3280. !
  3281. !@warning If the path points to an existing variable in the structure,
  3282. ! then this routine will destroy it and replace it with the
  3283. ! new value.
  3284. subroutine json_add_real_by_path(json,me,path,value,found,was_created)
  3285. implicit none
  3286. class(json_core),intent(inout) :: json
  3287. type(json_value),pointer :: me !! the JSON structure
  3288. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3289. real(RK),intent(in) :: value !! the value to add
  3290. logical(LK),intent(out),optional :: found !! if the variable was found
  3291. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3292. type(json_value),pointer :: p
  3293. type(json_value),pointer :: tmp
  3294. character(kind=CK,len=:),allocatable :: name !! variable name
  3295. if ( .not. json%exception_thrown ) then
  3296. nullify(p)
  3297. ! return a pointer to the path (possibly creating it)
  3298. ! If the variable had to be created, then
  3299. ! it will be a json_null variable.
  3300. call json%create(me,path,p,found,was_created)
  3301. if (.not. associated(p)) then
  3302. call json%throw_exception('Error in json_add_real_by_path:'//&
  3303. ' Unable to resolve path: '//trim(path),found)
  3304. if (present(found)) then
  3305. found = .false.
  3306. call json%clear_exceptions()
  3307. end if
  3308. else
  3309. !NOTE: a new object is created, and the old one
  3310. ! is replaced and destroyed. This is to
  3311. ! prevent memory leaks if the type is
  3312. ! being changed (for example, if an array
  3313. ! is being replaced with a scalar).
  3314. if (p%var_type==json_real) then
  3315. p%dbl_value = value
  3316. else
  3317. call json%info(p,name=name)
  3318. call json%create_real(tmp,value,name)
  3319. call json%replace(p,tmp,destroy=.true.)
  3320. end if
  3321. end if
  3322. else
  3323. if ( present(found) ) found = .false.
  3324. if ( present(was_created) ) was_created = .false.
  3325. end if
  3326. end subroutine json_add_real_by_path
  3327. !*****************************************************************************************
  3328. !*****************************************************************************************
  3329. !>
  3330. ! Wrapper to [[json_add_real_by_path]] where "path" is kind=CDK.
  3331. subroutine wrap_json_add_real_by_path(json,me,path,value,found,was_created)
  3332. implicit none
  3333. class(json_core),intent(inout) :: json
  3334. type(json_value),pointer :: me !! the JSON structure
  3335. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3336. real(RK),intent(in) :: value !! the value to add
  3337. logical(LK),intent(out),optional :: found !! if the variable was found
  3338. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3339. call json%json_add_real_by_path(me,to_unicode(path),value,found,was_created)
  3340. end subroutine wrap_json_add_real_by_path
  3341. !*****************************************************************************************
  3342. !*****************************************************************************************
  3343. !>
  3344. ! Alternate version of [[json_add_real_by_path]] where value=real32.
  3345. subroutine json_add_real32_by_path(json,me,path,value,found,was_created)
  3346. implicit none
  3347. class(json_core),intent(inout) :: json
  3348. type(json_value),pointer :: me !! the JSON structure
  3349. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3350. real(real32),intent(in) :: value !! the value to add
  3351. logical(LK),intent(out),optional :: found !! if the variable was found
  3352. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3353. call json%add_by_path(me,path,real(value,RK),found,was_created)
  3354. end subroutine json_add_real32_by_path
  3355. !*****************************************************************************************
  3356. !*****************************************************************************************
  3357. !>
  3358. ! Wrapper to [[json_add_real32_by_path]] where "path" is kind=CDK.
  3359. subroutine wrap_json_add_real32_by_path(json,me,path,value,found,was_created)
  3360. implicit none
  3361. class(json_core),intent(inout) :: json
  3362. type(json_value),pointer :: me !! the JSON structure
  3363. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3364. real(real32),intent(in) :: value !! the value to add
  3365. logical(LK),intent(out),optional :: found !! if the variable was found
  3366. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3367. call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created)
  3368. end subroutine wrap_json_add_real32_by_path
  3369. !*****************************************************************************************
  3370. # 3942
  3371. !*****************************************************************************************
  3372. !>
  3373. ! Add a logical value to a [[json_value]], given the path.
  3374. !
  3375. !@warning If the path points to an existing variable in the structure,
  3376. ! then this routine will destroy it and replace it with the
  3377. ! new value.
  3378. subroutine json_add_logical_by_path(json,me,path,value,found,was_created)
  3379. implicit none
  3380. class(json_core),intent(inout) :: json
  3381. type(json_value),pointer :: me !! the JSON structure
  3382. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3383. logical(LK),intent(in) :: value !! the value to add
  3384. logical(LK),intent(out),optional :: found !! if the variable was found
  3385. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3386. type(json_value),pointer :: p
  3387. type(json_value),pointer :: tmp
  3388. character(kind=CK,len=:),allocatable :: name !! variable name
  3389. if ( .not. json%exception_thrown ) then
  3390. nullify(p)
  3391. ! return a pointer to the path (possibly creating it)
  3392. ! If the variable had to be created, then
  3393. ! it will be a json_null variable.
  3394. call json%create(me,path,p,found,was_created)
  3395. if (.not. associated(p)) then
  3396. call json%throw_exception('Error in json_add_logical_by_path:'//&
  3397. ' Unable to resolve path: '//trim(path),found)
  3398. if (present(found)) then
  3399. found = .false.
  3400. call json%clear_exceptions()
  3401. end if
  3402. else
  3403. !NOTE: a new object is created, and the old one
  3404. ! is replaced and destroyed. This is to
  3405. ! prevent memory leaks if the type is
  3406. ! being changed (for example, if an array
  3407. ! is being replaced with a scalar).
  3408. if (p%var_type==json_logical) then
  3409. p%log_value = value
  3410. else
  3411. call json%info(p,name=name)
  3412. call json%create_logical(tmp,value,name)
  3413. call json%replace(p,tmp,destroy=.true.)
  3414. end if
  3415. end if
  3416. else
  3417. if ( present(found) ) found = .false.
  3418. if ( present(was_created) ) was_created = .false.
  3419. end if
  3420. end subroutine json_add_logical_by_path
  3421. !*****************************************************************************************
  3422. !*****************************************************************************************
  3423. !>
  3424. ! Wrapper to [[json_add_logical_by_path]] where "path" is kind=CDK.
  3425. subroutine wrap_json_add_logical_by_path(json,me,path,value,found,was_created)
  3426. implicit none
  3427. class(json_core),intent(inout) :: json
  3428. type(json_value),pointer :: me !! the JSON structure
  3429. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3430. logical(LK),intent(in) :: value !! the value to add
  3431. logical(LK),intent(out),optional :: found !! if the variable was found
  3432. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3433. call json%json_add_logical_by_path(me,to_unicode(path),value,found,was_created)
  3434. end subroutine wrap_json_add_logical_by_path
  3435. !*****************************************************************************************
  3436. !*****************************************************************************************
  3437. !>
  3438. ! Add a string value to a [[json_value]], given the path.
  3439. !
  3440. !@warning If the path points to an existing variable in the structure,
  3441. ! then this routine will destroy it and replace it with the
  3442. ! new value.
  3443. subroutine json_add_string_by_path(json,me,path,value,found,&
  3444. was_created,trim_str,adjustl_str)
  3445. implicit none
  3446. class(json_core),intent(inout) :: json
  3447. type(json_value),pointer :: me !! the JSON structure
  3448. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3449. character(kind=CK,len=*),intent(in) :: value !! the value to add
  3450. logical(LK),intent(out),optional :: found !! if the variable was found
  3451. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3452. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3453. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3454. type(json_value),pointer :: p
  3455. type(json_value),pointer :: tmp
  3456. character(kind=CK,len=:),allocatable :: name !! variable name
  3457. if ( .not. json%exception_thrown ) then
  3458. nullify(p)
  3459. ! return a pointer to the path (possibly creating it)
  3460. ! If the variable had to be created, then
  3461. ! it will be a json_null variable.
  3462. call json%create(me,path,p,found,was_created)
  3463. if (.not. associated(p)) then
  3464. call json%throw_exception('Error in json_add_string_by_path:'//&
  3465. ' Unable to resolve path: '//trim(path),found)
  3466. if (present(found)) then
  3467. found = .false.
  3468. call json%clear_exceptions()
  3469. end if
  3470. else
  3471. !NOTE: a new object is created, and the old one
  3472. ! is replaced and destroyed. This is to
  3473. ! prevent memory leaks if the type is
  3474. ! being changed (for example, if an array
  3475. ! is being replaced with a scalar).
  3476. if (p%var_type==json_string) then
  3477. p%str_value = value
  3478. else
  3479. call json%info(p,name=name)
  3480. call json%create_string(tmp,value,name,trim_str,adjustl_str)
  3481. call json%replace(p,tmp,destroy=.true.)
  3482. end if
  3483. end if
  3484. else
  3485. if ( present(found) ) found = .false.
  3486. if ( present(was_created) ) was_created = .false.
  3487. end if
  3488. end subroutine json_add_string_by_path
  3489. !*****************************************************************************************
  3490. !*****************************************************************************************
  3491. !>
  3492. ! Wrapper to [[json_add_string_by_path]] where "path" is kind=CDK.
  3493. subroutine wrap_json_add_string_by_path(json,me,path,value,found,&
  3494. was_created,trim_str,adjustl_str)
  3495. implicit none
  3496. class(json_core),intent(inout) :: json
  3497. type(json_value),pointer :: me !! the JSON structure
  3498. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3499. character(kind=CDK,len=*),intent(in) :: value !! the value to add
  3500. logical(LK),intent(out),optional :: found !! if the variable was found
  3501. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3502. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3503. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3504. call json%json_add_string_by_path(me,to_unicode(path),to_unicode(value),&
  3505. found,was_created,trim_str,adjustl_str)
  3506. end subroutine wrap_json_add_string_by_path
  3507. !*****************************************************************************************
  3508. !*****************************************************************************************
  3509. !>
  3510. ! Wrapper for [[json_add_string_by_path]] where "path" is kind=CDK.
  3511. subroutine json_add_string_by_path_path_ascii(json,me,path,value,found,&
  3512. was_created,trim_str,adjustl_str)
  3513. implicit none
  3514. class(json_core),intent(inout) :: json
  3515. type(json_value),pointer :: me !! the JSON structure
  3516. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3517. character(kind=CK,len=*),intent(in) :: value !! the value to add
  3518. logical(LK),intent(out),optional :: found !! if the variable was found
  3519. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3520. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3521. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3522. call json%json_add_string_by_path(me,to_unicode(path),value,found,was_created,trim_str,adjustl_str)
  3523. end subroutine json_add_string_by_path_path_ascii
  3524. !*****************************************************************************************
  3525. !*****************************************************************************************
  3526. !>
  3527. ! Wrapper for [[json_add_string_by_path]] where "value" is kind=CDK.
  3528. subroutine json_add_string_by_path_value_ascii(json,me,path,value,found,&
  3529. was_created,trim_str,adjustl_str)
  3530. implicit none
  3531. class(json_core),intent(inout) :: json
  3532. type(json_value),pointer :: me !! the JSON structure
  3533. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3534. character(kind=CDK,len=*),intent(in) :: value !! the value to add
  3535. logical(LK),intent(out),optional :: found !! if the variable was found
  3536. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3537. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3538. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3539. call json%json_add_string_by_path(me,path,to_unicode(value),found,was_created,trim_str,adjustl_str)
  3540. end subroutine json_add_string_by_path_value_ascii
  3541. !*****************************************************************************************
  3542. !*****************************************************************************************
  3543. !>
  3544. ! Wrapper to [[json_add_integer_by_path]] for adding an integer vector by path.
  3545. subroutine json_add_integer_vec_by_path(json,me,path,value,found,was_created)
  3546. implicit none
  3547. class(json_core),intent(inout) :: json
  3548. type(json_value),pointer :: me !! the JSON structure
  3549. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3550. integer(IK),dimension(:),intent(in) :: value !! the vector to add
  3551. logical(LK),intent(out),optional :: found !! if the variable was found
  3552. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3553. type(json_value),pointer :: p !! pointer to path (which may exist)
  3554. type(json_value),pointer :: var !! new variable that is created
  3555. integer(IK) :: i !! counter
  3556. character(kind=CK,len=:),allocatable :: name !! the variable name
  3557. logical(LK) :: p_found !! if the path was successfully found (or created)
  3558. if ( .not. json%exception_thrown ) then
  3559. !get a pointer to the variable
  3560. !(creating it if necessary)
  3561. call json%create(me,path,p,found=p_found)
  3562. if (p_found) then
  3563. call json%info(p,name=name) ! want to keep the existing name
  3564. call json%create_array(var,name) ! create a new array variable
  3565. call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
  3566. !populate each element of the array:
  3567. do i=1,size(value)
  3568. call json%add(var, CK_'', value(i))
  3569. end do
  3570. end if
  3571. else
  3572. if ( present(found) ) found = .false.
  3573. if ( present(was_created) ) was_created = .false.
  3574. end if
  3575. end subroutine json_add_integer_vec_by_path
  3576. !*****************************************************************************************
  3577. !*****************************************************************************************
  3578. !>
  3579. ! Wrapper for [[json_add_integer_vec_by_path]] where "path" is kind=CDK).
  3580. subroutine wrap_json_add_integer_vec_by_path(json,me,path,value,found,was_created)
  3581. implicit none
  3582. class(json_core),intent(inout) :: json
  3583. type(json_value),pointer :: me !! the JSON structure
  3584. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3585. integer(IK),dimension(:),intent(in) :: value !! the vector to add
  3586. logical(LK),intent(out),optional :: found !! if the variable was found
  3587. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3588. call json%json_add_integer_vec_by_path(me,to_unicode(path),value,found,was_created)
  3589. end subroutine wrap_json_add_integer_vec_by_path
  3590. !*****************************************************************************************
  3591. !*****************************************************************************************
  3592. !>
  3593. ! Wrapper to [[json_add_logical_by_path]] for adding a logical vector by path.
  3594. subroutine json_add_logical_vec_by_path(json,me,path,value,found,was_created)
  3595. implicit none
  3596. class(json_core),intent(inout) :: json
  3597. type(json_value),pointer :: me !! the JSON structure
  3598. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3599. logical(LK),dimension(:),intent(in) :: value !! the vector to add
  3600. logical(LK),intent(out),optional :: found !! if the variable was found
  3601. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3602. type(json_value),pointer :: p !! pointer to path (which may exist)
  3603. type(json_value),pointer :: var !! new variable that is created
  3604. integer(IK) :: i !! counter
  3605. character(kind=CK,len=:),allocatable :: name !! the variable name
  3606. logical(LK) :: p_found !! if the path was successfully found (or created)
  3607. if ( .not. json%exception_thrown ) then
  3608. !get a pointer to the variable
  3609. !(creating it if necessary)
  3610. call json%create(me,path,p,found=p_found)
  3611. if (p_found) then
  3612. call json%info(p,name=name) ! want to keep the existing name
  3613. call json%create_array(var,name) ! create a new array variable
  3614. call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
  3615. !populate each element of the array:
  3616. do i=1,size(value)
  3617. call json%add(var, CK_'', value(i))
  3618. end do
  3619. end if
  3620. else
  3621. if ( present(found) ) found = .false.
  3622. if ( present(was_created) ) was_created = .false.
  3623. end if
  3624. end subroutine json_add_logical_vec_by_path
  3625. !*****************************************************************************************
  3626. !*****************************************************************************************
  3627. !>
  3628. ! Wrapper for [[json_add_logical_vec_by_path]] where "path" is kind=CDK).
  3629. subroutine wrap_json_add_logical_vec_by_path(json,me,path,value,found,was_created)
  3630. implicit none
  3631. class(json_core),intent(inout) :: json
  3632. type(json_value),pointer :: me !! the JSON structure
  3633. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3634. logical(LK),dimension(:),intent(in) :: value !! the vector to add
  3635. logical(LK),intent(out),optional :: found !! if the variable was found
  3636. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3637. call json%json_add_logical_vec_by_path(me,to_unicode(path),value,found,was_created)
  3638. end subroutine wrap_json_add_logical_vec_by_path
  3639. !*****************************************************************************************
  3640. !*****************************************************************************************
  3641. !>
  3642. ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path.
  3643. subroutine json_add_real_vec_by_path(json,me,path,value,found,was_created)
  3644. implicit none
  3645. class(json_core),intent(inout) :: json
  3646. type(json_value),pointer :: me !! the JSON structure
  3647. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3648. real(RK),dimension(:),intent(in) :: value !! the vector to add
  3649. logical(LK),intent(out),optional :: found !! if the variable was found
  3650. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3651. type(json_value),pointer :: p !! pointer to path (which may exist)
  3652. type(json_value),pointer :: var !! new variable that is created
  3653. integer(IK) :: i !! counter
  3654. character(kind=CK,len=:),allocatable :: name !! the variable name
  3655. logical(LK) :: p_found !! if the path was successfully found (or created)
  3656. if ( .not. json%exception_thrown ) then
  3657. !get a pointer to the variable
  3658. !(creating it if necessary)
  3659. call json%create(me,path,p,found=p_found)
  3660. if (p_found) then
  3661. call json%info(p,name=name) ! want to keep the existing name
  3662. call json%create_array(var,name) ! create a new array variable
  3663. call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
  3664. !populate each element of the array:
  3665. do i=1,size(value)
  3666. call json%add(var, CK_'', value(i))
  3667. end do
  3668. end if
  3669. else
  3670. if ( present(found) ) found = .false.
  3671. if ( present(was_created) ) was_created = .false.
  3672. end if
  3673. end subroutine json_add_real_vec_by_path
  3674. !*****************************************************************************************
  3675. !*****************************************************************************************
  3676. !>
  3677. ! Wrapper for [[json_add_real_vec_by_path]] where "path" is kind=CDK).
  3678. subroutine wrap_json_add_real_vec_by_path(json,me,path,value,found,was_created)
  3679. implicit none
  3680. class(json_core),intent(inout) :: json
  3681. type(json_value),pointer :: me !! the JSON structure
  3682. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3683. real(RK),dimension(:),intent(in) :: value !! the vector to add
  3684. logical(LK),intent(out),optional :: found !! if the variable was found
  3685. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3686. call json%json_add_real_vec_by_path(me,to_unicode(path),value,found,was_created)
  3687. end subroutine wrap_json_add_real_vec_by_path
  3688. !*****************************************************************************************
  3689. !*****************************************************************************************
  3690. !>
  3691. ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path.
  3692. subroutine json_add_real32_vec_by_path(json,me,path,value,found,was_created)
  3693. implicit none
  3694. class(json_core),intent(inout) :: json
  3695. type(json_value),pointer :: me !! the JSON structure
  3696. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3697. real(real32),dimension(:),intent(in) :: value !! the vector to add
  3698. logical(LK),intent(out),optional :: found !! if the variable was found
  3699. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3700. call json%add_by_path(me,path,real(value,RK),found,was_created)
  3701. end subroutine json_add_real32_vec_by_path
  3702. !*****************************************************************************************
  3703. !*****************************************************************************************
  3704. !>
  3705. ! Wrapper for [[json_add_real32_vec_by_path]] where "path" is kind=CDK).
  3706. subroutine wrap_json_add_real32_vec_by_path(json,me,path,value,found,was_created)
  3707. implicit none
  3708. class(json_core),intent(inout) :: json
  3709. type(json_value),pointer :: me !! the JSON structure
  3710. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3711. real(real32),dimension(:),intent(in) :: value !! the vector to add
  3712. logical(LK),intent(out),optional :: found !! if the variable was found
  3713. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3714. call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created)
  3715. end subroutine wrap_json_add_real32_vec_by_path
  3716. !*****************************************************************************************
  3717. # 4445
  3718. !*****************************************************************************************
  3719. !>
  3720. ! Wrapper to [[json_add_string_by_path]] for adding a string vector by path.
  3721. !
  3722. !@note The `ilen` input can be used to specify the actual lengths of the
  3723. ! the strings in the array. They must all be `<= len(value)`.
  3724. subroutine json_add_string_vec_by_path(json,me,path,value,found,was_created,ilen,trim_str,adjustl_str)
  3725. implicit none
  3726. class(json_core),intent(inout) :: json
  3727. type(json_value),pointer :: me !! the JSON structure
  3728. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3729. character(kind=CK,len=*),dimension(:),intent(in) :: value !! the vector to add
  3730. logical(LK),intent(out),optional :: found !! if the variable was found
  3731. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3732. integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
  3733. !! element in `value`. If not present,
  3734. !! the full `len(value)` string is added
  3735. !! for each element.
  3736. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3737. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3738. type(json_value),pointer :: p !! pointer to path (which may exist)
  3739. type(json_value),pointer :: var !! new variable that is created
  3740. integer(IK) :: i !! counter
  3741. character(kind=CK,len=:),allocatable :: name !! the variable name
  3742. logical(LK) :: p_found !! if the path was successfully found (or created)
  3743. if ( .not. json%exception_thrown ) then
  3744. ! validate ilen array if present:
  3745. if (present(ilen)) then
  3746. if (size(ilen)/=size(value)) then
  3747. call json%throw_exception('Error in json_add_string_vec_by_path: '//&
  3748. 'Invalid size of ilen input vector.',found)
  3749. if (present(found)) then
  3750. found = .false.
  3751. call json%clear_exceptions()
  3752. end if
  3753. if (present(was_created)) was_created = .false.
  3754. return
  3755. else
  3756. ! also have to validate the specified lengths.
  3757. ! (must not be greater than input string length)
  3758. do i = 1, size(value)
  3759. if (ilen(i)>len(value)) then
  3760. call json%throw_exception('Error in json_add_string_vec_by_path: '//&
  3761. 'Invalid ilen element.',found)
  3762. if (present(found)) then
  3763. found = .false.
  3764. call json%clear_exceptions()
  3765. end if
  3766. if (present(was_created)) was_created = .false.
  3767. return
  3768. end if
  3769. end do
  3770. end if
  3771. end if
  3772. !get a pointer to the variable
  3773. !(creating it if necessary)
  3774. call json%create(me,path,p,found=p_found)
  3775. if (p_found) then
  3776. call json%info(p,name=name) ! want to keep the existing name
  3777. call json%create_array(var,name) ! create a new array variable
  3778. call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
  3779. !populate each element of the array:
  3780. do i=1,size(value)
  3781. if (present(ilen)) then
  3782. call json%add(var, CK_'', value(i)(1:ilen(i)), &
  3783. trim_str=trim_str, adjustl_str=adjustl_str)
  3784. else
  3785. call json%add(var, CK_'', value(i), &
  3786. trim_str=trim_str, adjustl_str=adjustl_str)
  3787. end if
  3788. end do
  3789. end if
  3790. else
  3791. if ( present(found) ) found = .false.
  3792. if ( present(was_created) ) was_created = .false.
  3793. end if
  3794. end subroutine json_add_string_vec_by_path
  3795. !*****************************************************************************************
  3796. !*****************************************************************************************
  3797. !>
  3798. ! Wrapper for [[json_add_string_vec_by_path]] where "path" and "value" are kind=CDK).
  3799. subroutine wrap_json_add_string_vec_by_path(json,me,path,value,&
  3800. found,was_created,ilen,&
  3801. trim_str,adjustl_str)
  3802. implicit none
  3803. class(json_core),intent(inout) :: json
  3804. type(json_value),pointer :: me !! the JSON structure
  3805. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3806. character(kind=CDK,len=*),dimension(:),intent(in):: value !! the vector to add
  3807. logical(LK),intent(out),optional :: found !! if the variable was found
  3808. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3809. integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
  3810. !! element in `value`. If not present,
  3811. !! the full `len(value)` string is added
  3812. !! for each element.
  3813. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3814. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3815. call json%json_add_string_vec_by_path(me,to_unicode(path),to_unicode(value),&
  3816. found,was_created,ilen,trim_str,adjustl_str)
  3817. end subroutine wrap_json_add_string_vec_by_path
  3818. !*****************************************************************************************
  3819. !*****************************************************************************************
  3820. !>
  3821. ! Wrapper for [[json_add_string_vec_by_path]] where "value" is kind=CDK).
  3822. subroutine json_add_string_vec_by_path_value_ascii(json,me,path,value,&
  3823. found,was_created,ilen,&
  3824. trim_str,adjustl_str)
  3825. implicit none
  3826. class(json_core),intent(inout) :: json
  3827. type(json_value),pointer :: me !! the JSON structure
  3828. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3829. character(kind=CDK,len=*),dimension(:),intent(in):: value !! the vector to add
  3830. logical(LK),intent(out),optional :: found !! if the variable was found
  3831. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3832. integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
  3833. !! element in `value`. If not present,
  3834. !! the full `len(value)` string is added
  3835. !! for each element.
  3836. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3837. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3838. call json%json_add_string_vec_by_path(me,path,to_unicode(value),&
  3839. found,was_created,ilen,trim_str,adjustl_str)
  3840. end subroutine json_add_string_vec_by_path_value_ascii
  3841. !*****************************************************************************************
  3842. !*****************************************************************************************
  3843. !>
  3844. ! Wrapper for [[json_add_string_vec_by_path]] where "path" is kind=CDK).
  3845. subroutine json_add_string_vec_by_path_path_ascii(json,me,path,value,&
  3846. found,was_created,ilen,&
  3847. trim_str,adjustl_str)
  3848. implicit none
  3849. class(json_core),intent(inout) :: json
  3850. type(json_value),pointer :: me !! the JSON structure
  3851. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3852. character(kind=CK,len=*),dimension(:),intent(in) :: value !! the vector to add
  3853. logical(LK),intent(out),optional :: found !! if the variable was found
  3854. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3855. integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
  3856. !! element in `value`. If not present,
  3857. !! the full `len(value)` string is added
  3858. !! for each element.
  3859. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3860. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3861. call json%json_add_string_vec_by_path(me,to_unicode(path),value,&
  3862. found,was_created,ilen,trim_str,adjustl_str)
  3863. end subroutine json_add_string_vec_by_path_path_ascii
  3864. !*****************************************************************************************
  3865. !*****************************************************************************************
  3866. !> author: Jacob Williams
  3867. ! date: 1/19/2014
  3868. !
  3869. ! Add a real value child to the [[json_value]] variable.
  3870. !
  3871. !@note This routine is part of the public API that can be
  3872. ! used to build a JSON structure using [[json_value]] pointers.
  3873. subroutine json_value_add_real(json,p,name,val)
  3874. implicit none
  3875. class(json_core),intent(inout) :: json
  3876. type(json_value),pointer :: p
  3877. character(kind=CK,len=*),intent(in) :: name !! variable name
  3878. real(RK),intent(in) :: val !! real value
  3879. type(json_value),pointer :: var
  3880. !create the variable:
  3881. call json%create_real(var,val,name)
  3882. !add it:
  3883. call json%add(p, var)
  3884. end subroutine json_value_add_real
  3885. !*****************************************************************************************
  3886. !*****************************************************************************************
  3887. !>
  3888. ! Alternate version of [[json_value_add_real]] where `name` is kind=CDK.
  3889. subroutine wrap_json_value_add_real(json,p,name,val)
  3890. implicit none
  3891. class(json_core),intent(inout) :: json
  3892. type(json_value),pointer :: p
  3893. character(kind=CDK,len=*),intent(in) :: name !! variable name
  3894. real(RK),intent(in) :: val !! real value
  3895. call json%add(p, to_unicode(name), val)
  3896. end subroutine wrap_json_value_add_real
  3897. !*****************************************************************************************
  3898. !*****************************************************************************************
  3899. !> author: Jacob Williams
  3900. ! date: 1/20/2014
  3901. !
  3902. ! Add a real vector child to the [[json_value]] variable.
  3903. !
  3904. !@note This routine is part of the public API that can be
  3905. ! used to build a JSON structure using [[json_value]] pointers.
  3906. subroutine json_value_add_real_vec(json, p, name, val)
  3907. implicit none
  3908. class(json_core),intent(inout) :: json
  3909. type(json_value),pointer :: p
  3910. character(kind=CK,len=*),intent(in) :: name
  3911. real(RK),dimension(:),intent(in) :: val
  3912. type(json_value),pointer :: var
  3913. integer(IK) :: i !! counter
  3914. !create the variable as an array:
  3915. call json%create_array(var,name)
  3916. !populate the array:
  3917. do i=1,size(val)
  3918. call json%add(var, CK_'', val(i))
  3919. end do
  3920. !add it:
  3921. call json%add(p, var)
  3922. end subroutine json_value_add_real_vec
  3923. !*****************************************************************************************
  3924. !*****************************************************************************************
  3925. !>
  3926. ! Alternate version of [[json_value_add_real_vec]] where `name` is kind=CDK.
  3927. subroutine wrap_json_value_add_real_vec(json, p, name, val)
  3928. implicit none
  3929. class(json_core),intent(inout) :: json
  3930. type(json_value),pointer :: p
  3931. character(kind=CDK,len=*),intent(in) :: name
  3932. real(RK),dimension(:),intent(in) :: val
  3933. call json%add(p, to_unicode(name), val)
  3934. end subroutine wrap_json_value_add_real_vec
  3935. !*****************************************************************************************
  3936. !*****************************************************************************************
  3937. !>
  3938. ! Alternate version of [[json_value_add_real]] where `val` is `real32`.
  3939. subroutine json_value_add_real32(json,p,name,val)
  3940. implicit none
  3941. class(json_core),intent(inout) :: json
  3942. type(json_value),pointer :: p
  3943. character(kind=CK,len=*),intent(in) :: name !! variable name
  3944. real(real32),intent(in) :: val !! real value
  3945. call json%add(p,name,real(val,RK))
  3946. end subroutine json_value_add_real32
  3947. !*****************************************************************************************
  3948. !*****************************************************************************************
  3949. !>
  3950. ! Alternate version of [[json_value_add_real32]] where `name` is kind=CDK.
  3951. subroutine wrap_json_value_add_real32(json,p,name,val)
  3952. implicit none
  3953. class(json_core),intent(inout) :: json
  3954. type(json_value),pointer :: p
  3955. character(kind=CDK,len=*),intent(in) :: name !! variable name
  3956. real(real32),intent(in) :: val !! real value
  3957. call json%add(p, to_unicode(name), val)
  3958. end subroutine wrap_json_value_add_real32
  3959. !*****************************************************************************************
  3960. !*****************************************************************************************
  3961. !>
  3962. ! Alternate version of [[json_value_add_real_vec]] where `val` is `real32`.
  3963. subroutine json_value_add_real32_vec(json, p, name, val)
  3964. implicit none
  3965. class(json_core),intent(inout) :: json
  3966. type(json_value),pointer :: p
  3967. character(kind=CK,len=*),intent(in) :: name
  3968. real(real32),dimension(:),intent(in) :: val
  3969. call json%add(p,name,real(val,RK))
  3970. end subroutine json_value_add_real32_vec
  3971. !*****************************************************************************************
  3972. !*****************************************************************************************
  3973. !>
  3974. ! Alternate version of [[json_value_add_real32_vec]] where `name` is kind=CDK.
  3975. subroutine wrap_json_value_add_real32_vec(json, p, name, val)
  3976. implicit none
  3977. class(json_core),intent(inout) :: json
  3978. type(json_value),pointer :: p
  3979. character(kind=CDK,len=*),intent(in) :: name
  3980. real(real32),dimension(:),intent(in) :: val
  3981. call json%add(p, to_unicode(name), val)
  3982. end subroutine wrap_json_value_add_real32_vec
  3983. !*****************************************************************************************
  3984. # 4868
  3985. !*****************************************************************************************
  3986. !>
  3987. ! Add a NULL value child to the [[json_value]] variable.
  3988. !
  3989. !@note This routine is part of the public API that can be
  3990. ! used to build a JSON structure using [[json_value]] pointers.
  3991. subroutine json_value_add_null(json, p, name)
  3992. implicit none
  3993. class(json_core),intent(inout) :: json
  3994. type(json_value),pointer :: p
  3995. character(kind=CK,len=*),intent(in) :: name
  3996. type(json_value),pointer :: var
  3997. !create the variable:
  3998. call json%create_null(var,name)
  3999. !add it:
  4000. call json%add(p, var)
  4001. end subroutine json_value_add_null
  4002. !*****************************************************************************************
  4003. !*****************************************************************************************
  4004. !>
  4005. ! Alternate version of [[json_value_add_null]] where `name` is kind=CDK.
  4006. subroutine wrap_json_value_add_null(json, p, name)
  4007. implicit none
  4008. class(json_core),intent(inout) :: json
  4009. type(json_value),pointer :: p
  4010. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4011. call json%add(p, to_unicode(name))
  4012. end subroutine wrap_json_value_add_null
  4013. !*****************************************************************************************
  4014. !*****************************************************************************************
  4015. !> author: Jacob Williams
  4016. ! date: 1/20/2014
  4017. !
  4018. ! Add an integer value child to the [[json_value]] variable.
  4019. !
  4020. !@note This routine is part of the public API that can be
  4021. ! used to build a JSON structure using [[json_value]] pointers.
  4022. subroutine json_value_add_integer(json, p, name, val)
  4023. implicit none
  4024. class(json_core),intent(inout) :: json
  4025. type(json_value),pointer :: p
  4026. character(kind=CK,len=*),intent(in) :: name
  4027. integer(IK),intent(in) :: val
  4028. type(json_value),pointer :: var
  4029. !create the variable:
  4030. call json%create_integer(var,val,name)
  4031. !add it:
  4032. call json%add(p, var)
  4033. end subroutine json_value_add_integer
  4034. !*****************************************************************************************
  4035. !*****************************************************************************************
  4036. !>
  4037. ! Alternate version of [[json_value_add_integer]] where `name` is kind=CDK.
  4038. subroutine wrap_json_value_add_integer(json, p, name, val)
  4039. implicit none
  4040. class(json_core),intent(inout) :: json
  4041. type(json_value),pointer :: p
  4042. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4043. integer(IK),intent(in) :: val !! value
  4044. call json%add(p, to_unicode(name), val)
  4045. end subroutine wrap_json_value_add_integer
  4046. !*****************************************************************************************
  4047. !*****************************************************************************************
  4048. !> author: Jacob Williams
  4049. ! date: 1/20/2014
  4050. !
  4051. ! Add a integer vector child to the [[json_value]] variable.
  4052. !
  4053. !@note This routine is part of the public API that can be
  4054. ! used to build a JSON structure using [[json_value]] pointers.
  4055. subroutine json_value_add_integer_vec(json, p, name, val)
  4056. implicit none
  4057. class(json_core),intent(inout) :: json
  4058. type(json_value),pointer :: p
  4059. character(kind=CK,len=*),intent(in) :: name !! name of the variable
  4060. integer(IK),dimension(:),intent(in) :: val !! value
  4061. type(json_value),pointer :: var
  4062. integer(IK) :: i !! counter
  4063. !create a variable as an array:
  4064. call json%create_array(var,name)
  4065. !populate the array:
  4066. do i=1,size(val)
  4067. call json%add(var, CK_'', val(i))
  4068. end do
  4069. !add it:
  4070. call json%add(p, var)
  4071. end subroutine json_value_add_integer_vec
  4072. !*****************************************************************************************
  4073. !*****************************************************************************************
  4074. !>
  4075. ! Alternate version of [[json_value_add_integer_vec]] where `name` is kind=CDK.
  4076. subroutine wrap_json_value_add_integer_vec(json, p, name, val)
  4077. implicit none
  4078. class(json_core),intent(inout) :: json
  4079. type(json_value),pointer :: p
  4080. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4081. integer(IK),dimension(:),intent(in) :: val !! value
  4082. call json%add(p, to_unicode(name), val)
  4083. end subroutine wrap_json_value_add_integer_vec
  4084. !*****************************************************************************************
  4085. !*****************************************************************************************
  4086. !> author: Jacob Williams
  4087. ! date: 1/20/2014
  4088. !
  4089. ! Add a logical value child to the [[json_value]] variable.
  4090. !
  4091. !@note This routine is part of the public API that can be
  4092. ! used to build a JSON structure using [[json_value]] pointers.
  4093. subroutine json_value_add_logical(json, p, name, val)
  4094. implicit none
  4095. class(json_core),intent(inout) :: json
  4096. type(json_value),pointer :: p
  4097. character(kind=CK,len=*),intent(in) :: name !! name of the variable
  4098. logical(LK),intent(in) :: val !! value
  4099. type(json_value),pointer :: var
  4100. !create the variable:
  4101. call json%create_logical(var,val,name)
  4102. !add it:
  4103. call json%add(p, var)
  4104. end subroutine json_value_add_logical
  4105. !*****************************************************************************************
  4106. !*****************************************************************************************
  4107. !>
  4108. ! Alternate version of [[json_value_add_logical]] where `name` is kind=CDK.
  4109. subroutine wrap_json_value_add_logical(json, p, name, val)
  4110. implicit none
  4111. class(json_core),intent(inout) :: json
  4112. type(json_value),pointer :: p
  4113. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4114. logical(LK),intent(in) :: val !! value
  4115. call json%add(p, to_unicode(name), val)
  4116. end subroutine wrap_json_value_add_logical
  4117. !*****************************************************************************************
  4118. !*****************************************************************************************
  4119. !> author: Jacob Williams
  4120. ! date: 1/20/2014
  4121. !
  4122. ! Add a logical vector child to the [[json_value]] variable.
  4123. !
  4124. !@note This routine is part of the public API that can be
  4125. ! used to build a JSON structure using [[json_value]] pointers.
  4126. subroutine json_value_add_logical_vec(json, p, name, val)
  4127. implicit none
  4128. class(json_core),intent(inout) :: json
  4129. type(json_value),pointer :: p
  4130. character(kind=CK,len=*),intent(in) :: name !! name of the vector
  4131. logical(LK),dimension(:),intent(in) :: val !! value
  4132. type(json_value),pointer :: var
  4133. integer(IK) :: i !! counter
  4134. !create the variable as an array:
  4135. call json%create_array(var,name)
  4136. !populate the array:
  4137. do i=1,size(val)
  4138. call json%add(var, CK_'', val(i))
  4139. end do
  4140. !add it:
  4141. call json%add(p, var)
  4142. end subroutine json_value_add_logical_vec
  4143. !*****************************************************************************************
  4144. !*****************************************************************************************
  4145. !>
  4146. ! Alternate version of [[json_value_add_logical_vec]] where `name` is kind=CDK.
  4147. subroutine wrap_json_value_add_logical_vec(json, p, name, val)
  4148. implicit none
  4149. class(json_core),intent(inout) :: json
  4150. type(json_value),pointer :: p
  4151. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4152. logical(LK),dimension(:),intent(in) :: val !! value
  4153. call json%add(p, to_unicode(name), val)
  4154. end subroutine wrap_json_value_add_logical_vec
  4155. !*****************************************************************************************
  4156. !*****************************************************************************************
  4157. !> author: Jacob Williams
  4158. ! date: 1/19/2014
  4159. !
  4160. ! Add a character string child to the [[json_value]] variable.
  4161. !
  4162. !@note This routine is part of the public API that can be
  4163. ! used to build a JSON structure using [[json_value]] pointers.
  4164. subroutine json_value_add_string(json, p, name, val, trim_str, adjustl_str)
  4165. implicit none
  4166. class(json_core),intent(inout) :: json
  4167. type(json_value),pointer :: p
  4168. character(kind=CK,len=*),intent(in) :: name !! name of the variable
  4169. character(kind=CK,len=*),intent(in) :: val !! value
  4170. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  4171. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  4172. type(json_value),pointer :: var
  4173. !create the variable:
  4174. call json%create_string(var,val,name,trim_str,adjustl_str)
  4175. !add it:
  4176. call json%add(p, var)
  4177. end subroutine json_value_add_string
  4178. !*****************************************************************************************
  4179. !*****************************************************************************************
  4180. !>
  4181. ! Alternate version of [[json_value_add_string]] where `name` and `val` are kind=CDK.
  4182. subroutine wrap_json_value_add_string(json, p, name, val, trim_str, adjustl_str)
  4183. implicit none
  4184. class(json_core),intent(inout) :: json
  4185. type(json_value),pointer :: p
  4186. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4187. character(kind=CDK,len=*),intent(in) :: val !! value
  4188. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  4189. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  4190. call json%add(p, to_unicode(name), to_unicode(val), trim_str, adjustl_str)
  4191. end subroutine wrap_json_value_add_string
  4192. !*****************************************************************************************
  4193. !*****************************************************************************************
  4194. !>
  4195. ! Alternate version of [[json_value_add_string]] where `name` is kind=CDK.
  4196. subroutine json_value_add_string_name_ascii(json, p, name, val, trim_str, adjustl_str)
  4197. implicit none
  4198. class(json_core),intent(inout) :: json
  4199. type(json_value),pointer :: p
  4200. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4201. character(kind=CK, len=*),intent(in) :: val !! value
  4202. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  4203. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  4204. call json%add(p, to_unicode(name), val, trim_str, adjustl_str)
  4205. end subroutine json_value_add_string_name_ascii
  4206. !*****************************************************************************************
  4207. !*****************************************************************************************
  4208. !>
  4209. ! Alternate version of [[json_value_add_string]] where `val` is kind=CDK.
  4210. subroutine json_value_add_string_val_ascii(json, p, name, val, trim_str, adjustl_str)
  4211. implicit none
  4212. class(json_core),intent(inout) :: json
  4213. type(json_value),pointer :: p
  4214. character(kind=CK, len=*),intent(in) :: name !! name of the variable
  4215. character(kind=CDK,len=*),intent(in) :: val !! value
  4216. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  4217. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  4218. call json%add(p, name, to_unicode(val), trim_str, adjustl_str)
  4219. end subroutine json_value_add_string_val_ascii
  4220. !*****************************************************************************************
  4221. !*****************************************************************************************
  4222. !> author: Jacob Williams
  4223. ! date: 1/19/2014
  4224. !
  4225. ! Add a character string vector child to the [[json_value]] variable.
  4226. !
  4227. !@note This routine is part of the public API that can be
  4228. ! used to build a JSON structure using [[json_value]] pointers.
  4229. subroutine json_value_add_string_vec(json, p, name, val, trim_str, adjustl_str)
  4230. implicit none
  4231. class(json_core),intent(inout) :: json
  4232. type(json_value),pointer :: p
  4233. character(kind=CK,len=*),intent(in) :: name !! variable name
  4234. character(kind=CK,len=*),dimension(:),intent(in) :: val !! array of strings
  4235. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  4236. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  4237. type(json_value),pointer :: var
  4238. integer(IK) :: i !! counter
  4239. !create the variable as an array:
  4240. call json%create_array(var,name)
  4241. !populate the array:
  4242. do i=1,size(val)
  4243. call json%add(var, CK_'', val(i), trim_str, adjustl_str)
  4244. end do
  4245. !add it:
  4246. call json%add(p, var)
  4247. end subroutine json_value_add_string_vec
  4248. !*****************************************************************************************
  4249. !*****************************************************************************************
  4250. !>
  4251. ! Alternate version of [[json_value_add_string_vec]] where `name` and `val` are kind=CDK.
  4252. subroutine wrap_json_value_add_string_vec(json, p, name, val, trim_str, adjustl_str)
  4253. implicit none
  4254. class(json_core),intent(inout) :: json
  4255. type(json_value),pointer :: p
  4256. character(kind=CDK,len=*),intent(in) :: name
  4257. character(kind=CDK,len=*),dimension(:),intent(in) :: val
  4258. logical(LK),intent(in),optional :: trim_str
  4259. logical(LK),intent(in),optional :: adjustl_str
  4260. call json%add(p, to_unicode(name), to_unicode(val), trim_str, adjustl_str)
  4261. end subroutine wrap_json_value_add_string_vec
  4262. !*****************************************************************************************
  4263. !*****************************************************************************************
  4264. !>
  4265. ! Alternate version of [[json_value_add_string_vec]] where `name` is kind=CDK.
  4266. subroutine json_value_add_string_vec_name_ascii(json, p, name, val, trim_str, adjustl_str)
  4267. implicit none
  4268. class(json_core),intent(inout) :: json
  4269. type(json_value),pointer :: p
  4270. character(kind=CDK,len=*),intent(in) :: name
  4271. character(kind=CK, len=*),dimension(:),intent(in) :: val
  4272. logical(LK),intent(in),optional :: trim_str
  4273. logical(LK),intent(in),optional :: adjustl_str
  4274. call json%add(p, to_unicode(name), val, trim_str, adjustl_str)
  4275. end subroutine json_value_add_string_vec_name_ascii
  4276. !*****************************************************************************************
  4277. !*****************************************************************************************
  4278. !>
  4279. ! Alternate version of [[json_value_add_string_vec]] where `val` is kind=CDK.
  4280. subroutine json_value_add_string_vec_val_ascii(json, p, name, val, trim_str, adjustl_str)
  4281. implicit none
  4282. class(json_core),intent(inout) :: json
  4283. type(json_value),pointer :: p
  4284. character(kind=CK, len=*),intent(in) :: name
  4285. character(kind=CDK,len=*),dimension(:),intent(in) :: val
  4286. logical(LK),intent(in),optional :: trim_str
  4287. logical(LK),intent(in),optional :: adjustl_str
  4288. call json%add(p, name, to_unicode(val), trim_str, adjustl_str)
  4289. end subroutine json_value_add_string_vec_val_ascii
  4290. !*****************************************************************************************
  4291. !*****************************************************************************************
  4292. !>
  4293. ! Count the number of children in the object or array.
  4294. !
  4295. !### History
  4296. ! * JW : 1/4/2014 : Original routine removed.
  4297. ! Now using `n_children` variable.
  4298. ! Renamed from `json_value_count`.
  4299. function json_count(json,p) result(count)
  4300. implicit none
  4301. class(json_core),intent(inout) :: json
  4302. type(json_value),pointer,intent(in) :: p !! this should normally be a `json_object`
  4303. !! or a `json_array`. For any other
  4304. !! variable type this will return 0.
  4305. integer(IK) :: count !! number of children in `p`.
  4306. if (associated(p)) then
  4307. count = p%n_children
  4308. else
  4309. call json%throw_exception('Error in json_count: '//&
  4310. 'pointer is not associated.')
  4311. end if
  4312. end function json_count
  4313. !*****************************************************************************************
  4314. !*****************************************************************************************
  4315. !> author: Jacob Williams
  4316. ! date: 10/16/2015
  4317. !
  4318. ! Returns a pointer to the parent of a [[json_value]].
  4319. ! If there is no parent, then a `null()` pointer is returned.
  4320. subroutine json_get_parent(json,p,parent)
  4321. implicit none
  4322. class(json_core),intent(inout) :: json
  4323. type(json_value),pointer,intent(in) :: p !! JSON object
  4324. type(json_value),pointer,intent(out) :: parent !! pointer to `parent`
  4325. if (associated(p)) then
  4326. parent => p%parent
  4327. else
  4328. nullify(parent)
  4329. call json%throw_exception('Error in json_get_parent: '//&
  4330. 'pointer is not associated.')
  4331. end if
  4332. end subroutine json_get_parent
  4333. !*****************************************************************************************
  4334. !*****************************************************************************************
  4335. !> author: Jacob Williams
  4336. ! date: 10/31/2015
  4337. !
  4338. ! Returns a pointer to the next of a [[json_value]].
  4339. ! If there is no next, then a `null()` pointer is returned.
  4340. subroutine json_get_next(json,p,next)
  4341. implicit none
  4342. class(json_core),intent(inout) :: json
  4343. type(json_value),pointer,intent(in) :: p !! JSON object
  4344. type(json_value),pointer,intent(out) :: next !! pointer to `next`
  4345. if (associated(p)) then
  4346. next => p%next
  4347. else
  4348. nullify(next)
  4349. call json%throw_exception('Error in json_get_next: '//&
  4350. 'pointer is not associated.')
  4351. end if
  4352. end subroutine json_get_next
  4353. !*****************************************************************************************
  4354. !*****************************************************************************************
  4355. !> author: Jacob Williams
  4356. ! date: 10/31/2015
  4357. !
  4358. ! Returns a pointer to the previous of a [[json_value]].
  4359. ! If there is no previous, then a `null()` pointer is returned.
  4360. subroutine json_get_previous(json,p,previous)
  4361. implicit none
  4362. class(json_core),intent(inout) :: json
  4363. type(json_value),pointer,intent(in) :: p !! JSON object
  4364. type(json_value),pointer,intent(out) :: previous !! pointer to `previous`
  4365. if (associated(p)) then
  4366. previous => p%previous
  4367. else
  4368. nullify(previous)
  4369. call json%throw_exception('Error in json_get_previous: '//&
  4370. 'pointer is not associated.')
  4371. end if
  4372. end subroutine json_get_previous
  4373. !*****************************************************************************************
  4374. !*****************************************************************************************
  4375. !> author: Jacob Williams
  4376. ! date: 10/31/2015
  4377. !
  4378. ! Returns a pointer to the tail of a [[json_value]]
  4379. ! (the last child of an array of object).
  4380. ! If there is no tail, then a `null()` pointer is returned.
  4381. subroutine json_get_tail(json,p,tail)
  4382. implicit none
  4383. class(json_core),intent(inout) :: json
  4384. type(json_value),pointer,intent(in) :: p !! JSON object
  4385. type(json_value),pointer,intent(out) :: tail !! pointer to `tail`
  4386. if (associated(p)) then
  4387. tail => p%tail
  4388. else
  4389. nullify(tail)
  4390. call json%throw_exception('Error in json_get_tail: '//&
  4391. 'pointer is not associated.')
  4392. end if
  4393. end subroutine json_get_tail
  4394. !*****************************************************************************************
  4395. !*****************************************************************************************
  4396. !>
  4397. ! Returns a child in the object or array given the index.
  4398. subroutine json_value_get_child_by_index(json, p, idx, child, found)
  4399. implicit none
  4400. class(json_core),intent(inout) :: json
  4401. type(json_value),pointer,intent(in) :: p !! object or array JSON data
  4402. integer(IK),intent(in) :: idx !! index of the child
  4403. !! (this is a 1-based Fortran
  4404. !! style array index).
  4405. type(json_value),pointer :: child !! pointer to the child
  4406. logical(LK),intent(out),optional :: found !! true if the value was found
  4407. !! (if not present, an exception
  4408. !! will be thrown if it was not
  4409. !! found. If present and not
  4410. !! found, no exception will be
  4411. !! thrown).
  4412. integer(IK) :: i !! counter
  4413. nullify(child)
  4414. if (.not. json%exception_thrown) then
  4415. if (associated(p%children)) then
  4416. ! If getting first or last child, we can do this quickly.
  4417. ! Otherwise, traverse the list.
  4418. if (idx==1) then
  4419. child => p%children ! first one
  4420. elseif (idx==p%n_children) then
  4421. if (associated(p%tail)) then
  4422. child => p%tail ! last one
  4423. else
  4424. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4425. ' child%tail is not associated.',found)
  4426. end if
  4427. elseif (idx<1 .or. idx>p%n_children) then
  4428. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4429. ' idx is out of range.',found)
  4430. else
  4431. ! if idx is closer to the end, we traverse the list backward from tail,
  4432. ! otherwise we traverse it forward from children:
  4433. if (p%n_children-idx < idx) then ! traverse backward
  4434. child => p%tail
  4435. do i = 1, p%n_children - idx
  4436. if (associated(child%previous)) then
  4437. child => child%previous
  4438. else
  4439. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4440. ' child%previous is not associated.',found)
  4441. nullify(child)
  4442. exit
  4443. end if
  4444. end do
  4445. else ! traverse forward
  4446. child => p%children
  4447. do i = 1, idx - 1
  4448. if (associated(child%next)) then
  4449. child => child%next
  4450. else
  4451. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4452. ' child%next is not associated.',found)
  4453. nullify(child)
  4454. exit
  4455. end if
  4456. end do
  4457. end if
  4458. end if
  4459. else
  4460. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4461. ' p%children is not associated.',found)
  4462. end if
  4463. ! found output:
  4464. if (json%exception_thrown) then
  4465. if (present(found)) then
  4466. call json%clear_exceptions()
  4467. found = .false.
  4468. end if
  4469. else
  4470. if (present(found)) found = .true.
  4471. end if
  4472. else
  4473. if (present(found)) found = .false.
  4474. end if
  4475. end subroutine json_value_get_child_by_index
  4476. !*****************************************************************************************
  4477. !*****************************************************************************************
  4478. !>
  4479. ! Returns pointer to the first child of the object
  4480. ! (or `null()` if it is not associated).
  4481. subroutine json_value_get_child(json, p, child)
  4482. implicit none
  4483. class(json_core),intent(inout) :: json
  4484. type(json_value),pointer,intent(in) :: p !! object or array JSON data
  4485. type(json_value),pointer :: child !! pointer to the child
  4486. if (associated(p)) then
  4487. child => p%children
  4488. else
  4489. nullify(child)
  4490. call json%throw_exception('Error in json_value_get_child: '//&
  4491. 'pointer is not associated.')
  4492. end if
  4493. end subroutine json_value_get_child
  4494. !*****************************************************************************************
  4495. !*****************************************************************************************
  4496. !>
  4497. ! Returns a child in the object or array given the name string.
  4498. !
  4499. ! The name search can be case-sensitive or not, and can have significant trailing
  4500. ! whitespace or not, depending on the settings in the [[json_core(type)]] class.
  4501. !
  4502. !@note The `name` input is not a path, and is not parsed like it is in [[json_get_by_path]].
  4503. subroutine json_value_get_child_by_name(json, p, name, child, found)
  4504. implicit none
  4505. class(json_core),intent(inout) :: json
  4506. type(json_value),pointer,intent(in) :: p
  4507. character(kind=CK,len=*),intent(in) :: name !! the name of a child of `p`
  4508. type(json_value),pointer :: child !! pointer to the child
  4509. logical(LK),intent(out),optional :: found !! true if the value was found
  4510. !! (if not present, an exception
  4511. !! will be thrown if it was not
  4512. !! found. If present and not
  4513. !! found, no exception will be
  4514. !! thrown).
  4515. integer(IK) :: i,n_children
  4516. logical :: error
  4517. nullify(child)
  4518. if (.not. json%exception_thrown) then
  4519. if (associated(p)) then
  4520. error = .true. ! will be false if it is found
  4521. if (p%var_type==json_object) then
  4522. n_children = json%count(p)
  4523. child => p%children !start with first one
  4524. do i=1, n_children
  4525. if (.not. associated(child)) then
  4526. call json%throw_exception(&
  4527. 'Error in json_value_get_child_by_name: '//&
  4528. 'Malformed JSON linked list',found)
  4529. exit
  4530. end if
  4531. if (allocated(child%name)) then
  4532. !name string matching routine:
  4533. if (json%name_equal(child,name)) then
  4534. error = .false.
  4535. exit
  4536. end if
  4537. end if
  4538. child => child%next
  4539. end do
  4540. end if
  4541. if (error) then
  4542. !did not find anything:
  4543. call json%throw_exception(&
  4544. 'Error in json_value_get_child_by_name: '//&
  4545. 'child variable '//trim(name)//' was not found.',found)
  4546. nullify(child)
  4547. end if
  4548. else
  4549. call json%throw_exception(&
  4550. 'Error in json_value_get_child_by_name: '//&
  4551. 'pointer is not associated.',found)
  4552. end if
  4553. ! found output:
  4554. if (json%exception_thrown) then
  4555. if (present(found)) then
  4556. call json%clear_exceptions()
  4557. found = .false.
  4558. end if
  4559. else
  4560. if (present(found)) found = .true.
  4561. end if
  4562. else
  4563. if (present(found)) found = .false.
  4564. end if
  4565. end subroutine json_value_get_child_by_name
  4566. !*****************************************************************************************
  4567. !*****************************************************************************************
  4568. !> author: Jacob Williams
  4569. ! date: 8/25/2017
  4570. !
  4571. ! Checks a JSON object for duplicate child names.
  4572. !
  4573. ! It uses the specified settings for name matching (see [[name_strings_equal]]).
  4574. !
  4575. !@note This will only check for one duplicate,
  4576. ! it will return the first one that it finds.
  4577. subroutine json_check_children_for_duplicate_keys(json,p,has_duplicate,name,path)
  4578. implicit none
  4579. class(json_core),intent(inout) :: json
  4580. type(json_value),pointer,intent(in) :: p !! the object to search. If `p` is
  4581. !! not a `json_object`, then `has_duplicate`
  4582. !! will be false.
  4583. logical(LK),intent(out) :: has_duplicate !! true if there is at least
  4584. !! two children have duplicate
  4585. !! `name` values.
  4586. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! the duplicate name
  4587. !! (unallocated if no
  4588. !! duplicate was found)
  4589. character(kind=CK,len=:),allocatable,intent(out),optional :: path !! the full path to the
  4590. !! duplicate name
  4591. !! (unallocated if no
  4592. !! duplicate was found)
  4593. integer(IK) :: i !! counter
  4594. integer(IK) :: j !! counter
  4595. type(json_value),pointer :: child !! pointer to a child of `p`
  4596. integer(IK) :: n_children !! number of children of `p`
  4597. logical(LK) :: found !! flag for `get_child`
  4598. type :: alloc_str
  4599. !! so we can have an array of allocatable strings
  4600. character(kind=CK,len=:),allocatable :: str !! name string
  4601. end type alloc_str
  4602. type(alloc_str),dimension(:),allocatable :: names !! array of all the
  4603. !! child name strings
  4604. ! initialize:
  4605. has_duplicate =.false.
  4606. if (.not. json%exception_thrown) then
  4607. if (associated(p)) then
  4608. if (p%var_type==json_object) then
  4609. ! number of items to check:
  4610. n_children = json%count(p)
  4611. allocate(names(n_children))
  4612. ! first get a list of all the name keys:
  4613. do i=1, n_children
  4614. call json%get_child(p,i,child,found) ! get by index
  4615. if (.not. found) then
  4616. call json%throw_exception(&
  4617. 'Error in json_check_children_for_duplicate_keys: '//&
  4618. 'Malformed JSON linked list')
  4619. exit
  4620. end if
  4621. if (allocated(child%name)) then
  4622. names(i)%str = child%name
  4623. else
  4624. call json%throw_exception(&
  4625. 'Error in json_check_children_for_duplicate_keys: '//&
  4626. 'Object child name is not allocated')
  4627. exit
  4628. end if
  4629. end do
  4630. if (.not. json%exception_thrown) then
  4631. ! now check the list for duplicates:
  4632. main: do i=1,n_children
  4633. do j=1,i-1
  4634. if (json%name_strings_equal(names(i)%str,names(j)%str)) then
  4635. has_duplicate = .true.
  4636. if (present(name)) then
  4637. name = names(i)%str
  4638. end if
  4639. if (present(path)) then
  4640. call json%get_child(p,names(i)%str,child,found) ! get by name
  4641. if (found) then
  4642. call json%get_path(child,path,found)
  4643. if (.not. found) then
  4644. ! should never happen since we know it is there
  4645. call json%throw_exception(&
  4646. 'Error in json_check_children_for_duplicate_keys: '//&
  4647. 'Could not get path')
  4648. end if
  4649. else
  4650. ! should never happen since we know it is there
  4651. call json%throw_exception(&
  4652. 'Error in json_check_children_for_duplicate_keys: '//&
  4653. 'Could not get child: '//trim(names(i)%str))
  4654. end if
  4655. end if
  4656. exit main
  4657. end if
  4658. end do
  4659. end do main
  4660. end if
  4661. ! cleanup
  4662. do i=1,n_children
  4663. if (allocated(names(i)%str)) deallocate(names(i)%str)
  4664. end do
  4665. if (allocated(names)) deallocate(names)
  4666. end if
  4667. end if
  4668. end if
  4669. end subroutine json_check_children_for_duplicate_keys
  4670. !*****************************************************************************************
  4671. !*****************************************************************************************
  4672. !> author: Jacob Williams
  4673. ! date: 8/25/2017
  4674. !
  4675. ! Checks a JSON structure for duplicate child names.
  4676. ! This one recursively traverses the entire structure
  4677. ! (calling [[json_check_children_for_duplicate_keys]]
  4678. ! recursively for each element).
  4679. !
  4680. !@note This will only check for one duplicate,
  4681. ! it will return the first one that it finds.
  4682. subroutine json_check_all_for_duplicate_keys(json,p,has_duplicate,name,path)
  4683. implicit none
  4684. class(json_core),intent(inout) :: json
  4685. type(json_value),pointer,intent(in) :: p !! the object to search. If `p` is
  4686. !! not a `json_object`, then `has_duplicate`
  4687. !! will be false.
  4688. logical(LK),intent(out) :: has_duplicate !! true if there is at least
  4689. !! one duplicate `name` key anywhere
  4690. !! in the structure.
  4691. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! the duplicate name
  4692. !! (unallocated if no
  4693. !! duplicates were found)
  4694. character(kind=CK,len=:),allocatable,intent(out),optional :: path !! the full path to the
  4695. !! duplicate name
  4696. !! (unallocated if no
  4697. !! duplicate was found)
  4698. has_duplicate = .false.
  4699. if (.not. json%exception_thrown) then
  4700. call json%traverse(p,duplicate_key_func)
  4701. end if
  4702. contains
  4703. subroutine duplicate_key_func(json,p,finished)
  4704. !! Callback function to check each element
  4705. !! for duplicate child names.
  4706. implicit none
  4707. class(json_core),intent(inout) :: json
  4708. type(json_value),pointer,intent(in) :: p
  4709. logical(LK),intent(out) :: finished
  4710. # 5854
  4711. call json%check_children_for_duplicate_keys(p,has_duplicate,name,path)
  4712. finished = has_duplicate .or. json%exception_thrown
  4713. end subroutine duplicate_key_func
  4714. end subroutine json_check_all_for_duplicate_keys
  4715. !*****************************************************************************************
  4716. !*****************************************************************************************
  4717. !>
  4718. ! Alternate version of [[json_value_get_child_by_name]] where `name` is kind=CDK.
  4719. subroutine wrap_json_value_get_child_by_name(json, p, name, child, found)
  4720. implicit none
  4721. class(json_core),intent(inout) :: json
  4722. type(json_value),pointer,intent(in) :: p
  4723. character(kind=CDK,len=*),intent(in) :: name
  4724. type(json_value),pointer :: child
  4725. logical(LK),intent(out),optional :: found
  4726. call json%get(p,to_unicode(name),child,found)
  4727. end subroutine wrap_json_value_get_child_by_name
  4728. !*****************************************************************************************
  4729. !*****************************************************************************************
  4730. !> author: Jacob Williams
  4731. ! date: 2/12/2014
  4732. !
  4733. ! Print the [[json_value]] structure to an allocatable string.
  4734. subroutine json_value_to_string(json,p,str)
  4735. implicit none
  4736. class(json_core),intent(inout) :: json
  4737. type(json_value),pointer,intent(in) :: p
  4738. character(kind=CK,len=:),intent(out),allocatable :: str !! prints structure to this string
  4739. integer(IK) :: iloc !! used to keep track of size of str
  4740. !! since it is being allocated in chunks.
  4741. str = repeat(space, print_str_chunk_size)
  4742. iloc = 0_IK
  4743. call json%json_value_print(p, iunit=unit2str, str=str, iloc=iloc, indent=1_IK, colon=.true.)
  4744. ! trim the string if necessary:
  4745. if (len(str)>iloc) str = str(1:iloc)
  4746. end subroutine json_value_to_string
  4747. !*****************************************************************************************
  4748. !*****************************************************************************************
  4749. !>
  4750. ! Print the [[json_value]] structure to the console (`output_unit`).
  4751. !
  4752. !### Note
  4753. ! * Just a wrapper for [[json_print_to_unit]].
  4754. subroutine json_print_to_console(json,p)
  4755. implicit none
  4756. class(json_core),intent(inout) :: json
  4757. type(json_value),pointer,intent(in) :: p
  4758. call json%print(p,int(output_unit,IK))
  4759. end subroutine json_print_to_console
  4760. !*****************************************************************************************
  4761. !*****************************************************************************************
  4762. !> author: Jacob Williams
  4763. ! date: 6/20/2014
  4764. !
  4765. ! Print the [[json_value]] structure to a file.
  4766. subroutine json_print_to_unit(json,p,iunit)
  4767. implicit none
  4768. class(json_core),intent(inout) :: json
  4769. type(json_value),pointer,intent(in) :: p
  4770. integer(IK),intent(in) :: iunit !! the file unit (the file must
  4771. !! already have been opened, can't be -1).
  4772. character(kind=CK,len=:),allocatable :: dummy !! dummy for `str` argument
  4773. !! to [[json_value_print]]
  4774. integer(IK) :: idummy !! dummy for `iloc` argument
  4775. !! to [[json_value_print]]
  4776. if (iunit/=unit2str) then
  4777. idummy = 0_IK
  4778. call json%json_value_print(p,iunit,str=dummy,iloc=idummy,indent=1_IK,colon=.true.)
  4779. else
  4780. call json%throw_exception('Error in json_print_to_unit: iunit must not be -1.')
  4781. end if
  4782. end subroutine json_print_to_unit
  4783. !*****************************************************************************************
  4784. !*****************************************************************************************
  4785. !> author: Jacob Williams
  4786. ! date: 12/23/2014
  4787. !
  4788. ! Print the [[json_value]] structure to a file.
  4789. subroutine json_print_to_filename(json,p,filename)
  4790. implicit none
  4791. class(json_core),intent(inout) :: json
  4792. type(json_value),pointer,intent(in) :: p
  4793. character(kind=CDK,len=*),intent(in) :: filename !! the filename to print to
  4794. !! (should not already be open)
  4795. integer(IK) :: iunit !! file unit for `open` statement
  4796. integer(IK) :: istat !! `iostat` code for `open` statement
  4797. open(newunit=iunit,file=filename,status='REPLACE',iostat=istat )
  4798. if (istat==0) then
  4799. call json%print(p,iunit)
  4800. close(iunit,iostat=istat)
  4801. else
  4802. call json%throw_exception('Error in json_print_to_filename: could not open file: '//&
  4803. trim(filename))
  4804. end if
  4805. end subroutine json_print_to_filename
  4806. !*****************************************************************************************
  4807. !*****************************************************************************************
  4808. !>
  4809. ! Print the JSON structure to a string or a file.
  4810. !
  4811. !### Notes
  4812. ! * This is an internal routine called by the various wrapper routines.
  4813. ! * The reason the `str` argument is non-optional is because of a
  4814. ! bug in v4.9 of the gfortran compiler.
  4815. recursive subroutine json_value_print(json,p,iunit,str,indent,&
  4816. need_comma,colon,is_array_element,&
  4817. is_compressed_vector,iloc)
  4818. implicit none
  4819. class(json_core),intent(inout) :: json
  4820. type(json_value),pointer,intent(in) :: p
  4821. integer(IK),intent(in) :: iunit !! file unit to write to (the
  4822. !! file is assumed to be open)
  4823. integer(IK),intent(in),optional :: indent !! indention level
  4824. logical(LK),intent(in),optional :: is_array_element !! if this is an array element
  4825. logical(LK),intent(in),optional :: need_comma !! if it needs a comma after it
  4826. logical(LK),intent(in),optional :: colon !! if the colon was just written
  4827. character(kind=CK,len=:),intent(inout),allocatable :: str
  4828. !! if `iunit==unit2str` (-1) then
  4829. !! the structure is printed to this
  4830. !! string rather than a file. This mode
  4831. !! is used by [[json_value_to_string]].
  4832. integer(IK),intent(inout) :: iloc !! current index in `str`. should be set to 0 initially.
  4833. !! [only used when `str` is used.]
  4834. logical(LK),intent(in),optional :: is_compressed_vector !! if True, this is an element
  4835. !! from an array being printed
  4836. !! on one line [default is False]
  4837. character(kind=CK,len=max_numeric_str_len) :: tmp !! for value to string conversions
  4838. character(kind=CK,len=:),allocatable :: s_indent !! the string of spaces for
  4839. !! indenting (see `tab` and `spaces`)
  4840. character(kind=CK,len=:),allocatable :: s !! the string appended to `str`
  4841. type(json_value),pointer :: element !! for getting children
  4842. integer(IK) :: tab !! number of `tabs` for indenting
  4843. integer(IK) :: spaces !! number of spaces for indenting
  4844. integer(IK) :: i !! counter
  4845. integer(IK) :: count !! number of children
  4846. logical(LK) :: print_comma !! if the comma will be printed after the value
  4847. logical(LK) :: write_file !! if we are writing to a file
  4848. logical(LK) :: write_string !! if we are writing to a string
  4849. logical(LK) :: is_array !! if this is an element in an array
  4850. logical(LK) :: is_vector !! if all elements of a vector
  4851. !! are scalars of the same type
  4852. character(kind=CK,len=:),allocatable :: str_escaped !! escaped version of
  4853. !! `name` or `str_value`
  4854. if (.not. json%exception_thrown) then
  4855. if (.not. associated(p)) then
  4856. ! note: a null() pointer will trigger this error.
  4857. ! However, if the pointer is undefined, then this will
  4858. ! crash (if this wasn't here it would crash below when
  4859. ! we try to access the contents)
  4860. call json%throw_exception('Error in json_value_print: '//&
  4861. 'the pointer is not associated')
  4862. return
  4863. end if
  4864. if (present(is_compressed_vector)) then
  4865. is_vector = is_compressed_vector
  4866. else
  4867. is_vector = .false.
  4868. end if
  4869. !whether to write a string or a file (one or the other):
  4870. write_string = (iunit==unit2str)
  4871. write_file = .not. write_string
  4872. !if the comma will be printed after the value
  4873. ! [comma not printed for the last elements]
  4874. if (present(need_comma)) then
  4875. print_comma = need_comma
  4876. else
  4877. print_comma = .false.
  4878. end if
  4879. !number of "tabs" to indent:
  4880. if (present(indent) .and. .not. json%no_whitespace) then
  4881. tab = indent
  4882. else
  4883. tab = 0
  4884. end if
  4885. !convert to number of spaces:
  4886. spaces = tab*json%spaces_per_tab
  4887. !if this is an element in an array:
  4888. if (present(is_array_element)) then
  4889. is_array = is_array_element
  4890. else
  4891. is_array = .false.
  4892. end if
  4893. !if the colon was the last thing written
  4894. if (present(colon)) then
  4895. s_indent = CK_''
  4896. else
  4897. s_indent = repeat(space, spaces)
  4898. end if
  4899. select case (p%var_type)
  4900. case (json_object)
  4901. count = json%count(p)
  4902. if (count==0) then !special case for empty object
  4903. s = s_indent//start_object//end_object
  4904. call write_it( comma=print_comma )
  4905. else
  4906. s = s_indent//start_object
  4907. call write_it()
  4908. !if an object is in an array, there is an extra tab:
  4909. if (is_array) then
  4910. if ( .not. json%no_whitespace) tab = tab+1
  4911. spaces = tab*json%spaces_per_tab
  4912. end if
  4913. nullify(element)
  4914. element => p%children
  4915. do i = 1, count
  4916. if (.not. associated(element)) then
  4917. call json%throw_exception('Error in json_value_print: '//&
  4918. 'Malformed JSON linked list')
  4919. return
  4920. end if
  4921. ! print the name
  4922. if (allocated(element%name)) then
  4923. call escape_string(element%name,str_escaped,json%escape_solidus)
  4924. if (json%no_whitespace) then
  4925. !compact printing - no extra space
  4926. s = repeat(space, spaces)//quotation_mark//&
  4927. str_escaped//quotation_mark//colon_char
  4928. call write_it(advance=.false.)
  4929. else
  4930. s = repeat(space, spaces)//quotation_mark//&
  4931. str_escaped//quotation_mark//colon_char//space
  4932. call write_it(advance=.false.)
  4933. end if
  4934. else
  4935. call json%throw_exception('Error in json_value_print:'//&
  4936. ' element%name not allocated')
  4937. nullify(element)
  4938. return
  4939. end if
  4940. ! recursive print of the element
  4941. call json%json_value_print(element, iunit=iunit, indent=tab + 1_IK, &
  4942. need_comma=i<count, colon=.true., str=str, iloc=iloc)
  4943. if (json%exception_thrown) return
  4944. ! get the next child the list:
  4945. element => element%next
  4946. end do
  4947. ! [one fewer tab if it isn't an array element]
  4948. if (.not. is_array) then
  4949. s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_object
  4950. else
  4951. s = s_indent//end_object
  4952. end if
  4953. call write_it( comma=print_comma )
  4954. nullify(element)
  4955. end if
  4956. case (json_array)
  4957. count = json%count(p)
  4958. if (count==0) then ! special case for empty array
  4959. s = s_indent//start_array//end_array
  4960. call write_it( comma=print_comma )
  4961. else
  4962. ! if every child is the same type & a scalar:
  4963. is_vector = json%is_vector(p)
  4964. if (json%failed()) return
  4965. s = s_indent//start_array
  4966. call write_it( advance=(.not. is_vector) )
  4967. !if an array is in an array, there is an extra tab:
  4968. if (is_array) then
  4969. if ( .not. json%no_whitespace) tab = tab+1
  4970. spaces = tab*json%spaces_per_tab
  4971. end if
  4972. nullify(element)
  4973. element => p%children
  4974. do i = 1, count
  4975. if (.not. associated(element)) then
  4976. call json%throw_exception('Error in json_value_print: '//&
  4977. 'Malformed JSON linked list')
  4978. return
  4979. end if
  4980. ! recursive print of the element
  4981. if (is_vector) then
  4982. call json%json_value_print(element, iunit=iunit, indent=0_IK,&
  4983. need_comma=i<count, is_array_element=.false., &
  4984. str=str, iloc=iloc,&
  4985. is_compressed_vector = .true.)
  4986. else
  4987. call json%json_value_print(element, iunit=iunit, indent=tab,&
  4988. need_comma=i<count, is_array_element=.true., &
  4989. str=str, iloc=iloc)
  4990. end if
  4991. if (json%exception_thrown) return
  4992. ! get the next child the list:
  4993. element => element%next
  4994. end do
  4995. !indent the closing array character:
  4996. if (is_vector) then
  4997. s = end_array
  4998. call write_it( comma=print_comma )
  4999. else
  5000. s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_array
  5001. call write_it( comma=print_comma )
  5002. end if
  5003. nullify(element)
  5004. end if
  5005. case (json_null)
  5006. s = s_indent//null_str
  5007. call write_it( comma=print_comma, &
  5008. advance=(.not. is_vector),&
  5009. space_after_comma=is_vector )
  5010. case (json_string)
  5011. if (allocated(p%str_value)) then
  5012. ! have to escape the string for printing:
  5013. call escape_string(p%str_value,str_escaped,json%escape_solidus)
  5014. s = s_indent//quotation_mark//str_escaped//quotation_mark
  5015. call write_it( comma=print_comma, &
  5016. advance=(.not. is_vector),&
  5017. space_after_comma=is_vector )
  5018. else
  5019. call json%throw_exception('Error in json_value_print:'//&
  5020. ' p%value_string not allocated')
  5021. return
  5022. end if
  5023. case (json_logical)
  5024. if (p%log_value) then
  5025. s = s_indent//true_str
  5026. call write_it( comma=print_comma, &
  5027. advance=(.not. is_vector),&
  5028. space_after_comma=is_vector )
  5029. else
  5030. s = s_indent//false_str
  5031. call write_it( comma=print_comma, &
  5032. advance=(.not. is_vector),&
  5033. space_after_comma=is_vector )
  5034. end if
  5035. case (json_integer)
  5036. call integer_to_string(p%int_value,int_fmt,tmp)
  5037. s = s_indent//trim(tmp)
  5038. call write_it( comma=print_comma, &
  5039. advance=(.not. is_vector),&
  5040. space_after_comma=is_vector )
  5041. case (json_real)
  5042. if (allocated(json%real_fmt)) then
  5043. call real_to_string(p%dbl_value,json%real_fmt,json%compact_real,json%non_normals_to_null,tmp)
  5044. else
  5045. !use the default format (user has not called initialize() or specified one):
  5046. call real_to_string(p%dbl_value,default_real_fmt,json%compact_real,json%non_normals_to_null,tmp)
  5047. end if
  5048. s = s_indent//trim(tmp)
  5049. call write_it( comma=print_comma, &
  5050. advance=(.not. is_vector),&
  5051. space_after_comma=is_vector )
  5052. case default
  5053. call integer_to_string(p%var_type,int_fmt,tmp)
  5054. call json%throw_exception('Error in json_value_print: '//&
  5055. 'unknown data type: '//trim(tmp))
  5056. end select
  5057. end if
  5058. contains
  5059. subroutine write_it(advance,comma,space_after_comma)
  5060. !! write the string `s` to the file (or the output string)
  5061. implicit none
  5062. logical(LK),intent(in),optional :: advance !! to add line break or not
  5063. logical(LK),intent(in),optional :: comma !! print comma after the string
  5064. logical(LK),intent(in),optional :: space_after_comma !! print a space after the comma
  5065. logical(LK) :: add_comma !! if a delimiter is to be added after string
  5066. logical(LK) :: add_line_break !! if a line break is to be added after string
  5067. logical(LK) :: add_space !! if a space is to be added after the comma
  5068. integer(IK) :: n !! length of actual string `s` appended to `str`
  5069. integer(IK) :: room_left !! number of characters left in `str`
  5070. integer(IK) :: n_chunks_to_add !! number of chunks to add to `str` for appending `s`
  5071. if (present(comma)) then
  5072. add_comma = comma
  5073. else
  5074. add_comma = .false. !default is not to add comma
  5075. end if
  5076. if (json%no_whitespace) then
  5077. add_space = .false.
  5078. else
  5079. if (present(space_after_comma)) then
  5080. add_space = space_after_comma
  5081. else
  5082. add_space = .false. !default is not to add space
  5083. end if
  5084. end if
  5085. if (present(advance)) then
  5086. if (json%no_whitespace) then
  5087. ! overrides input value:
  5088. add_line_break = .false.
  5089. else
  5090. add_line_break = advance
  5091. end if
  5092. else
  5093. add_line_break = .not. json%no_whitespace ! default is to advance if
  5094. ! we are printing whitespace
  5095. end if
  5096. ! string to print:
  5097. if (add_comma) then
  5098. if (add_space) then
  5099. s = s // delimiter // space
  5100. else
  5101. s = s // delimiter
  5102. end if
  5103. end if
  5104. if (write_file) then
  5105. if (add_line_break) then
  5106. write(iunit,fmt='(A)') s
  5107. else
  5108. write(iunit,fmt='(A)',advance='NO') s
  5109. end if
  5110. else !write string
  5111. if (add_line_break) s = s // newline
  5112. n = len(s)
  5113. room_left = len(str)-iloc
  5114. if (room_left < n) then
  5115. ! need to add another chunk to fit this string:
  5116. n_chunks_to_add = max(1_IK, ceiling( real(len(s)-room_left,RK) / real(chunk_size,RK), IK ) )
  5117. str = str // repeat(space, print_str_chunk_size*n_chunks_to_add)
  5118. end if
  5119. ! append s to str:
  5120. str(iloc+1:iloc+n) = s
  5121. iloc = iloc + n
  5122. end if
  5123. end subroutine write_it
  5124. end subroutine json_value_print
  5125. !*****************************************************************************************
  5126. !*****************************************************************************************
  5127. !>
  5128. ! Returns true if all the children are the same type (and a scalar).
  5129. ! Note that integers and reals are considered the same type for this purpose.
  5130. ! This routine is used for the `compress_vectors` option.
  5131. function json_is_vector(json, p) result(is_vector)
  5132. implicit none
  5133. class(json_core),intent(inout) :: json
  5134. type(json_value),pointer :: p
  5135. logical(LK) :: is_vector !! if all elements of a vector
  5136. !! are scalars of the same type
  5137. integer(IK) :: var_type_prev !! for getting the variable type of children
  5138. integer(IK) :: var_type !! for getting the variable type of children
  5139. type(json_value),pointer :: element !! for getting children
  5140. integer(IK) :: i !! counter
  5141. integer(IK) :: count !! number of children
  5142. integer(IK),parameter :: json_invalid = -1_IK !! to initialize the flag. an invalid value
  5143. integer(IK),parameter :: json_numeric = -2_IK !! indicates `json_integer` or `json_real`
  5144. if (json%compress_vectors) then
  5145. ! check to see if every child is the same type,
  5146. ! and a scalar:
  5147. is_vector = .true.
  5148. var_type_prev = json_invalid
  5149. count = json%count(p)
  5150. element => p%children
  5151. do i = 1_IK, count
  5152. if (.not. associated(element)) then
  5153. call json%throw_exception('Error in json_is_vector: '//&
  5154. 'Malformed JSON linked list')
  5155. return
  5156. end if
  5157. ! check variable type of all the children.
  5158. ! They must all be the same, and a scalar.
  5159. call json%info(element,var_type=var_type)
  5160. ! special check for numeric values:
  5161. if (var_type==json_integer .or. var_type==json_real) var_type = json_numeric
  5162. if (var_type==json_object .or. &
  5163. var_type==json_array .or. &
  5164. (i>1_IK .and. var_type/=var_type_prev)) then
  5165. is_vector = .false.
  5166. exit
  5167. end if
  5168. var_type_prev = var_type
  5169. ! get the next child the list:
  5170. element => element%next
  5171. end do
  5172. else
  5173. is_vector = .false.
  5174. end if
  5175. end function json_is_vector
  5176. !*****************************************************************************************
  5177. !*****************************************************************************************
  5178. !>
  5179. ! Returns true if the `path` is present in the `p` JSON structure.
  5180. !
  5181. !@note Just a wrapper for [[json_get_by_path]], so it uses the
  5182. ! specified `path_mode` and other settings.
  5183. function json_valid_path(json, p, path) result(found)
  5184. implicit none
  5185. class(json_core),intent(inout) :: json
  5186. type(json_value),pointer,intent(in) :: p !! a JSON linked list
  5187. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5188. logical(LK) :: found !! true if it was found
  5189. type(json_value),pointer :: tmp !! pointer to the variable specified by `path`
  5190. call json%get(p, path, tmp, found)
  5191. end function json_valid_path
  5192. !*****************************************************************************************
  5193. !*****************************************************************************************
  5194. !>
  5195. ! Alternate version of [[json_valid_path]] where "path" is kind=CDK.
  5196. function wrap_json_valid_path(json, p, path) result(found)
  5197. implicit none
  5198. class(json_core),intent(inout) :: json
  5199. type(json_value),pointer,intent(in) :: p !! a JSON linked list
  5200. character(kind=CDK,len=*),intent(in) :: path !! path to the variable
  5201. logical(LK) :: found !! true if it was found
  5202. found = json%valid_path(p, to_unicode(path))
  5203. end function wrap_json_valid_path
  5204. !*****************************************************************************************
  5205. !*****************************************************************************************
  5206. !>
  5207. ! Returns the [[json_value]] pointer given the path string.
  5208. !
  5209. ! It uses one of three methods:
  5210. !
  5211. ! * The original JSON-Fortran defaults
  5212. ! * [RFC 6901](https://tools.ietf.org/html/rfc6901)
  5213. ! * [JSONPath](http://goessner.net/articles/JsonPath/) "bracket-notation"
  5214. subroutine json_get_by_path(json, me, path, p, found)
  5215. implicit none
  5216. class(json_core),intent(inout) :: json
  5217. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5218. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5219. type(json_value),pointer,intent(out) :: p !! pointer to the variable
  5220. !! specified by `path`
  5221. logical(LK),intent(out),optional :: found !! true if it was found
  5222. character(kind=CK,len=max_integer_str_len),allocatable :: path_mode_str !! string version
  5223. !! of `json%path_mode`
  5224. nullify(p)
  5225. if (.not. json%exception_thrown) then
  5226. select case (json%path_mode)
  5227. case(1_IK)
  5228. call json%json_get_by_path_default(me, path, p, found)
  5229. case(2_IK)
  5230. call json%json_get_by_path_rfc6901(me, path, p, found)
  5231. case(3_IK)
  5232. call json%json_get_by_path_jsonpath_bracket(me, path, p, found)
  5233. case default
  5234. call integer_to_string(json%path_mode,int_fmt,path_mode_str)
  5235. call json%throw_exception('Error in json_get_by_path: Unsupported path_mode: '//&
  5236. trim(path_mode_str))
  5237. if (present(found)) found = .false.
  5238. end select
  5239. if (present(found)) then
  5240. if (.not. found) call json%clear_exceptions()
  5241. end if
  5242. else
  5243. if (present(found)) found = .false.
  5244. end if
  5245. end subroutine json_get_by_path
  5246. !*****************************************************************************************
  5247. !*****************************************************************************************
  5248. !>
  5249. ! Returns the [[json_value]] pointer given the path string,
  5250. ! If necessary, by creating the variables as needed.
  5251. !
  5252. ! By default, the leaf node and any empty array elements
  5253. ! are created as `json_null` values.
  5254. !
  5255. ! It only works for `path_mode=1` or `path_mode=3`.
  5256. ! An error will be thrown for `path_mode=2` (RFC 6901).
  5257. !
  5258. !### See also
  5259. ! * [[json_get_by_path]]
  5260. subroutine json_create_by_path(json,me,path,p,found,was_created)
  5261. implicit none
  5262. class(json_core),intent(inout) :: json
  5263. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5264. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5265. type(json_value),pointer,intent(out),optional :: p !! pointer to the variable
  5266. !! specify by `path`
  5267. logical(LK),intent(out),optional :: found !! true if there were no errors
  5268. !! (variable found or created)
  5269. logical(LK),intent(out),optional :: was_created !! true if it was actually created
  5270. !! (as opposed to already being there)
  5271. type(json_value),pointer :: tmp
  5272. character(kind=CK,len=max_integer_str_len) :: path_mode_str !! string version
  5273. !! of `json%path_mode`
  5274. if (present(p)) nullify(p)
  5275. if (.not. json%exception_thrown) then
  5276. select case (json%path_mode)
  5277. case(1_IK)
  5278. call json%json_get_by_path_default(me,path,tmp,found,&
  5279. create_it=.true.,&
  5280. was_created=was_created)
  5281. if (present(p)) p => tmp
  5282. case(3_IK)
  5283. call json%json_get_by_path_jsonpath_bracket(me,path,tmp,found,&
  5284. create_it=.true.,&
  5285. was_created=was_created)
  5286. if (present(p)) p => tmp
  5287. case default
  5288. if (json%path_mode==2_IK) then
  5289. ! the problem here is there isn't really a way to disambiguate
  5290. ! the array elements, so '/a/0' could be 'a(1)' or 'a.0'.
  5291. call json%throw_exception('Error in json_create_by_path: '//&
  5292. 'Create by path not supported in RFC 6901 path mode.')
  5293. else
  5294. call integer_to_string(json%path_mode,int_fmt,path_mode_str)
  5295. call json%throw_exception('Error in json_create_by_path: Unsupported path_mode: '//&
  5296. trim(path_mode_str))
  5297. end if
  5298. if (present(found)) then
  5299. call json%clear_exceptions()
  5300. found = .false.
  5301. end if
  5302. if (present(was_created)) was_created = .false.
  5303. end select
  5304. else
  5305. if (present(was_created)) was_created = .false.
  5306. if (present(found)) found = .false.
  5307. end if
  5308. end subroutine json_create_by_path
  5309. !*****************************************************************************************
  5310. !*****************************************************************************************
  5311. !>
  5312. ! Alternate version of [[json_create_by_path]] where "path" is kind=CDK.
  5313. subroutine wrap_json_create_by_path(json,me,path,p,found,was_created)
  5314. implicit none
  5315. class(json_core),intent(inout) :: json
  5316. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5317. character(kind=CDK,len=*),intent(in) :: path !! path to the variable
  5318. type(json_value),pointer,intent(out),optional :: p !! pointer to the variable
  5319. !! specify by `path`
  5320. logical(LK),intent(out),optional :: found !! true if there were no errors
  5321. !! (variable found or created)
  5322. logical(LK),intent(out),optional :: was_created !! true if it was actually created
  5323. !! (as opposed to already being there)
  5324. call json%create(me,to_unicode(path),p,found,was_created)
  5325. end subroutine wrap_json_create_by_path
  5326. !*****************************************************************************************
  5327. !*****************************************************************************************
  5328. !>
  5329. ! Rename a [[json_value]], given the path.
  5330. !
  5331. !@note this is a wrapper for [[json_value_rename]].
  5332. subroutine json_rename_by_path(json, me, path, name, found)
  5333. implicit none
  5334. class(json_core),intent(inout) :: json
  5335. type(json_value),pointer,intent(in) :: me
  5336. character(kind=CK,len=*),intent(in) :: path !! path to the variable to rename
  5337. character(kind=CK,len=*),intent(in) :: name !! the new name
  5338. logical(LK),intent(out),optional :: found !! if there were no errors
  5339. type(json_value),pointer :: p
  5340. if ( json%exception_thrown ) then
  5341. if ( present(found) ) found = .false.
  5342. return
  5343. end if
  5344. nullify(p)
  5345. call json%get(me=me, path=path, p=p)
  5346. if (.not. associated(p)) then
  5347. call json%throw_exception('Error in json_rename_by_path:'//&
  5348. ' Unable to resolve path: '//trim(path),found)
  5349. else
  5350. call json%rename(p,name)
  5351. nullify(p)
  5352. end if
  5353. if (json%exception_thrown) then
  5354. if (present(found)) then
  5355. found = .false.
  5356. call json%clear_exceptions()
  5357. end if
  5358. else
  5359. if (present(found)) found = .true.
  5360. end if
  5361. end subroutine json_rename_by_path
  5362. !*****************************************************************************************
  5363. !*****************************************************************************************
  5364. !>
  5365. ! Alternate version of [[json_rename_by_path]], where "path" and "name" are kind=CDK
  5366. subroutine wrap_json_rename_by_path(json, me, path, name, found)
  5367. implicit none
  5368. class(json_core),intent(inout) :: json
  5369. type(json_value),pointer,intent(in) :: me
  5370. character(kind=CDK,len=*),intent(in) :: path
  5371. character(kind=CDK,len=*),intent(in) :: name
  5372. logical(LK),intent(out),optional :: found
  5373. call json%rename(me,to_unicode(path),to_unicode(name),found)
  5374. end subroutine wrap_json_rename_by_path
  5375. !*****************************************************************************************
  5376. !*****************************************************************************************
  5377. !>
  5378. ! Alternate version of [[json_rename_by_path]], where "name" is kind=CDK
  5379. subroutine json_rename_by_path_name_ascii(json, me, path, name, found)
  5380. implicit none
  5381. class(json_core),intent(inout) :: json
  5382. type(json_value),pointer,intent(in) :: me
  5383. character(kind=CK,len=*),intent(in) :: path
  5384. character(kind=CDK,len=*),intent(in) :: name
  5385. logical(LK),intent(out),optional :: found
  5386. call json%rename(me,path,to_unicode(name),found)
  5387. end subroutine json_rename_by_path_name_ascii
  5388. !*****************************************************************************************
  5389. !*****************************************************************************************
  5390. !>
  5391. ! Alternate version of [[json_rename_by_path]], where "path" is kind=CDK
  5392. subroutine json_rename_by_path_path_ascii(json, me, path, name, found)
  5393. implicit none
  5394. class(json_core),intent(inout) :: json
  5395. type(json_value),pointer,intent(in) :: me
  5396. character(kind=CDK,len=*),intent(in) :: path
  5397. character(kind=CK,len=*),intent(in) :: name
  5398. logical(LK),intent(out),optional :: found
  5399. call json%rename(me,to_unicode(path),name,found)
  5400. end subroutine json_rename_by_path_path_ascii
  5401. !*****************************************************************************************
  5402. !*****************************************************************************************
  5403. !>
  5404. ! Returns the [[json_value]] pointer given the path string.
  5405. !
  5406. !### Example
  5407. !
  5408. !````fortran
  5409. ! type(json_core) :: json
  5410. ! type(json_value),pointer :: dat,p
  5411. ! logical :: found
  5412. ! !...
  5413. ! call json%initialize(path_mode=1) ! this is the default so not strictly necessary.
  5414. ! call json%get(dat,'data(2).version',p,found)
  5415. !````
  5416. !
  5417. !### Notes
  5418. ! The syntax used here is a subset of the
  5419. ! [http://goessner.net/articles/JsonPath/](JSONPath) "dot–notation".
  5420. ! The following special characters are used to denote paths:
  5421. !
  5422. ! * `$` - root
  5423. ! * `@` - this
  5424. ! * `.` - child object member (note this can be changed using `json%path_separator`)
  5425. ! * `[]` or `()` - child array element (note that indices are 1-based)
  5426. !
  5427. ! Thus, if any of these characters are present in the name key,
  5428. ! this routine cannot be used to get the value.
  5429. ! In that case, the `get_child` methods would need to be used.
  5430. ! Or, the alternate [[json_get_by_path_rfc6901]] could be used.
  5431. !
  5432. !### See also
  5433. ! * [[json_get_by_path_rfc6901]]
  5434. ! * [[json_get_by_path_jsonpath_bracket]]
  5435. !
  5436. !@note The syntax is inherited from FSON, and is basically a subset
  5437. ! of JSONPath "dot-notation", with the additional allowance of
  5438. ! () for array elements.
  5439. !
  5440. !@note JSON `null` values are used here for unknown variables when `create_it` is True.
  5441. ! So, it is possible that an existing null variable can be converted to another
  5442. ! type (object or array) if a child is specified in the path. Doing it this way
  5443. ! to avoid having to use another type (say `json_unknown`) that would have to be
  5444. ! converted to null once all the variables have been created (user would have
  5445. ! had to do this).
  5446. !
  5447. !@warning See (**) in code. I think we need to protect for memory leaks when
  5448. ! changing the type of a variable that already exists.
  5449. subroutine json_get_by_path_default(json,me,path,p,found,create_it,was_created)
  5450. implicit none
  5451. class(json_core),intent(inout) :: json
  5452. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5453. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5454. type(json_value),pointer,intent(out) :: p !! pointer to the variable
  5455. !! specify by `path`
  5456. logical(LK),intent(out),optional :: found !! true if it was found
  5457. logical(LK),intent(in),optional :: create_it !! if a variable is not present
  5458. !! in the path, then it is created.
  5459. !! the leaf node is returned as
  5460. !! a `null` json type and can be
  5461. !! changed by the caller.
  5462. logical(LK),intent(out),optional :: was_created !! if `create_it` is true, this
  5463. !! will be true if the variable
  5464. !! was actually created. Otherwise
  5465. !! it will be false.
  5466. integer(IK) :: i !! counter of characters in `path`
  5467. integer(IK) :: length !! significant length of `path`
  5468. integer(IK) :: child_i !! index for getting children
  5469. character(kind=CK,len=1) :: c !! a character in the `path`
  5470. logical(LK) :: array !! flag when searching for array index in `path`
  5471. type(json_value),pointer :: tmp !! temp variables for getting child objects
  5472. logical(LK) :: child_found !! if the child value was found
  5473. logical(LK) :: create !! if the object is to be created
  5474. logical(LK) :: created !! if `create` is true, then this will be
  5475. !! true if the leaf object had to be created
  5476. integer(IK) :: j !! counter of children when creating object
  5477. logical(LK) :: status_ok !! integer to string conversion flag
  5478. nullify(p)
  5479. if (.not. json%exception_thrown) then
  5480. if (present(create_it)) then
  5481. create = create_it
  5482. else
  5483. create = .false.
  5484. end if
  5485. ! default to assuming relative to me
  5486. p => me
  5487. child_i = 1
  5488. array = .false.
  5489. created = .false.
  5490. !keep trailing space or not:
  5491. if (json%trailing_spaces_significant) then
  5492. length = len(path)
  5493. else
  5494. length = len_trim(path)
  5495. end if
  5496. do i=1, length
  5497. c = path(i:i)
  5498. select case (c)
  5499. case (root)
  5500. ! root
  5501. do while (associated (p%parent))
  5502. p => p%parent
  5503. end do
  5504. child_i = i + 1
  5505. if (create) created = .false. ! should always exist
  5506. case (this)
  5507. ! this
  5508. p => me
  5509. child_i = i + 1
  5510. if (create) created = .false. ! should always exist
  5511. case (start_array,start_array_alt)
  5512. ! start looking for the array element index
  5513. array = .true.
  5514. ! get child member from p
  5515. if (child_i < i) then
  5516. nullify(tmp)
  5517. if (create) then
  5518. ! Example:
  5519. ! 'aaa.bbb(1)'
  5520. ! -> and aaa is a null, need to make it an object
  5521. !
  5522. ! What about the case: aaa.bbb(1)(3) ?
  5523. ! Is that already handled?
  5524. if (p%var_type==json_null) then ! (**)
  5525. ! if p was also created, then we need to
  5526. ! convert it into an object here:
  5527. p%var_type = json_object
  5528. end if
  5529. ! don't want to throw exceptions in this case
  5530. call json%get_child(p, path(child_i:i-1), tmp, child_found)
  5531. if (.not. child_found) then
  5532. ! have to create this child
  5533. ! [make it an array]
  5534. call json_value_create(tmp)
  5535. call json%to_array(tmp,path(child_i:i-1))
  5536. call json%add(p,tmp)
  5537. created = .true.
  5538. else
  5539. created = .false.
  5540. end if
  5541. else
  5542. ! call the normal way
  5543. call json%get_child(p, path(child_i:i-1), tmp)
  5544. end if
  5545. p => tmp
  5546. else
  5547. child_i = i + 1 ! say, '@('
  5548. cycle
  5549. end if
  5550. if (.not. associated(p)) then
  5551. call json%throw_exception('Error in json_get_by_path_default:'//&
  5552. ' Error getting array element',found)
  5553. exit
  5554. end if
  5555. child_i = i + 1
  5556. case (end_array,end_array_alt)
  5557. if (.not. array) then
  5558. call json%throw_exception('Error in json_get_by_path_default:'//&
  5559. ' Unexpected '//c,found)
  5560. exit
  5561. end if
  5562. array = .false.
  5563. call string_to_integer(path(child_i:i-1),child_i,status_ok)
  5564. if (.not. status_ok) then
  5565. call json%throw_exception('Error in json_get_by_path_default:'//&
  5566. ' Could not convert array index to integer: '//&
  5567. trim(path(child_i:i-1)),found)
  5568. exit
  5569. end if
  5570. nullify(tmp)
  5571. if (create) then
  5572. ! don't want to throw exceptions in this case
  5573. call json%get_child(p, child_i, tmp, child_found)
  5574. if (.not. child_found) then
  5575. if (p%var_type==json_null) then ! (**)
  5576. ! if p was also created, then we need to
  5577. ! convert it into an array here:
  5578. p%var_type = json_array
  5579. end if
  5580. ! have to create this element
  5581. ! [make it a null]
  5582. ! (and any missing ones before it)
  5583. do j = 1, child_i
  5584. nullify(tmp)
  5585. call json%get_child(p, j, tmp, child_found)
  5586. if (.not. child_found) then
  5587. call json_value_create(tmp)
  5588. call json%to_null(tmp) ! array element doesn't need a name
  5589. call json%add(p,tmp)
  5590. if (j==child_i) created = .true.
  5591. else
  5592. if (j==child_i) created = .false.
  5593. end if
  5594. end do
  5595. else
  5596. created = .false.
  5597. end if
  5598. else
  5599. ! call the normal way:
  5600. call json%get_child(p, child_i, tmp)
  5601. end if
  5602. p => tmp
  5603. child_i = i + 1
  5604. case default
  5605. if (c==json%path_separator) then
  5606. ! get child member from p
  5607. if (child_i < i) then
  5608. nullify(tmp)
  5609. if (create) then
  5610. if (p%var_type==json_null) then ! (**)
  5611. ! if p was also created, then we need to
  5612. ! convert it into an object here:
  5613. p%var_type = json_object
  5614. end if
  5615. ! don't want to throw exceptions in this case
  5616. call json%get_child(p, path(child_i:i-1), tmp, child_found)
  5617. if (.not. child_found) then
  5618. ! have to create this child
  5619. ! [make it an object]
  5620. call json_value_create(tmp)
  5621. call json%to_object(tmp,path(child_i:i-1))
  5622. call json%add(p,tmp)
  5623. created = .true.
  5624. else
  5625. created = .false.
  5626. end if
  5627. else
  5628. ! call the normal way
  5629. call json%get_child(p, path(child_i:i-1), tmp)
  5630. end if
  5631. p => tmp
  5632. else
  5633. child_i = i + 1 ! say '$.', '@.', or ').'
  5634. cycle
  5635. end if
  5636. if (.not. associated(p)) then
  5637. call json%throw_exception('Error in json_get_by_path_default:'//&
  5638. ' Error getting child member.',found)
  5639. exit
  5640. end if
  5641. child_i = i + 1
  5642. end if
  5643. end select
  5644. end do
  5645. if (json%exception_thrown) then
  5646. if (present(found)) then
  5647. nullify(p) ! just in case
  5648. found = .false.
  5649. call json%clear_exceptions()
  5650. end if
  5651. else
  5652. ! grab the last child if present in the path
  5653. if (child_i <= length) then
  5654. nullify(tmp)
  5655. if (create) then
  5656. if (p%var_type==json_null) then ! (**)
  5657. ! if p was also created, then we need to
  5658. ! convert it into an object here:
  5659. p%var_type = json_object
  5660. end if
  5661. call json%get_child(p, path(child_i:i-1), tmp, child_found)
  5662. if (.not. child_found) then
  5663. ! have to create this child
  5664. ! (make it a null since it is the leaf)
  5665. call json_value_create(tmp)
  5666. call json%to_null(tmp,path(child_i:i-1))
  5667. call json%add(p,tmp)
  5668. created = .true.
  5669. else
  5670. created = .false.
  5671. end if
  5672. else
  5673. ! call the normal way
  5674. call json%get_child(p, path(child_i:i-1), tmp)
  5675. end if
  5676. p => tmp
  5677. else
  5678. ! we already have p
  5679. if (create .and. created) then
  5680. ! make leaf p a null, but only
  5681. ! if it wasn't there
  5682. call json%to_null(p)
  5683. end if
  5684. end if
  5685. ! error checking
  5686. if (associated(p)) then
  5687. if (present(found)) found = .true. !everything seems to be ok
  5688. else
  5689. call json%throw_exception('Error in json_get_by_path_default:'//&
  5690. ' variable not found: '//trim(path),found)
  5691. if (present(found)) then
  5692. found = .false.
  5693. call json%clear_exceptions()
  5694. end if
  5695. end if
  5696. end if
  5697. ! if it had to be created:
  5698. if (present(was_created)) was_created = created
  5699. else
  5700. if (present(found)) found = .false.
  5701. if (present(was_created)) was_created = .false.
  5702. end if
  5703. end subroutine json_get_by_path_default
  5704. !*****************************************************************************************
  5705. !*****************************************************************************************
  5706. !> author: Jacob Williams
  5707. ! date: 2/4/2017
  5708. !
  5709. ! Returns the [[json_value]] pointer given the path string,
  5710. ! using the "JSON Pointer" path specification defined by RFC 6901.
  5711. !
  5712. ! Note that trailing whitespace significance and case sensitivity
  5713. ! are user-specified. To fully conform to the RFC 6901 standard,
  5714. ! should probably set (via `initialize`):
  5715. !
  5716. ! * `case_sensitive_keys = .true.` [this is the default setting]
  5717. ! * `trailing_spaces_significant = .true.` [this is *not* the default setting]
  5718. ! * `allow_duplicate_keys = .false.` [this is *not* the default setting]
  5719. !
  5720. !### Example
  5721. !
  5722. !````fortran
  5723. ! type(json_core) :: json
  5724. ! type(json_value),pointer :: dat,p
  5725. ! logical :: found
  5726. ! !...
  5727. ! call json%initialize(path_mode=2)
  5728. ! call json%get(dat,'/data/2/version',p,found)
  5729. !````
  5730. !
  5731. !### See also
  5732. ! * [[json_get_by_path_default]]
  5733. ! * [[json_get_by_path_jsonpath_bracket]]
  5734. !
  5735. !### Reference
  5736. ! * [JavaScript Object Notation (JSON) Pointer](https://tools.ietf.org/html/rfc6901)
  5737. !
  5738. !@note Not doing anything special about the `-` character to index an array.
  5739. ! This is considered a normal error.
  5740. !
  5741. !@note Unlike in the default path mode, the array indices here are 0-based
  5742. ! (in accordance with the RFC 6901 standard)
  5743. !
  5744. !@warning Not checking if the member that is referenced is unique.
  5745. ! (according to the standard, evaluation of non-unique references
  5746. ! should fail). Like [[json_get_by_path_default]], this one will just return
  5747. ! the first instance it encounters. This might be changed in the future.
  5748. !
  5749. !@warning I think the standard indicates that the input paths should use
  5750. ! escaped JSON strings (currently we are assuming they are not escaped).
  5751. subroutine json_get_by_path_rfc6901(json, me, path, p, found)
  5752. implicit none
  5753. class(json_core),intent(inout) :: json
  5754. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5755. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5756. !! (an RFC 6901 "JSON Pointer")
  5757. type(json_value),pointer,intent(out) :: p !! pointer to the variable
  5758. !! specify by `path`
  5759. logical(LK),intent(out),optional :: found !! true if it was found
  5760. character(kind=CK,len=:),allocatable :: token !! a token in the path (between the `/` characters)
  5761. integer(IK) :: i !! counter
  5762. integer(IK) :: islash_curr !! location of current '/' character in the path
  5763. integer(IK) :: islash_next !! location of next '/' character in the path
  5764. integer(IK) :: ilen !! length of `path` string
  5765. type(json_value),pointer :: tmp !! temporary variable for traversing the structure
  5766. integer(IK) :: ival !! integer array index value (0-based)
  5767. logical(LK) :: status_ok !! error flag
  5768. logical(LK) :: child_found !! for getting child values
  5769. nullify(p)
  5770. if (.not. json%exception_thrown) then
  5771. p => me ! initialize
  5772. if (path/=CK_'') then
  5773. if (path(1:1)==slash) then ! the first character must be a slash
  5774. islash_curr = 1 ! initialize current slash index
  5775. !keep trailing space or not:
  5776. if (json%trailing_spaces_significant) then
  5777. ilen = len(path)
  5778. else
  5779. ilen = len_trim(path)
  5780. end if
  5781. do
  5782. ! get the next token by finding the slashes
  5783. !
  5784. ! 1 2 3
  5785. ! /abc/d/efg
  5786. if (islash_curr==ilen) then
  5787. !the last token is an empty string
  5788. token = CK_''
  5789. islash_next = 0 ! will signal to stop
  5790. else
  5791. ! .
  5792. ! '/123/567/'
  5793. ! index in remaining string:
  5794. islash_next = index(path(islash_curr+1:ilen),slash)
  5795. if (islash_next<=0) then
  5796. !last token:
  5797. token = path(islash_curr+1:ilen)
  5798. else
  5799. ! convert to actual index in path:
  5800. islash_next = islash_curr + index(path(islash_curr+1:ilen),slash)
  5801. if (islash_next>islash_curr+1) then
  5802. token = path(islash_curr+1:islash_next-1)
  5803. else
  5804. !empty token:
  5805. token = CK_''
  5806. end if
  5807. end if
  5808. end if
  5809. ! remove trailing spaces in the token here if necessary:
  5810. if (.not. json%trailing_spaces_significant) &
  5811. token = trim(token)
  5812. ! decode the token:
  5813. token = decode_rfc6901(token)
  5814. ! now, parse the token:
  5815. ! first see if there is a child with this name
  5816. call json%get_child(p,token,tmp,child_found)
  5817. if (child_found) then
  5818. ! it was found
  5819. p => tmp
  5820. else
  5821. ! No key with this name.
  5822. ! Is it an integer? If so,
  5823. ! it might be an array index.
  5824. status_ok = (len(token)>0)
  5825. if (status_ok) then
  5826. do i=1,len(token)
  5827. ! It must only contain (0..9) characters
  5828. ! (it must be unsigned)
  5829. if (scan(token(i:i),CK_'0123456789')<1) then
  5830. status_ok = .false.
  5831. exit
  5832. end if
  5833. end do
  5834. if (status_ok) then
  5835. if (len(token)>1 .and. token(1:1)==CK_'0') then
  5836. ! leading zeros not allowed for some reason
  5837. status_ok = .false.
  5838. end if
  5839. end if
  5840. if (status_ok) then
  5841. ! if we make it this far, it should be
  5842. ! convertible to an integer, so do it.
  5843. call string_to_integer(token,ival,status_ok)
  5844. end if
  5845. end if
  5846. if (status_ok) then
  5847. ! ival is an array index (0-based)
  5848. call json%get_child(p,ival+1_IK,tmp,child_found)
  5849. if (child_found) then
  5850. p => tmp
  5851. else
  5852. ! not found
  5853. status_ok = .false.
  5854. end if
  5855. end if
  5856. if (.not. status_ok) then
  5857. call json%throw_exception('Error in json_get_by_path_rfc6901: '//&
  5858. 'invalid path specification: '//trim(path),found)
  5859. exit
  5860. end if
  5861. end if
  5862. if (islash_next<=0) exit ! finished
  5863. ! set up for next token:
  5864. islash_curr = islash_next
  5865. end do
  5866. else
  5867. call json%throw_exception('Error in json_get_by_path_rfc6901: '//&
  5868. 'invalid path specification: '//trim(path),found)
  5869. end if
  5870. end if
  5871. if (json%exception_thrown) then
  5872. nullify(p)
  5873. if (present(found)) then
  5874. found = .false.
  5875. call json%clear_exceptions()
  5876. end if
  5877. else
  5878. if (present(found)) found = .true.
  5879. end if
  5880. else
  5881. if (present(found)) found = .false.
  5882. end if
  5883. end subroutine json_get_by_path_rfc6901
  5884. !*****************************************************************************************
  5885. !*****************************************************************************************
  5886. !> author: Jacob Williams
  5887. ! date: 9/2/2017
  5888. !
  5889. ! Returns the [[json_value]] pointer given the path string,
  5890. ! using the "JSON Pointer" path specification defined by the
  5891. ! JSONPath "bracket-notation".
  5892. !
  5893. ! The first character `$` is optional, and signifies the root
  5894. ! of the structure. If it is not present, then the first key
  5895. ! is taken to be in the `me` object.
  5896. !
  5897. ! Single or real quotes may be used.
  5898. !
  5899. !### Example
  5900. !
  5901. !````fortran
  5902. ! type(json_core) :: json
  5903. ! type(json_value),pointer :: dat,p
  5904. ! logical :: found
  5905. ! !...
  5906. ! call json%initialize(path_mode=3)
  5907. ! call json%get(dat,"$['store']['book'][1]['title']",p,found)
  5908. !````
  5909. !
  5910. !### See also
  5911. ! * [[json_get_by_path_default]]
  5912. ! * [[json_get_by_path_rfc6901]]
  5913. !
  5914. !### Reference
  5915. ! * [JSONPath](http://goessner.net/articles/JsonPath/)
  5916. !
  5917. !@note Uses 1-based array indices (same as [[json_get_by_path_default]],
  5918. ! but unlike [[json_get_by_path_rfc6901]] which uses 0-based indices).
  5919. !
  5920. !@note When `create_it=True`, if the variable already exists and is a type
  5921. ! that is not compatible with the usage in the `path`, then it is
  5922. ! destroyed and replaced with what is specified in the `path`. Note that
  5923. ! this applies the all variables in the path as it is created. Currently,
  5924. ! this behavior is different from [[json_get_by_path_default]].
  5925. !
  5926. !@note JSON `null` values are used here for unknown variables
  5927. ! when `create_it` is True.
  5928. !
  5929. !@warning Note that if using single quotes, this routine cannot parse
  5930. ! a key containing `']`. If using real quotes, this routine
  5931. ! cannot parse a key containing `"]`. If the key contains both
  5932. ! `']` and `"]`, there is no way to parse it using this routine.
  5933. subroutine json_get_by_path_jsonpath_bracket(json,me,path,p,found,create_it,was_created)
  5934. implicit none
  5935. class(json_core),intent(inout) :: json
  5936. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5937. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5938. !! (using JSONPath
  5939. !! "bracket-notation")
  5940. type(json_value),pointer,intent(out) :: p !! pointer to the variable
  5941. !! specify by `path`
  5942. logical(LK),intent(out),optional :: found !! true if it was found
  5943. logical(LK),intent(in),optional :: create_it !! if a variable is not present
  5944. !! in the path, then it is created.
  5945. !! the leaf node is returned as
  5946. !! a `null` json type and can be
  5947. !! changed by the caller.
  5948. logical(LK),intent(out),optional :: was_created !! if `create_it` is true, this
  5949. !! will be true if the variable
  5950. !! was actually created. Otherwise
  5951. !! it will be false.
  5952. character(kind=CK,len=:),allocatable :: token !! a token in the path
  5953. !! (between the `['']` or
  5954. !! `[]` characters)
  5955. integer(IK) :: istart !! location of current '['
  5956. !! character in the path
  5957. integer(IK) :: iend !! location of current ']'
  5958. !! character in the path
  5959. integer(IK) :: ival !! integer array index value
  5960. logical(LK) :: status_ok !! error flag
  5961. type(json_value),pointer :: tmp !! temporary variable for
  5962. !! traversing the structure
  5963. integer(IK) :: i !! counter
  5964. integer(IK) :: ilen !! length of `path` string
  5965. logical(LK) :: real_quotes !! if the keys are enclosed in `"`,
  5966. !! rather than `'` tokens.
  5967. logical(LK) :: create !! if the object is to be created
  5968. logical(LK) :: created !! if `create` is true, then this will be
  5969. !! true if the leaf object had to be created
  5970. integer(IK) :: j !! counter of children when creating object
  5971. !TODO instead of reallocating `token` all the time, just
  5972. ! allocate a big size and keep track of the length,
  5973. ! then just reallocate only if necessary.
  5974. ! [would probably be inefficient if there was a very large token,
  5975. ! and then a bunch of small ones... but for similarly-sized ones
  5976. ! it should be way more efficient since it would avoid most
  5977. ! reallocations.]
  5978. nullify(p)
  5979. if (.not. json%exception_thrown) then
  5980. if (present(create_it)) then
  5981. create = create_it
  5982. else
  5983. create = .false.
  5984. end if
  5985. p => me ! initialize
  5986. created = .false.
  5987. if (path==CK_'') then
  5988. call json%throw_exception('Error in json_get_by_path_jsonpath_bracket: '//&
  5989. 'invalid path specification: '//trim(path),found)
  5990. else
  5991. if (path(1:1)==root .or. path(1:1)==start_array) then ! the first character must be
  5992. ! a `$` (root) or a `[`
  5993. ! (element of `me`)
  5994. if (path(1:1)==root) then
  5995. ! go to the root
  5996. do while (associated (p%parent))
  5997. p => p%parent
  5998. end do
  5999. if (create) created = .false. ! should always exist
  6000. end if
  6001. !path length (don't need trailing spaces:)
  6002. ilen = len_trim(path)
  6003. if (ilen>1) then
  6004. istart = 2 ! initialize first '[' location index
  6005. do
  6006. if (istart>ilen) exit ! finished
  6007. ! must be the next start bracket:
  6008. if (path(istart:istart) /= start_array) then
  6009. call json%throw_exception(&
  6010. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6011. 'expecting "[", found: "'//trim(path(istart:istart))//&
  6012. '" in path: '//trim(path),found)
  6013. exit
  6014. end if
  6015. ! get the next token by checking:
  6016. !
  6017. ! * [''] -- is the token after istart a quote?
  6018. ! if so, then search for the next `']`
  6019. !
  6020. ! * [1] -- if not, then maybe it is a number,
  6021. ! so search for the next `]`
  6022. ! verify length of remaining string
  6023. if (istart+2<=ilen) then
  6024. real_quotes = path(istart+1:istart+1) == quotation_mark ! ["
  6025. if (real_quotes .or. path(istart+1:istart+1)==single_quote) then ! ['
  6026. ! it might be a key value: ['abc']
  6027. istart = istart + 1 ! move counter to ' index
  6028. if (real_quotes) then
  6029. iend = istart + index(path(istart+1:ilen),&
  6030. quotation_mark//end_array) ! "]
  6031. else
  6032. iend = istart + index(path(istart+1:ilen),&
  6033. single_quote//end_array) ! ']
  6034. end if
  6035. if (iend>istart) then
  6036. ! istart iend
  6037. ! | |
  6038. ! ['p']['abcdefg']
  6039. if (iend>istart+1) then
  6040. token = path(istart+1:iend-1)
  6041. else
  6042. token = CK_'' ! blank string
  6043. end if
  6044. ! remove trailing spaces in
  6045. ! the token here if necessary:
  6046. if (.not. json%trailing_spaces_significant) &
  6047. token = trim(token)
  6048. if (create) then
  6049. ! have a token, create it if necessary
  6050. ! we need to convert it into an object here
  6051. ! (e.g., if p was also just created)
  6052. ! and destroy its data to prevent a memory leak
  6053. call json%convert(p,json_object)
  6054. ! don't want to throw exceptions in this case
  6055. call json%get_child(p,token,tmp,status_ok)
  6056. if (.not. status_ok) then
  6057. ! have to create this child
  6058. ! [make it a null since we don't
  6059. ! know what it is yet]
  6060. call json_value_create(tmp)
  6061. call json%to_null(tmp,token)
  6062. call json%add(p,tmp)
  6063. status_ok = .true.
  6064. created = .true.
  6065. else
  6066. ! it was already there.
  6067. created = .false.
  6068. end if
  6069. else
  6070. ! have a token, see if it is valid:
  6071. call json%get_child(p,token,tmp,status_ok)
  6072. end if
  6073. if (status_ok) then
  6074. ! it was found
  6075. p => tmp
  6076. else
  6077. call json%throw_exception(&
  6078. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6079. 'invalid token found: "'//token//&
  6080. '" in path: '//trim(path),found)
  6081. exit
  6082. end if
  6083. iend = iend + 1 ! move counter to ] index
  6084. else
  6085. call json%throw_exception(&
  6086. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6087. 'invalid path: '//trim(path),found)
  6088. exit
  6089. end if
  6090. else
  6091. ! it might be an integer value: [123]
  6092. iend = istart + index(path(istart+1:ilen),end_array) ! ]
  6093. if (iend>istart+1) then
  6094. ! this should be an integer:
  6095. token = path(istart+1:iend-1)
  6096. ! verify that there are no spaces or other
  6097. ! characters in the string:
  6098. status_ok = .true.
  6099. do i=1,len(token)
  6100. ! It must only contain (0..9) characters
  6101. ! (it must be unsigned)
  6102. if (scan(token(i:i),CK_'0123456789')<1) then
  6103. status_ok = .false.
  6104. exit
  6105. end if
  6106. end do
  6107. if (status_ok) then
  6108. call string_to_integer(token,ival,status_ok)
  6109. if (status_ok) status_ok = ival>0 ! assuming 1-based array indices
  6110. end if
  6111. if (status_ok) then
  6112. ! have a valid integer to use as an index
  6113. ! see if this element is really there:
  6114. call json%get_child(p,ival,tmp,status_ok)
  6115. if (create .and. .not. status_ok) then
  6116. ! have to create it:
  6117. if (.not.(p%var_type==json_object .or. p%var_type==json_array)) then
  6118. ! we need to convert it into an array here
  6119. ! (e.g., if p was also just created)
  6120. ! and destroy its data to prevent a memory leak
  6121. call json%convert(p,json_array)
  6122. end if
  6123. ! have to create this element
  6124. ! [make it a null]
  6125. ! (and any missing ones before it)
  6126. do j = 1, ival
  6127. nullify(tmp)
  6128. call json%get_child(p, j, tmp, status_ok)
  6129. if (.not. status_ok) then
  6130. call json_value_create(tmp)
  6131. call json%to_null(tmp) ! array element doesn't need a name
  6132. call json%add(p,tmp)
  6133. if (j==ival) created = .true.
  6134. else
  6135. if (j==ival) created = .false.
  6136. end if
  6137. end do
  6138. status_ok = .true.
  6139. else
  6140. created = .false.
  6141. end if
  6142. if (status_ok) then
  6143. ! found it
  6144. p => tmp
  6145. else
  6146. ! not found
  6147. call json%throw_exception(&
  6148. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6149. 'invalid array index found: "'//token//&
  6150. '" in path: '//trim(path),found)
  6151. exit
  6152. end if
  6153. else
  6154. call json%throw_exception(&
  6155. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6156. 'invalid token: "'//token//&
  6157. '" in path: '//trim(path),found)
  6158. exit
  6159. end if
  6160. else
  6161. call json%throw_exception(&
  6162. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6163. 'invalid path: '//trim(path),found)
  6164. exit
  6165. end if
  6166. end if
  6167. else
  6168. call json%throw_exception(&
  6169. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6170. 'invalid path: '//trim(path),found)
  6171. exit
  6172. end if
  6173. ! set up for next token:
  6174. istart = iend + 1
  6175. end do
  6176. end if
  6177. else
  6178. call json%throw_exception(&
  6179. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6180. 'expecting "'//root//'", found: "'//path(1:1)//&
  6181. '" in path: '//trim(path),found)
  6182. end if
  6183. end if
  6184. if (json%exception_thrown) then
  6185. nullify(p)
  6186. if (present(found)) then
  6187. found = .false.
  6188. call json%clear_exceptions()
  6189. end if
  6190. else
  6191. if (present(found)) found = .true.
  6192. end if
  6193. ! if it had to be created:
  6194. if (present(was_created)) was_created = created
  6195. else
  6196. if (present(found)) found = .false.
  6197. if (present(was_created)) was_created = .false.
  6198. end if
  6199. end subroutine json_get_by_path_jsonpath_bracket
  6200. !*****************************************************************************************
  6201. !*****************************************************************************************
  6202. !>
  6203. ! Convert an existing JSON variable `p` to a different variable type.
  6204. ! The existing variable (and its children) is destroyed. It is replaced
  6205. ! in the structure by a new variable of type `var_type`
  6206. ! (which can be a `json_null`, `json_object` or `json_array`).
  6207. !
  6208. !@note This is an internal routine used when creating variables by path.
  6209. subroutine convert(json,p,var_type)
  6210. implicit none
  6211. class(json_core),intent(inout) :: json
  6212. type(json_value),pointer :: p !! the variable to convert
  6213. integer(IK),intent(in) :: var_type !! the variable type to convert `p` to
  6214. type(json_value),pointer :: tmp !! temporary variable
  6215. character(kind=CK,len=:),allocatable :: name !! the name of a JSON variable
  6216. logical :: convert_it !! if `p` needs to be converted
  6217. convert_it = p%var_type /= var_type
  6218. if (convert_it) then
  6219. call json%info(p,name=name) ! get existing name
  6220. select case (var_type)
  6221. case(json_object)
  6222. call json%create_object(tmp,name)
  6223. case(json_array)
  6224. call json%create_array(tmp,name)
  6225. case(json_null)
  6226. call json%create_null(tmp,name)
  6227. case default
  6228. call json%throw_exception('Error in convert: invalid var_type value.')
  6229. return
  6230. end select
  6231. call json%replace(p,tmp,destroy=.true.)
  6232. p => tmp
  6233. nullify(tmp)
  6234. end if
  6235. end subroutine convert
  6236. !*****************************************************************************************
  6237. !*****************************************************************************************
  6238. !>
  6239. ! Alternate version of [[json_get_by_path]] where "path" is kind=CDK.
  6240. subroutine wrap_json_get_by_path(json, me, path, p, found)
  6241. implicit none
  6242. class(json_core),intent(inout) :: json
  6243. type(json_value),pointer,intent(in) :: me
  6244. character(kind=CDK,len=*),intent(in) :: path
  6245. type(json_value),pointer,intent(out) :: p
  6246. logical(LK),intent(out),optional :: found
  6247. call json%get(me, to_unicode(path), p, found)
  6248. end subroutine wrap_json_get_by_path
  6249. !*****************************************************************************************
  6250. !*****************************************************************************************
  6251. !>
  6252. ! Returns the path to a JSON object that is part
  6253. ! of a linked list structure.
  6254. !
  6255. ! The path returned would be suitable for input to
  6256. ! [[json_get_by_path]] and related routines.
  6257. !
  6258. !@note If an error occurs (which in this case means a malformed
  6259. ! JSON structure) then an exception will be thrown, unless
  6260. ! `found` is present, which will be set to `false`. `path`
  6261. ! will be a blank string.
  6262. !
  6263. !@note If `json%path_mode/=1`, then the `use_alt_array_tokens`
  6264. ! and `path_sep` inputs are ignored if present.
  6265. !
  6266. !@note [http://goessner.net/articles/JsonPath/](JSONPath) (`path_mode=3`)
  6267. ! does not specify whether or not the keys should be escaped (this routine
  6268. ! assumes not, as does http://jsonpath.com).
  6269. ! Also, we are using Fortran-style 1-based array indices,
  6270. ! not 0-based, to agree with the assumption in `path_mode=1`
  6271. subroutine json_get_path(json, p, path, found, use_alt_array_tokens, path_sep)
  6272. implicit none
  6273. class(json_core),intent(inout) :: json
  6274. type(json_value),pointer,intent(in) :: p !! a JSON linked list object
  6275. character(kind=CK,len=:),allocatable,intent(out) :: path !! path to the variable
  6276. logical(LK),intent(out),optional :: found !! true if there were no problems
  6277. logical(LK),intent(in),optional :: use_alt_array_tokens !! if true, then '()' are used for array elements
  6278. !! otherwise, '[]' are used [default]
  6279. !! (only used if `path_mode=1`)
  6280. character(kind=CK,len=1),intent(in),optional :: path_sep !! character to use for path separator
  6281. !! (otherwise use `json%path_separator`)
  6282. !! (only used if `path_mode=1`)
  6283. character(kind=CK,len=:),allocatable :: name !! variable name
  6284. character(kind=CK,len=:),allocatable :: parent_name !! variable's parent name
  6285. character(kind=CK,len=max_integer_str_len) :: istr !! for integer to string conversion
  6286. !! (array indices)
  6287. type(json_value),pointer :: tmp !! for traversing the structure
  6288. type(json_value),pointer :: element !! for traversing the structure
  6289. integer(IK) :: var_type !! JSON variable type flag
  6290. integer(IK) :: i !! counter
  6291. integer(IK) :: n_children !! number of children for parent
  6292. logical(LK) :: use_brackets !! to use '[]' characters for arrays
  6293. logical(LK) :: parent_is_root !! if the parent is the root
  6294. character(kind=CK,len=1) :: array_start !! for `path_mode=1`, the character to start arrays
  6295. character(kind=CK,len=1) :: array_end !! for `path_mode=1`, the character to end arrays
  6296. logical :: consecutive_arrays !! check for array of array case
  6297. integer(IK) :: parents_parent_var_type !! `var_type` for parent's parent
  6298. !optional input:
  6299. if (present(use_alt_array_tokens)) then
  6300. use_brackets = .not. use_alt_array_tokens
  6301. else
  6302. use_brackets = .true.
  6303. end if
  6304. if (json%path_mode==1_IK) then
  6305. if (use_brackets) then
  6306. array_start = start_array
  6307. array_end = end_array
  6308. else
  6309. array_start = start_array_alt
  6310. array_end = end_array_alt
  6311. end if
  6312. end if
  6313. ! initialize:
  6314. consecutive_arrays = .false.
  6315. if (associated(p)) then
  6316. !traverse the structure via parents up to the root
  6317. tmp => p
  6318. do
  6319. if (.not. associated(tmp)) exit !finished
  6320. !get info about the current variable:
  6321. call json%info(tmp,name=name)
  6322. if (json%path_mode==2_IK) then
  6323. name = encode_rfc6901(name)
  6324. end if
  6325. ! if tmp a child of an object, or an element of an array
  6326. if (associated(tmp%parent)) then
  6327. !get info about the parent:
  6328. call json%info(tmp%parent,var_type=var_type,&
  6329. n_children=n_children,name=parent_name)
  6330. if (json%path_mode==2_IK) then
  6331. parent_name = encode_rfc6901(parent_name)
  6332. end if
  6333. if (associated(tmp%parent%parent)) then
  6334. call json%info(tmp%parent%parent,var_type=parents_parent_var_type)
  6335. consecutive_arrays = parents_parent_var_type == json_array .and. &
  6336. var_type == json_array
  6337. else
  6338. consecutive_arrays = .false.
  6339. end if
  6340. select case (var_type)
  6341. case (json_array)
  6342. !get array index of this element:
  6343. element => tmp%parent%children
  6344. do i = 1, n_children
  6345. if (.not. associated(element)) then
  6346. call json%throw_exception('Error in json_get_path: '//&
  6347. 'malformed JSON structure. ',found)
  6348. exit
  6349. end if
  6350. if (associated(element,tmp)) then
  6351. exit
  6352. else
  6353. element => element%next
  6354. end if
  6355. if (i==n_children) then ! it wasn't found (should never happen)
  6356. call json%throw_exception('Error in json_get_path: '//&
  6357. 'malformed JSON structure. ',found)
  6358. exit
  6359. end if
  6360. end do
  6361. select case(json%path_mode)
  6362. case(3_IK)
  6363. ! JSONPath "bracket-notation"
  6364. ! example: `$['key'][1]`
  6365. ! [note: this uses 1-based indices]
  6366. call integer_to_string(i,int_fmt,istr)
  6367. if (consecutive_arrays) then
  6368. call add_to_path(start_array//trim(adjustl(istr))//end_array,CK_'')
  6369. else
  6370. call add_to_path(start_array//single_quote//parent_name//&
  6371. single_quote//end_array//&
  6372. start_array//trim(adjustl(istr))//end_array,CK_'')
  6373. end if
  6374. case(2_IK)
  6375. ! rfc6901
  6376. ! Example: '/key/0'
  6377. call integer_to_string(i-1_IK,int_fmt,istr) ! 0-based index
  6378. if (consecutive_arrays) then
  6379. call add_to_path(trim(adjustl(istr)))
  6380. else
  6381. call add_to_path(parent_name//slash//trim(adjustl(istr)))
  6382. end if
  6383. case(1_IK)
  6384. ! default
  6385. ! Example: `key[1]`
  6386. call integer_to_string(i,int_fmt,istr)
  6387. if (consecutive_arrays) then
  6388. call add_to_path(array_start//trim(adjustl(istr))//array_end,path_sep)
  6389. else
  6390. call add_to_path(parent_name//array_start//&
  6391. trim(adjustl(istr))//array_end,path_sep)
  6392. end if
  6393. end select
  6394. if (.not. consecutive_arrays) tmp => tmp%parent ! already added parent name
  6395. case (json_object)
  6396. if (.not. consecutive_arrays) then
  6397. ! idea is not to print the array name if
  6398. ! it was already printed with the array
  6399. !process parent on the next pass
  6400. select case(json%path_mode)
  6401. case(3_IK)
  6402. call add_to_path(start_array//single_quote//name//&
  6403. single_quote//end_array,CK_'')
  6404. case default
  6405. call add_to_path(name,path_sep)
  6406. end select
  6407. end if
  6408. case default
  6409. call json%throw_exception('Error in json_get_path: '//&
  6410. 'malformed JSON structure. '//&
  6411. 'A variable that is not an object '//&
  6412. 'or array should not have a child.',found)
  6413. exit
  6414. end select
  6415. else
  6416. !the last one:
  6417. select case(json%path_mode)
  6418. case(3_IK)
  6419. call add_to_path(start_array//single_quote//name//&
  6420. single_quote//end_array,CK_'')
  6421. case default
  6422. call add_to_path(name,path_sep)
  6423. end select
  6424. end if
  6425. if (associated(tmp%parent)) then
  6426. !check if the parent is the root:
  6427. parent_is_root = (.not. associated(tmp%parent%parent))
  6428. if (parent_is_root) exit
  6429. end if
  6430. !go to parent:
  6431. tmp => tmp%parent
  6432. end do
  6433. else
  6434. call json%throw_exception('Error in json_get_path: '//&
  6435. 'input pointer is not associated',found)
  6436. end if
  6437. !for errors, return blank string:
  6438. if (json%exception_thrown .or. .not. allocated(path)) then
  6439. path = CK_''
  6440. else
  6441. select case (json%path_mode)
  6442. case(3_IK)
  6443. ! add the outer level object identifier:
  6444. path = root//path
  6445. case(2_IK)
  6446. ! add the root slash:
  6447. path = slash//path
  6448. end select
  6449. end if
  6450. !optional output:
  6451. if (present(found)) then
  6452. if (json%exception_thrown) then
  6453. found = .false.
  6454. call json%clear_exceptions()
  6455. else
  6456. found = .true.
  6457. end if
  6458. end if
  6459. contains
  6460. subroutine add_to_path(str,path_sep)
  6461. !! prepend the string to the path
  6462. implicit none
  6463. character(kind=CK,len=*),intent(in) :: str !! string to prepend to `path`
  6464. character(kind=CK,len=*),intent(in),optional :: path_sep
  6465. !! path separator (default is '.').
  6466. !! (ignored if `json%path_mode/=1`)
  6467. select case (json%path_mode)
  6468. case(3_IK)
  6469. ! in this case, the options are ignored
  6470. if (.not. allocated(path)) then
  6471. path = str
  6472. else
  6473. path = str//path
  6474. end if
  6475. case(2_IK)
  6476. ! in this case, the options are ignored
  6477. if (.not. allocated(path)) then
  6478. path = str
  6479. else
  6480. path = str//slash//path
  6481. end if
  6482. case(1_IK)
  6483. ! default path format
  6484. if (.not. allocated(path)) then
  6485. path = str
  6486. else
  6487. ! shouldn't add the path_sep for cases like x[1][2]
  6488. ! [if current is an array element, and the previous was
  6489. ! also an array element] so check for that here:
  6490. if (.not. ( str(len(str):len(str))==array_end .and. &
  6491. path(1:1)==array_start )) then
  6492. if (present(path_sep)) then
  6493. ! use user specified:
  6494. path = str//path_sep//path
  6495. else
  6496. ! use the default:
  6497. path = str//json%path_separator//path
  6498. end if
  6499. else
  6500. path = str//path
  6501. end if
  6502. end if
  6503. end select
  6504. end subroutine add_to_path
  6505. end subroutine json_get_path
  6506. !*****************************************************************************************
  6507. !*****************************************************************************************
  6508. !>
  6509. ! Wrapper for [[json_get_path]] where "path" and "path_sep" are kind=CDK.
  6510. subroutine wrap_json_get_path(json, p, path, found, use_alt_array_tokens, path_sep)
  6511. implicit none
  6512. class(json_core),intent(inout) :: json
  6513. type(json_value),pointer,intent(in) :: p !! a JSON linked list object
  6514. character(kind=CDK,len=:),allocatable,intent(out) :: path !! path to the variable
  6515. logical(LK),intent(out),optional :: found !! true if there were no problems
  6516. logical(LK),intent(in),optional :: use_alt_array_tokens !! if true, then '()' are used
  6517. !! for array elements otherwise,
  6518. !! '[]' are used [default]
  6519. character(kind=CDK,len=1),intent(in),optional :: path_sep !! character to use for path
  6520. !! separator (default is '.')
  6521. character(kind=CK,len=:),allocatable :: ck_path !! path to the variable
  6522. ! call the main routine:
  6523. if (present(path_sep)) then
  6524. call json%get_path(p,ck_path,found,use_alt_array_tokens,to_unicode(path_sep))
  6525. else
  6526. call json%get_path(p,ck_path,found,use_alt_array_tokens)
  6527. end if
  6528. ! from unicode:
  6529. path = ck_path
  6530. end subroutine wrap_json_get_path
  6531. !*****************************************************************************************
  6532. !*****************************************************************************************
  6533. !>
  6534. ! Convert a string into an integer.
  6535. !
  6536. !@note Replacement for the `parse_integer` function in the original code.
  6537. function string_to_int(json,str) result(ival)
  6538. implicit none
  6539. class(json_core),intent(inout) :: json
  6540. character(kind=CK,len=*),intent(in) :: str !! a string
  6541. integer(IK) :: ival !! `str` converted to an integer
  6542. logical(LK) :: status_ok !! error flag for [[string_to_integer]]
  6543. ! call the core routine:
  6544. call string_to_integer(str,ival,status_ok)
  6545. if (.not. status_ok) then
  6546. ival = 0
  6547. call json%throw_exception('Error in string_to_int: '//&
  6548. 'string cannot be converted to an integer: '//&
  6549. trim(str))
  6550. end if
  6551. end function string_to_int
  6552. !*****************************************************************************************
  6553. !*****************************************************************************************
  6554. !>
  6555. ! Convert a string into a `real(RK)` value.
  6556. function string_to_dble(json,str) result(rval)
  6557. implicit none
  6558. class(json_core),intent(inout) :: json
  6559. character(kind=CK,len=*),intent(in) :: str !! a string
  6560. real(RK) :: rval !! `str` converted to a `real(RK)`
  6561. logical(LK) :: status_ok !! error flag for [[string_to_real]]
  6562. call string_to_real(str,json%use_quiet_nan,rval,status_ok)
  6563. if (.not. status_ok) then !if there was an error
  6564. rval = 0.0_RK
  6565. call json%throw_exception('Error in string_to_dble: '//&
  6566. 'string cannot be converted to a real: '//&
  6567. trim(str))
  6568. end if
  6569. end function string_to_dble
  6570. !*****************************************************************************************
  6571. !*****************************************************************************************
  6572. !>
  6573. ! Get an integer value from a [[json_value]].
  6574. subroutine json_get_integer(json, me, value)
  6575. implicit none
  6576. class(json_core),intent(inout) :: json
  6577. type(json_value),pointer,intent(in) :: me
  6578. integer(IK),intent(out) :: value !! the integer value
  6579. logical(LK) :: status_ok !! for [[string_to_integer]]
  6580. value = 0_IK
  6581. if ( json%exception_thrown ) return
  6582. if (me%var_type == json_integer) then
  6583. value = me%int_value
  6584. else
  6585. if (json%strict_type_checking) then
  6586. if (allocated(me%name)) then
  6587. call json%throw_exception('Error in json_get_integer:'//&
  6588. ' Unable to resolve value to integer: '//me%name)
  6589. else
  6590. call json%throw_exception('Error in json_get_integer:'//&
  6591. ' Unable to resolve value to integer')
  6592. end if
  6593. else
  6594. !type conversions
  6595. select case(me%var_type)
  6596. case (json_real)
  6597. value = int(me%dbl_value, IK)
  6598. case (json_logical)
  6599. if (me%log_value) then
  6600. value = 1_IK
  6601. else
  6602. value = 0_IK
  6603. end if
  6604. case (json_string)
  6605. call string_to_integer(me%str_value,value,status_ok)
  6606. if (.not. status_ok) then
  6607. value = 0_IK
  6608. if (allocated(me%name)) then
  6609. call json%throw_exception('Error in json_get_integer:'//&
  6610. ' Unable to convert string value to integer: '//&
  6611. me%name//' = '//trim(me%str_value))
  6612. else
  6613. call json%throw_exception('Error in json_get_integer:'//&
  6614. ' Unable to convert string value to integer: '//&
  6615. trim(me%str_value))
  6616. end if
  6617. end if
  6618. case default
  6619. if (allocated(me%name)) then
  6620. call json%throw_exception('Error in json_get_integer:'//&
  6621. ' Unable to resolve value to integer: '//me%name)
  6622. else
  6623. call json%throw_exception('Error in json_get_integer:'//&
  6624. ' Unable to resolve value to integer')
  6625. end if
  6626. end select
  6627. end if
  6628. end if
  6629. end subroutine json_get_integer
  6630. !*****************************************************************************************
  6631. !*****************************************************************************************
  6632. !>
  6633. ! Get an integer value from a [[json_value]], given the path string.
  6634. subroutine json_get_integer_by_path(json, me, path, value, found, default)
  6635. implicit none
  6636. class(json_core),intent(inout) :: json
  6637. type(json_value),pointer,intent(in) :: me
  6638. character(kind=CK,len=*),intent(in) :: path
  6639. integer(IK),intent(out) :: value
  6640. logical(LK),intent(out),optional :: found
  6641. integer(IK),intent(in),optional :: default !! default value if not found
  6642. integer(IK),parameter :: default_if_not_specified = 0_IK
  6643. character(kind=CK,len=*),parameter :: routine = CK_'json_get_integer_by_path'
  6644. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_scalar_by_path.inc" 1
  6645. type(json_value),pointer :: p
  6646. if (present(default)) then
  6647. value = default
  6648. else
  6649. value = default_if_not_specified
  6650. end if
  6651. if ( json%exception_thrown ) then
  6652. call flag_not_found(found)
  6653. return
  6654. end if
  6655. nullify(p)
  6656. call json%get(me=me, path=path, p=p)
  6657. if (.not. associated(p)) then
  6658. call json%throw_exception('Error in '//routine//':'//&
  6659. ' Unable to resolve path: '// trim(path),found)
  6660. else
  6661. call json%get(p,value)
  6662. end if
  6663. if ( json%exception_thrown ) then
  6664. if ( present(found) .or. present(default)) then
  6665. call flag_not_found(found)
  6666. if (present(default)) value = default
  6667. call json%clear_exceptions()
  6668. end if
  6669. else
  6670. if ( present(found) ) found = .true.
  6671. end if
  6672. # 8210 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  6673. end subroutine json_get_integer_by_path
  6674. !*****************************************************************************************
  6675. !*****************************************************************************************
  6676. !>
  6677. ! Alternate version of [[json_get_integer_by_path]], where "path" is kind=CDK.
  6678. subroutine wrap_json_get_integer_by_path(json, me, path, value, found, default)
  6679. implicit none
  6680. class(json_core),intent(inout) :: json
  6681. type(json_value),pointer,intent(in) :: me
  6682. character(kind=CDK,len=*),intent(in) :: path
  6683. integer(IK),intent(out) :: value
  6684. logical(LK),intent(out),optional :: found
  6685. integer(IK),intent(in),optional :: default !! default value if not found
  6686. call json%get(me, to_unicode(path), value, found, default)
  6687. end subroutine wrap_json_get_integer_by_path
  6688. !*****************************************************************************************
  6689. !*****************************************************************************************
  6690. !> author: Jacob Williams
  6691. ! date: 5/14/2014
  6692. !
  6693. ! Get an integer vector from a [[json_value]].
  6694. subroutine json_get_integer_vec(json, me, vec)
  6695. implicit none
  6696. class(json_core),intent(inout) :: json
  6697. type(json_value),pointer :: me
  6698. integer(IK),dimension(:),allocatable,intent(out) :: vec
  6699. logical(LK) :: initialized
  6700. if ( json%exception_thrown ) return
  6701. ! check for 0-length arrays first:
  6702. select case (me%var_type)
  6703. case (json_array)
  6704. if (json%count(me)==0) then
  6705. allocate(vec(0))
  6706. return
  6707. end if
  6708. end select
  6709. initialized = .false.
  6710. !the callback function is called for each element of the array:
  6711. call json%get(me, array_callback=get_int_from_array)
  6712. if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
  6713. contains
  6714. subroutine get_int_from_array(json, element, i, count)
  6715. !! callback function for integer
  6716. implicit none
  6717. class(json_core),intent(inout) :: json
  6718. type(json_value),pointer,intent(in) :: element
  6719. integer(IK),intent(in) :: i !! index
  6720. integer(IK),intent(in) :: count !! size of array
  6721. !size the output array:
  6722. if (.not. initialized) then
  6723. allocate(vec(count))
  6724. initialized = .true.
  6725. end if
  6726. !populate the elements:
  6727. call json%get(element, value=vec(i))
  6728. end subroutine get_int_from_array
  6729. end subroutine json_get_integer_vec
  6730. !*****************************************************************************************
  6731. !*****************************************************************************************
  6732. !>
  6733. ! If `found` is present, set it it false.
  6734. subroutine flag_not_found(found)
  6735. implicit none
  6736. logical(LK),intent(out),optional :: found
  6737. if (present(found)) found = .false.
  6738. end subroutine flag_not_found
  6739. !*****************************************************************************************
  6740. !*****************************************************************************************
  6741. !>
  6742. ! Get an integer vector from a [[json_value]], given the path string.
  6743. subroutine json_get_integer_vec_by_path(json, me, path, vec, found, default)
  6744. implicit none
  6745. class(json_core),intent(inout) :: json
  6746. type(json_value),pointer,intent(in) :: me
  6747. character(kind=CK,len=*),intent(in) :: path
  6748. integer(IK),dimension(:),allocatable,intent(out) :: vec
  6749. logical(LK),intent(out),optional :: found
  6750. integer(IK),dimension(:),intent(in),optional :: default !! default value if not found
  6751. character(kind=CK,len=*),parameter :: routine = CK_'json_get_integer_vec_by_path'
  6752. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_vec_by_path.inc" 1
  6753. type(json_value),pointer :: p
  6754. if ( json%exception_thrown ) then
  6755. if (present(default)) vec = default
  6756. call flag_not_found(found)
  6757. return
  6758. end if
  6759. nullify(p)
  6760. call json%get(me=me, path=path, p=p)
  6761. if (.not. associated(p)) then
  6762. call json%throw_exception('Error in '//routine//':'//&
  6763. ' Unable to resolve path: '// trim(path),found)
  6764. else
  6765. call json%get(p,vec)
  6766. end if
  6767. if ( json%exception_thrown ) then
  6768. if ( present(found) .or. present(default)) then
  6769. call flag_not_found(found)
  6770. if (present(default)) vec = default
  6771. call json%clear_exceptions()
  6772. end if
  6773. else
  6774. if ( present(found) ) found = .true.
  6775. end if
  6776. # 8328 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  6777. end subroutine json_get_integer_vec_by_path
  6778. !*****************************************************************************************
  6779. !*****************************************************************************************
  6780. !>
  6781. ! Alternate version of [[json_get_integer_vec_by_path]], where "path" is kind=CDK
  6782. subroutine wrap_json_get_integer_vec_by_path(json, me, path, vec, found, default)
  6783. implicit none
  6784. class(json_core),intent(inout) :: json
  6785. type(json_value),pointer :: me
  6786. character(kind=CDK,len=*),intent(in) :: path
  6787. integer(IK),dimension(:),allocatable,intent(out) :: vec
  6788. logical(LK),intent(out),optional :: found
  6789. integer(IK),dimension(:),intent(in),optional :: default !! default value if not found
  6790. call json%get(me,path=to_unicode(path),vec=vec,found=found,default=default)
  6791. end subroutine wrap_json_get_integer_vec_by_path
  6792. !*****************************************************************************************
  6793. !*****************************************************************************************
  6794. !>
  6795. ! Get a real value from a [[json_value]].
  6796. subroutine json_get_real(json, me, value)
  6797. implicit none
  6798. class(json_core),intent(inout) :: json
  6799. type(json_value),pointer :: me
  6800. real(RK),intent(out) :: value
  6801. logical(LK) :: status_ok !! for [[string_to_real]]
  6802. value = 0.0_RK
  6803. if ( json%exception_thrown ) return
  6804. if (me%var_type == json_real) then
  6805. value = me%dbl_value
  6806. else
  6807. if (json%strict_type_checking) then
  6808. if (allocated(me%name)) then
  6809. call json%throw_exception('Error in json_get_real:'//&
  6810. ' Unable to resolve value to real: '//me%name)
  6811. else
  6812. call json%throw_exception('Error in json_get_real:'//&
  6813. ' Unable to resolve value to real')
  6814. end if
  6815. else
  6816. !type conversions
  6817. select case (me%var_type)
  6818. case (json_integer)
  6819. value = real(me%int_value, RK)
  6820. case (json_logical)
  6821. if (me%log_value) then
  6822. value = 1.0_RK
  6823. else
  6824. value = 0.0_RK
  6825. end if
  6826. case (json_string)
  6827. call string_to_real(me%str_value,json%use_quiet_nan,value,status_ok)
  6828. if (.not. status_ok) then
  6829. value = 0.0_RK
  6830. if (allocated(me%name)) then
  6831. call json%throw_exception('Error in json_get_real:'//&
  6832. ' Unable to convert string value to real: '//&
  6833. me%name//' = '//trim(me%str_value))
  6834. else
  6835. call json%throw_exception('Error in json_get_real:'//&
  6836. ' Unable to convert string value to real: '//&
  6837. trim(me%str_value))
  6838. end if
  6839. end if
  6840. case (json_null)
  6841. if (ieee_support_nan(value) .and. json%null_to_real_mode/=1_IK) then
  6842. select case (json%null_to_real_mode)
  6843. case(2_IK)
  6844. if (json%use_quiet_nan) then
  6845. value = ieee_value(value,ieee_quiet_nan)
  6846. else
  6847. value = ieee_value(value,ieee_signaling_nan)
  6848. end if
  6849. case(3_IK)
  6850. value = 0.0_RK
  6851. end select
  6852. else
  6853. if (allocated(me%name)) then
  6854. call json%throw_exception('Error in json_get_real:'//&
  6855. ' Cannot convert null to NaN: '//me%name)
  6856. else
  6857. call json%throw_exception('Error in json_get_real:'//&
  6858. ' Cannot convert null to NaN')
  6859. end if
  6860. end if
  6861. case default
  6862. if (allocated(me%name)) then
  6863. call json%throw_exception('Error in json_get_real:'//&
  6864. ' Unable to resolve value to real: '//me%name)
  6865. else
  6866. call json%throw_exception('Error in json_get_real:'//&
  6867. ' Unable to resolve value to real')
  6868. end if
  6869. end select
  6870. end if
  6871. end if
  6872. end subroutine json_get_real
  6873. !*****************************************************************************************
  6874. !*****************************************************************************************
  6875. !>
  6876. ! Get a real value from a [[json_value]], given the path.
  6877. subroutine json_get_real_by_path(json, me, path, value, found, default)
  6878. implicit none
  6879. class(json_core),intent(inout) :: json
  6880. type(json_value),pointer :: me
  6881. character(kind=CK,len=*),intent(in) :: path
  6882. real(RK),intent(out) :: value
  6883. logical(LK),intent(out),optional :: found
  6884. real(RK),intent(in),optional :: default !! default value if not found
  6885. real(RK),parameter :: default_if_not_specified = 0.0_RK
  6886. character(kind=CK,len=*),parameter :: routine = CK_'json_get_real_by_path'
  6887. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_scalar_by_path.inc" 1
  6888. type(json_value),pointer :: p
  6889. if (present(default)) then
  6890. value = default
  6891. else
  6892. value = default_if_not_specified
  6893. end if
  6894. if ( json%exception_thrown ) then
  6895. call flag_not_found(found)
  6896. return
  6897. end if
  6898. nullify(p)
  6899. call json%get(me=me, path=path, p=p)
  6900. if (.not. associated(p)) then
  6901. call json%throw_exception('Error in '//routine//':'//&
  6902. ' Unable to resolve path: '// trim(path),found)
  6903. else
  6904. call json%get(p,value)
  6905. end if
  6906. if ( json%exception_thrown ) then
  6907. if ( present(found) .or. present(default)) then
  6908. call flag_not_found(found)
  6909. if (present(default)) value = default
  6910. call json%clear_exceptions()
  6911. end if
  6912. else
  6913. if ( present(found) ) found = .true.
  6914. end if
  6915. # 8460 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  6916. end subroutine json_get_real_by_path
  6917. !*****************************************************************************************
  6918. !*****************************************************************************************
  6919. !>
  6920. ! Alternate version of [[json_get_real_by_path]], where "path" is kind=CDK
  6921. subroutine wrap_json_get_real_by_path(json, me, path, value, found, default)
  6922. implicit none
  6923. class(json_core),intent(inout) :: json
  6924. type(json_value),pointer :: me
  6925. character(kind=CDK,len=*),intent(in) :: path
  6926. real(RK),intent(out) :: value
  6927. logical(LK),intent(out),optional :: found
  6928. real(RK),intent(in),optional :: default !! default value if not found
  6929. call json%get(me,to_unicode(path),value,found,default)
  6930. end subroutine wrap_json_get_real_by_path
  6931. !*****************************************************************************************
  6932. !*****************************************************************************************
  6933. !> author: Jacob Williams
  6934. ! date: 5/14/2014
  6935. !
  6936. ! Get a real vector from a [[json_value]].
  6937. subroutine json_get_real_vec(json, me, vec)
  6938. implicit none
  6939. class(json_core),intent(inout) :: json
  6940. type(json_value),pointer :: me
  6941. real(RK),dimension(:),allocatable,intent(out) :: vec
  6942. logical(LK) :: initialized
  6943. if ( json%exception_thrown ) return
  6944. ! check for 0-length arrays first:
  6945. select case (me%var_type)
  6946. case (json_array)
  6947. if (json%count(me)==0) then
  6948. allocate(vec(0))
  6949. return
  6950. end if
  6951. end select
  6952. initialized = .false.
  6953. !the callback function is called for each element of the array:
  6954. call json%get(me, array_callback=get_real_from_array)
  6955. if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
  6956. contains
  6957. subroutine get_real_from_array(json, element, i, count)
  6958. !! callback function for real
  6959. implicit none
  6960. class(json_core),intent(inout) :: json
  6961. type(json_value),pointer,intent(in) :: element
  6962. integer(IK),intent(in) :: i !! index
  6963. integer(IK),intent(in) :: count !! size of array
  6964. !size the output array:
  6965. if (.not. initialized) then
  6966. allocate(vec(count))
  6967. initialized = .true.
  6968. end if
  6969. !populate the elements:
  6970. call json%get(element, value=vec(i))
  6971. end subroutine get_real_from_array
  6972. end subroutine json_get_real_vec
  6973. !*****************************************************************************************
  6974. !*****************************************************************************************
  6975. !>
  6976. ! Get a real vector from a [[json_value]], given the path.
  6977. subroutine json_get_real_vec_by_path(json, me, path, vec, found, default)
  6978. implicit none
  6979. class(json_core),intent(inout) :: json
  6980. type(json_value),pointer,intent(in) :: me
  6981. character(kind=CK,len=*),intent(in) :: path
  6982. real(RK),dimension(:),allocatable,intent(out) :: vec
  6983. logical(LK),intent(out),optional :: found
  6984. real(RK),dimension(:),intent(in),optional :: default !! default value if not found
  6985. character(kind=CK,len=*),parameter :: routine = CK_'json_get_real_vec_by_path'
  6986. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_vec_by_path.inc" 1
  6987. type(json_value),pointer :: p
  6988. if ( json%exception_thrown ) then
  6989. if (present(default)) vec = default
  6990. call flag_not_found(found)
  6991. return
  6992. end if
  6993. nullify(p)
  6994. call json%get(me=me, path=path, p=p)
  6995. if (.not. associated(p)) then
  6996. call json%throw_exception('Error in '//routine//':'//&
  6997. ' Unable to resolve path: '// trim(path),found)
  6998. else
  6999. call json%get(p,vec)
  7000. end if
  7001. if ( json%exception_thrown ) then
  7002. if ( present(found) .or. present(default)) then
  7003. call flag_not_found(found)
  7004. if (present(default)) vec = default
  7005. call json%clear_exceptions()
  7006. end if
  7007. else
  7008. if ( present(found) ) found = .true.
  7009. end if
  7010. # 8563 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  7011. end subroutine json_get_real_vec_by_path
  7012. !*****************************************************************************************
  7013. !*****************************************************************************************
  7014. !>
  7015. ! Alternate version of [[json_get_real_vec_by_path]], where "path" is kind=CDK
  7016. subroutine wrap_json_get_real_vec_by_path(json, me, path, vec, found, default)
  7017. implicit none
  7018. class(json_core),intent(inout) :: json
  7019. type(json_value),pointer :: me
  7020. character(kind=CDK,len=*),intent(in) :: path
  7021. real(RK),dimension(:),allocatable,intent(out) :: vec
  7022. logical(LK),intent(out),optional :: found
  7023. real(RK),dimension(:),intent(in),optional :: default !! default value if not found
  7024. call json%get(me, to_unicode(path), vec, found, default)
  7025. end subroutine wrap_json_get_real_vec_by_path
  7026. !*****************************************************************************************
  7027. !*****************************************************************************************
  7028. !>
  7029. ! Alternate version of [[json_get_real]] where value=real32.
  7030. subroutine json_get_real32(json, me, value)
  7031. implicit none
  7032. class(json_core),intent(inout) :: json
  7033. type(json_value),pointer :: me
  7034. real(real32),intent(out) :: value
  7035. real(RK) :: tmp
  7036. call json%get(me, tmp)
  7037. value = real(tmp,real32)
  7038. end subroutine json_get_real32
  7039. !*****************************************************************************************
  7040. !*****************************************************************************************
  7041. !>
  7042. ! Alternate version of [[json_get_real_by_path]] where value=real32.
  7043. subroutine json_get_real32_by_path(json, me, path, value, found, default)
  7044. implicit none
  7045. class(json_core),intent(inout) :: json
  7046. type(json_value),pointer :: me
  7047. character(kind=CK,len=*),intent(in) :: path
  7048. real(real32),intent(out) :: value
  7049. logical(LK),intent(out),optional :: found
  7050. real(real32),intent(in),optional :: default !! default value if not found
  7051. real(RK) :: tmp
  7052. real(RK) :: tmp_default
  7053. if (present(default)) then
  7054. tmp_default = real(default,RK)
  7055. call json%get(me, path, tmp, found, tmp_default)
  7056. else
  7057. call json%get(me, path, tmp, found)
  7058. end if
  7059. value = real(tmp,real32)
  7060. end subroutine json_get_real32_by_path
  7061. !*****************************************************************************************
  7062. !*****************************************************************************************
  7063. !>
  7064. ! Alternate version of [[json_get_real32_by_path]], where "path" is kind=CDK
  7065. subroutine wrap_json_get_real32_by_path(json, me, path, value, found, default)
  7066. implicit none
  7067. class(json_core),intent(inout) :: json
  7068. type(json_value),pointer :: me
  7069. character(kind=CDK,len=*),intent(in) :: path
  7070. real(real32),intent(out) :: value
  7071. logical(LK),intent(out),optional :: found
  7072. real(real32),intent(in),optional :: default !! default value if not found
  7073. call json%get(me,to_unicode(path),value,found,default)
  7074. end subroutine wrap_json_get_real32_by_path
  7075. !*****************************************************************************************
  7076. !*****************************************************************************************
  7077. !>
  7078. ! Alternate version of [[json_get_real_vec]] where `vec` is `real32`.
  7079. subroutine json_get_real32_vec(json, me, vec)
  7080. implicit none
  7081. class(json_core),intent(inout) :: json
  7082. type(json_value),pointer :: me
  7083. real(real32),dimension(:),allocatable,intent(out) :: vec
  7084. real(RK),dimension(:),allocatable :: tmp
  7085. call json%get(me, tmp)
  7086. if (allocated(tmp)) vec = real(tmp,real32)
  7087. end subroutine json_get_real32_vec
  7088. !*****************************************************************************************
  7089. !*****************************************************************************************
  7090. !>
  7091. ! Alternate version of [[json_get_real_vec_by_path]] where `vec` is `real32`.
  7092. subroutine json_get_real32_vec_by_path(json, me, path, vec, found, default)
  7093. implicit none
  7094. class(json_core),intent(inout) :: json
  7095. type(json_value),pointer,intent(in) :: me
  7096. character(kind=CK,len=*),intent(in) :: path
  7097. real(real32),dimension(:),allocatable,intent(out) :: vec
  7098. logical(LK),intent(out),optional :: found
  7099. real(real32),dimension(:),intent(in),optional :: default !! default value if not found
  7100. real(RK),dimension(:),allocatable :: tmp
  7101. real(RK),dimension(:),allocatable :: tmp_default
  7102. if (present(default)) then
  7103. tmp_default = real(default,RK)
  7104. call json%get(me, path, tmp, found, tmp_default)
  7105. else
  7106. call json%get(me, path, tmp, found)
  7107. end if
  7108. if (allocated(tmp)) vec = real(tmp,real32)
  7109. end subroutine json_get_real32_vec_by_path
  7110. !*****************************************************************************************
  7111. !*****************************************************************************************
  7112. !>
  7113. ! Alternate version of [[json_get_real32_vec_by_path]], where "path" is kind=CDK
  7114. subroutine wrap_json_get_real32_vec_by_path(json, me, path, vec, found, default)
  7115. implicit none
  7116. class(json_core),intent(inout) :: json
  7117. type(json_value),pointer :: me
  7118. character(kind=CDK,len=*),intent(in) :: path
  7119. real(real32),dimension(:),allocatable,intent(out) :: vec
  7120. logical(LK),intent(out),optional :: found
  7121. real(real32),dimension(:),intent(in),optional :: default !! default value if not found
  7122. call json%get(me, to_unicode(path), vec, found, default)
  7123. end subroutine wrap_json_get_real32_vec_by_path
  7124. !*****************************************************************************************
  7125. # 8855
  7126. !*****************************************************************************************
  7127. !>
  7128. ! Get a logical value from a [[json_value]].
  7129. !
  7130. !### Note
  7131. ! If `strict_type_checking` is False, then the following assumptions are made:
  7132. !
  7133. ! * For integers: a value > 0 is True
  7134. ! * For reals: a value > 0 is True
  7135. ! * For strings: 'true' is True, and everything else is false. [case sensitive match]
  7136. subroutine json_get_logical(json, me, value)
  7137. implicit none
  7138. class(json_core),intent(inout) :: json
  7139. type(json_value),pointer,intent(in) :: me
  7140. logical(LK),intent(out) :: value
  7141. value = .false.
  7142. if ( json%exception_thrown ) return
  7143. if (me%var_type == json_logical) then
  7144. value = me%log_value
  7145. else
  7146. if (json%strict_type_checking) then
  7147. if (allocated(me%name)) then
  7148. call json%throw_exception('Error in json_get_logical: '//&
  7149. 'Unable to resolve value to logical: '//&
  7150. me%name)
  7151. else
  7152. call json%throw_exception('Error in json_get_logical: '//&
  7153. 'Unable to resolve value to logical')
  7154. end if
  7155. else
  7156. !type conversions
  7157. select case (me%var_type)
  7158. case (json_integer)
  7159. value = (me%int_value > 0_IK)
  7160. case (json_real)
  7161. value = (me%dbl_value > 0.0_RK)
  7162. case (json_string)
  7163. value = (me%str_value == true_str)
  7164. case default
  7165. if (allocated(me%name)) then
  7166. call json%throw_exception('Error in json_get_logical: '//&
  7167. 'Unable to resolve value to logical: '//&
  7168. me%name)
  7169. else
  7170. call json%throw_exception('Error in json_get_logical: '//&
  7171. 'Unable to resolve value to logical')
  7172. end if
  7173. end select
  7174. end if
  7175. end if
  7176. end subroutine json_get_logical
  7177. !*****************************************************************************************
  7178. !*****************************************************************************************
  7179. !>
  7180. ! Get a logical value from a [[json_value]], given the path.
  7181. subroutine json_get_logical_by_path(json, me, path, value, found, default)
  7182. implicit none
  7183. class(json_core),intent(inout) :: json
  7184. type(json_value),pointer,intent(in) :: me
  7185. character(kind=CK,len=*),intent(in) :: path
  7186. logical(LK),intent(out) :: value
  7187. logical(LK),intent(out),optional :: found
  7188. logical(LK),intent(in),optional :: default !! default value if not found
  7189. logical(LK),parameter :: default_if_not_specified = .false.
  7190. character(kind=CK,len=*),parameter :: routine = CK_'json_get_logical_by_path'
  7191. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_scalar_by_path.inc" 1
  7192. type(json_value),pointer :: p
  7193. if (present(default)) then
  7194. value = default
  7195. else
  7196. value = default_if_not_specified
  7197. end if
  7198. if ( json%exception_thrown ) then
  7199. call flag_not_found(found)
  7200. return
  7201. end if
  7202. nullify(p)
  7203. call json%get(me=me, path=path, p=p)
  7204. if (.not. associated(p)) then
  7205. call json%throw_exception('Error in '//routine//':'//&
  7206. ' Unable to resolve path: '// trim(path),found)
  7207. else
  7208. call json%get(p,value)
  7209. end if
  7210. if ( json%exception_thrown ) then
  7211. if ( present(found) .or. present(default)) then
  7212. call flag_not_found(found)
  7213. if (present(default)) value = default
  7214. call json%clear_exceptions()
  7215. end if
  7216. else
  7217. if ( present(found) ) found = .true.
  7218. end if
  7219. # 8935 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  7220. end subroutine json_get_logical_by_path
  7221. !*****************************************************************************************
  7222. !*****************************************************************************************
  7223. !>
  7224. ! Alternate version of [[json_get_logical_by_path]], where "path" is kind=CDK
  7225. subroutine wrap_json_get_logical_by_path(json, me, path, value, found, default)
  7226. implicit none
  7227. class(json_core),intent(inout) :: json
  7228. type(json_value),pointer,intent(in) :: me
  7229. character(kind=CDK,len=*),intent(in) :: path
  7230. logical(LK),intent(out) :: value
  7231. logical(LK),intent(out),optional :: found
  7232. logical(LK),intent(in),optional :: default !! default value if not found
  7233. call json%get(me,to_unicode(path),value,found,default)
  7234. end subroutine wrap_json_get_logical_by_path
  7235. !*****************************************************************************************
  7236. !*****************************************************************************************
  7237. !> author: Jacob Williams
  7238. ! date: 5/14/2014
  7239. !
  7240. ! Get a logical vector from [[json_value]].
  7241. subroutine json_get_logical_vec(json, me, vec)
  7242. implicit none
  7243. class(json_core),intent(inout) :: json
  7244. type(json_value),pointer,intent(in) :: me
  7245. logical(LK),dimension(:),allocatable,intent(out) :: vec
  7246. logical(LK) :: initialized
  7247. if ( json%exception_thrown ) return
  7248. ! check for 0-length arrays first:
  7249. select case (me%var_type)
  7250. case (json_array)
  7251. if (json%count(me)==0) then
  7252. allocate(vec(0))
  7253. return
  7254. end if
  7255. end select
  7256. initialized = .false.
  7257. !the callback function is called for each element of the array:
  7258. call json%get(me, array_callback=get_logical_from_array)
  7259. if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
  7260. contains
  7261. subroutine get_logical_from_array(json, element, i, count)
  7262. !! callback function for logical
  7263. implicit none
  7264. class(json_core),intent(inout) :: json
  7265. type(json_value),pointer,intent(in) :: element
  7266. integer(IK),intent(in) :: i !! index
  7267. integer(IK),intent(in) :: count !! size of array
  7268. !size the output array:
  7269. if (.not. initialized) then
  7270. allocate(vec(count))
  7271. initialized = .true.
  7272. end if
  7273. !populate the elements:
  7274. call json%get(element, value=vec(i))
  7275. end subroutine get_logical_from_array
  7276. end subroutine json_get_logical_vec
  7277. !*****************************************************************************************
  7278. !*****************************************************************************************
  7279. !>
  7280. ! Get a logical vector from a [[json_value]], given the path.
  7281. subroutine json_get_logical_vec_by_path(json, me, path, vec, found, default)
  7282. implicit none
  7283. class(json_core),intent(inout) :: json
  7284. type(json_value),pointer,intent(in) :: me
  7285. character(kind=CK,len=*),intent(in) :: path
  7286. logical(LK),dimension(:),allocatable,intent(out) :: vec
  7287. logical(LK),intent(out),optional :: found
  7288. logical(LK),dimension(:),intent(in),optional :: default
  7289. character(kind=CK,len=*),parameter :: routine = CK_'json_get_logical_vec_by_path'
  7290. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_vec_by_path.inc" 1
  7291. type(json_value),pointer :: p
  7292. if ( json%exception_thrown ) then
  7293. if (present(default)) vec = default
  7294. call flag_not_found(found)
  7295. return
  7296. end if
  7297. nullify(p)
  7298. call json%get(me=me, path=path, p=p)
  7299. if (.not. associated(p)) then
  7300. call json%throw_exception('Error in '//routine//':'//&
  7301. ' Unable to resolve path: '// trim(path),found)
  7302. else
  7303. call json%get(p,vec)
  7304. end if
  7305. if ( json%exception_thrown ) then
  7306. if ( present(found) .or. present(default)) then
  7307. call flag_not_found(found)
  7308. if (present(default)) vec = default
  7309. call json%clear_exceptions()
  7310. end if
  7311. else
  7312. if ( present(found) ) found = .true.
  7313. end if
  7314. # 9038 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  7315. end subroutine json_get_logical_vec_by_path
  7316. !*****************************************************************************************
  7317. !*****************************************************************************************
  7318. !>
  7319. ! Alternate version of [[json_get_logical_vec_by_path]], where "path" is kind=CDK
  7320. subroutine wrap_json_get_logical_vec_by_path(json, me, path, vec, found, default)
  7321. implicit none
  7322. class(json_core),intent(inout) :: json
  7323. type(json_value),pointer,intent(in) :: me
  7324. character(kind=CDK,len=*),intent(in) :: path
  7325. logical(LK),dimension(:),allocatable,intent(out) :: vec
  7326. logical(LK),intent(out),optional :: found
  7327. logical(LK),dimension(:),intent(in),optional :: default
  7328. call json%get(me,to_unicode(path),vec,found,default)
  7329. end subroutine wrap_json_get_logical_vec_by_path
  7330. !*****************************************************************************************
  7331. !*****************************************************************************************
  7332. !>
  7333. ! Get a character string from a [[json_value]].
  7334. subroutine json_get_string(json, me, value)
  7335. implicit none
  7336. class(json_core),intent(inout) :: json
  7337. type(json_value),pointer,intent(in) :: me
  7338. character(kind=CK,len=:),allocatable,intent(out) :: value
  7339. value = CK_''
  7340. if (.not. json%exception_thrown) then
  7341. if (me%var_type == json_string) then
  7342. if (allocated(me%str_value)) then
  7343. if (json%unescaped_strings) then
  7344. ! default: it is stored already unescaped:
  7345. value = me%str_value
  7346. else
  7347. ! return the escaped version:
  7348. call escape_string(me%str_value, value, json%escape_solidus)
  7349. end if
  7350. else
  7351. call json%throw_exception('Error in json_get_string: '//&
  7352. 'me%str_value not allocated')
  7353. end if
  7354. else
  7355. if (json%strict_type_checking) then
  7356. if (allocated(me%name)) then
  7357. call json%throw_exception('Error in json_get_string:'//&
  7358. ' Unable to resolve value to string: '//me%name)
  7359. else
  7360. call json%throw_exception('Error in json_get_string:'//&
  7361. ' Unable to resolve value to string')
  7362. end if
  7363. else
  7364. select case (me%var_type)
  7365. case (json_integer)
  7366. if (allocated(me%int_value)) then
  7367. value = repeat(space, max_integer_str_len)
  7368. call integer_to_string(me%int_value,int_fmt,value)
  7369. value = trim(value)
  7370. else
  7371. call json%throw_exception('Error in json_get_string: '//&
  7372. 'me%int_value not allocated')
  7373. end if
  7374. case (json_real)
  7375. if (allocated(me%dbl_value)) then
  7376. value = repeat(space, max_numeric_str_len)
  7377. call real_to_string(me%dbl_value,json%real_fmt,&
  7378. json%non_normals_to_null,&
  7379. json%compact_real,value)
  7380. value = trim(value)
  7381. else
  7382. call json%throw_exception('Error in json_get_string: '//&
  7383. 'me%int_value not allocated')
  7384. end if
  7385. case (json_logical)
  7386. if (allocated(me%log_value)) then
  7387. if (me%log_value) then
  7388. value = true_str
  7389. else
  7390. value = false_str
  7391. end if
  7392. else
  7393. call json%throw_exception('Error in json_get_string: '//&
  7394. 'me%log_value not allocated')
  7395. end if
  7396. case (json_null)
  7397. value = null_str
  7398. case default
  7399. if (allocated(me%name)) then
  7400. call json%throw_exception('Error in json_get_string: '//&
  7401. 'Unable to resolve value to characters: '//&
  7402. me%name)
  7403. else
  7404. call json%throw_exception('Error in json_get_string: '//&
  7405. 'Unable to resolve value to characters')
  7406. end if
  7407. end select
  7408. end if
  7409. end if
  7410. end if
  7411. end subroutine json_get_string
  7412. !*****************************************************************************************
  7413. !*****************************************************************************************
  7414. !>
  7415. ! Get a character string from a [[json_value]], given the path.
  7416. subroutine json_get_string_by_path(json, me, path, value, found, default)
  7417. implicit none
  7418. class(json_core),intent(inout) :: json
  7419. type(json_value),pointer,intent(in) :: me
  7420. character(kind=CK,len=*),intent(in) :: path
  7421. character(kind=CK,len=:),allocatable,intent(out) :: value
  7422. logical(LK),intent(out),optional :: found
  7423. character(kind=CK,len=*),intent(in),optional :: default
  7424. character(kind=CK,len=*),parameter :: default_if_not_specified = CK_''
  7425. character(kind=CK,len=*),parameter :: routine = CK_'json_get_string_by_path'
  7426. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_scalar_by_path.inc" 1
  7427. type(json_value),pointer :: p
  7428. if (present(default)) then
  7429. value = default
  7430. else
  7431. value = default_if_not_specified
  7432. end if
  7433. if ( json%exception_thrown ) then
  7434. call flag_not_found(found)
  7435. return
  7436. end if
  7437. nullify(p)
  7438. call json%get(me=me, path=path, p=p)
  7439. if (.not. associated(p)) then
  7440. call json%throw_exception('Error in '//routine//':'//&
  7441. ' Unable to resolve path: '// trim(path),found)
  7442. else
  7443. call json%get(p,value)
  7444. end if
  7445. if ( json%exception_thrown ) then
  7446. if ( present(found) .or. present(default)) then
  7447. call flag_not_found(found)
  7448. if (present(default)) value = default
  7449. call json%clear_exceptions()
  7450. end if
  7451. else
  7452. if ( present(found) ) found = .true.
  7453. end if
  7454. # 9185 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  7455. end subroutine json_get_string_by_path
  7456. !*****************************************************************************************
  7457. !*****************************************************************************************
  7458. !>
  7459. ! Alternate version of [[json_get_string_by_path]], where "path" is kind=CDK
  7460. subroutine wrap_json_get_string_by_path(json, me, path, value, found, default)
  7461. implicit none
  7462. class(json_core),intent(inout) :: json
  7463. type(json_value),pointer,intent(in) :: me
  7464. character(kind=CDK,len=*),intent(in) :: path
  7465. character(kind=CK,len=:),allocatable,intent(out) :: value
  7466. logical(LK),intent(out),optional :: found
  7467. character(kind=CK,len=*),intent(in),optional :: default
  7468. call json%get(me,to_unicode(path),value,found,default)
  7469. end subroutine wrap_json_get_string_by_path
  7470. !*****************************************************************************************
  7471. !*****************************************************************************************
  7472. !> author: Jacob Williams
  7473. ! date: 5/14/2014
  7474. !
  7475. ! Get a string vector from a [[json_value(type)]].
  7476. subroutine json_get_string_vec(json, me, vec)
  7477. implicit none
  7478. class(json_core),intent(inout) :: json
  7479. type(json_value),pointer,intent(in) :: me
  7480. character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
  7481. logical(LK) :: initialized
  7482. if ( json%exception_thrown ) return
  7483. ! check for 0-length arrays first:
  7484. select case (me%var_type)
  7485. case (json_array)
  7486. if (json%count(me)==0) then
  7487. allocate(vec(0))
  7488. return
  7489. end if
  7490. end select
  7491. initialized = .false.
  7492. !the callback function is called for each element of the array:
  7493. call json%get(me, array_callback=get_chars_from_array)
  7494. if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
  7495. contains
  7496. subroutine get_chars_from_array(json, element, i, count)
  7497. !! callback function for chars
  7498. implicit none
  7499. class(json_core),intent(inout) :: json
  7500. type(json_value),pointer,intent(in) :: element
  7501. integer(IK),intent(in) :: i !! index
  7502. integer(IK),intent(in) :: count !! size of array
  7503. character(kind=CK,len=:),allocatable :: cval
  7504. !size the output array:
  7505. if (.not. initialized) then
  7506. allocate(vec(count))
  7507. initialized = .true.
  7508. end if
  7509. !populate the elements:
  7510. call json%get(element, value=cval)
  7511. if (allocated(cval)) then
  7512. vec(i) = cval
  7513. deallocate(cval)
  7514. else
  7515. vec(i) = CK_''
  7516. end if
  7517. end subroutine get_chars_from_array
  7518. end subroutine json_get_string_vec
  7519. !*****************************************************************************************
  7520. !*****************************************************************************************
  7521. !>
  7522. ! Get a string vector from a [[json_value(type)]], given the path.
  7523. subroutine json_get_string_vec_by_path(json, me, path, vec, found, default)
  7524. implicit none
  7525. class(json_core),intent(inout) :: json
  7526. type(json_value),pointer,intent(in) :: me
  7527. character(kind=CK,len=*),intent(in) :: path
  7528. character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
  7529. logical(LK),intent(out),optional :: found
  7530. character(kind=CK,len=*),dimension(:),intent(in),optional :: default
  7531. character(kind=CK,len=*),parameter :: routine = CK_'json_get_string_vec_by_path'
  7532. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_vec_by_path.inc" 1
  7533. type(json_value),pointer :: p
  7534. if ( json%exception_thrown ) then
  7535. if (present(default)) vec = default
  7536. call flag_not_found(found)
  7537. return
  7538. end if
  7539. nullify(p)
  7540. call json%get(me=me, path=path, p=p)
  7541. if (.not. associated(p)) then
  7542. call json%throw_exception('Error in '//routine//':'//&
  7543. ' Unable to resolve path: '// trim(path),found)
  7544. else
  7545. call json%get(p,vec)
  7546. end if
  7547. if ( json%exception_thrown ) then
  7548. if ( present(found) .or. present(default)) then
  7549. call flag_not_found(found)
  7550. if (present(default)) vec = default
  7551. call json%clear_exceptions()
  7552. end if
  7553. else
  7554. if ( present(found) ) found = .true.
  7555. end if
  7556. # 9296 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  7557. end subroutine json_get_string_vec_by_path
  7558. !*****************************************************************************************
  7559. !*****************************************************************************************
  7560. !>
  7561. ! Alternate version of [[json_get_string_vec_by_path]], where "path" is kind=CDK
  7562. subroutine wrap_json_get_string_vec_by_path(json, me, path, vec, found, default)
  7563. implicit none
  7564. class(json_core),intent(inout) :: json
  7565. type(json_value),pointer,intent(in) :: me
  7566. character(kind=CDK,len=*),intent(in) :: path
  7567. character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
  7568. logical(LK),intent(out),optional :: found
  7569. character(kind=CK,len=*),dimension(:),intent(in),optional :: default
  7570. call json%get(me,to_unicode(path),vec,found,default)
  7571. end subroutine wrap_json_get_string_vec_by_path
  7572. !*****************************************************************************************
  7573. !*****************************************************************************************
  7574. !> author: Jacob Williams
  7575. ! date: 12/16/2016
  7576. !
  7577. ! Get a string vector from a [[json_value(type)]]. This is an alternate
  7578. ! version of [[json_get_string_vec]]. This one returns an allocatable
  7579. ! length character (where the string length is the maximum length of
  7580. ! any element in the array). It also returns an integer array of the
  7581. ! actual sizes of the strings in the JSON structure.
  7582. !
  7583. !@note This is somewhat inefficient since it does
  7584. ! cycle through the array twice.
  7585. !
  7586. !@warning The allocation of `vec` doesn't work with
  7587. ! gfortran 4.9 or 5 due to compiler bugs
  7588. subroutine json_get_alloc_string_vec(json, me, vec, ilen)
  7589. implicit none
  7590. class(json_core),intent(inout) :: json
  7591. type(json_value),pointer,intent(in) :: me
  7592. character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
  7593. integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
  7594. !! of each character
  7595. !! string in the array
  7596. logical(LK) :: initialized !! if the output array has been sized
  7597. integer(IK) :: max_len !! the length of the longest string in the array
  7598. if ( json%exception_thrown ) return
  7599. ! check for 0-length arrays first:
  7600. select case (me%var_type)
  7601. case (json_array)
  7602. if (json%count(me)==0) then
  7603. allocate(character(kind=CK,len=0) :: vec(0))
  7604. allocate(ilen(0))
  7605. return
  7606. end if
  7607. end select
  7608. initialized = .false.
  7609. call json%string_info(me,ilen=ilen,max_str_len=max_len)
  7610. if (.not. json%exception_thrown) then
  7611. ! now get each string using the callback function:
  7612. call json%get(me, array_callback=get_chars_from_array)
  7613. end if
  7614. if (json%exception_thrown) then
  7615. if (allocated(vec)) deallocate(vec)
  7616. if (allocated(ilen)) deallocate(ilen)
  7617. end if
  7618. contains
  7619. subroutine get_chars_from_array(json, element, i, count)
  7620. !! callback function for chars
  7621. implicit none
  7622. class(json_core),intent(inout) :: json
  7623. type(json_value),pointer,intent(in) :: element
  7624. integer(IK),intent(in) :: i !! index
  7625. integer(IK),intent(in) :: count !! size of array
  7626. character(kind=CK,len=:),allocatable :: cval !! for getting string
  7627. !size the output array:
  7628. if (.not. initialized) then
  7629. ! string length long enough to hold the longest one
  7630. ! Note that this doesn't work with gfortran 4.9 or 5.
  7631. allocate( character(kind=CK,len=max_len) :: vec(count) )
  7632. initialized = .true.
  7633. end if
  7634. !populate the elements:
  7635. call json%get(element, value=cval)
  7636. if (allocated(cval)) then
  7637. vec(i) = cval
  7638. ilen(i) = len(cval) ! return the actual length
  7639. deallocate(cval)
  7640. else
  7641. vec(i) = CK_''
  7642. ilen(i) = 0
  7643. end if
  7644. end subroutine get_chars_from_array
  7645. end subroutine json_get_alloc_string_vec
  7646. !*****************************************************************************************
  7647. !*****************************************************************************************
  7648. !>
  7649. ! Alternate version of [[json_get_alloc_string_vec]] where input is the path.
  7650. !
  7651. ! This is an alternate version of [[json_get_string_vec_by_path]].
  7652. ! This one returns an allocatable length character (where the string
  7653. ! length is the maximum length of any element in the array). It also
  7654. ! returns an integer array of the actual sizes of the strings in the
  7655. ! JSON structure.
  7656. !
  7657. !@note An alternative to using this routine is to use [[json_get_array]] with
  7658. ! a callback function that gets the string from each element and populates
  7659. ! a user-defined string type.
  7660. !
  7661. !@note If the `default` argument is used, and `default_ilen` is not present,
  7662. ! then `ilen` will just be returned as the length of the `default` dummy
  7663. ! argument (all elements with the same length).
  7664. subroutine json_get_alloc_string_vec_by_path(json,me,path,vec,ilen,found,default,default_ilen)
  7665. implicit none
  7666. class(json_core),intent(inout) :: json
  7667. type(json_value),pointer,intent(in) :: me
  7668. character(kind=CK,len=*),intent(in) :: path
  7669. character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
  7670. integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
  7671. !! of each character
  7672. !! string in the array
  7673. logical(LK),intent(out),optional :: found
  7674. character(kind=CK,len=*),dimension(:),intent(in),optional :: default
  7675. integer(IK),dimension(:),intent(in),optional :: default_ilen !! the actual
  7676. !! length of `default`
  7677. character(kind=CK,len=*),parameter :: routine = CK_'json_get_alloc_string_vec_by_path'
  7678. # 1 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_get_vec_by_path_alloc.inc" 1
  7679. type(json_value),pointer :: p
  7680. if ( json%exception_thrown ) then
  7681. if (present(default)) then
  7682. vec = default
  7683. if (present(default_ilen)) then
  7684. ilen = default_ilen
  7685. else
  7686. allocate(ilen(size(default)))
  7687. ilen = len(default)
  7688. end if
  7689. end if
  7690. call flag_not_found(found)
  7691. return
  7692. end if
  7693. nullify(p)
  7694. call json%get(me=me, path=path, p=p)
  7695. if (.not. associated(p)) then
  7696. call json%throw_exception('Error in '//routine//':'//&
  7697. ' Unable to resolve path: '// trim(path),found)
  7698. else
  7699. call json%get(p,vec,ilen)
  7700. end if
  7701. if ( json%exception_thrown ) then
  7702. if ( present(found) .or. present(default)) then
  7703. call flag_not_found(found)
  7704. if (present(default)) then
  7705. vec = default
  7706. if (present(default_ilen)) then
  7707. ilen = default_ilen
  7708. else
  7709. allocate(ilen(size(default)))
  7710. ilen = len(default)
  7711. end if
  7712. end if
  7713. call json%clear_exceptions()
  7714. end if
  7715. else
  7716. if ( present(found) ) found = .true.
  7717. end if
  7718. # 9451 "/mnt/c/Projects/VSIM/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
  7719. end subroutine json_get_alloc_string_vec_by_path
  7720. !*****************************************************************************************
  7721. !*****************************************************************************************
  7722. !>
  7723. ! Alternate version of [[json_get_alloc_string_vec_by_path]], where "path" is kind=CDK
  7724. subroutine wrap_json_get_alloc_string_vec_by_path(json,me,path,vec,ilen,found,default,default_ilen)
  7725. implicit none
  7726. class(json_core),intent(inout) :: json
  7727. type(json_value),pointer,intent(in) :: me
  7728. character(kind=CDK,len=*),intent(in) :: path
  7729. character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
  7730. integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
  7731. !! of each character
  7732. !! string in the array
  7733. logical(LK),intent(out),optional :: found
  7734. character(kind=CK,len=*),dimension(:),intent(in),optional :: default
  7735. integer(IK),dimension(:),intent(in),optional :: default_ilen !! the actual
  7736. !! length of `default`
  7737. call json%get(me,to_unicode(path),vec,ilen,found,default,default_ilen)
  7738. end subroutine wrap_json_get_alloc_string_vec_by_path
  7739. !*****************************************************************************************
  7740. !*****************************************************************************************
  7741. !>
  7742. ! This routine calls the user-supplied [[json_array_callback_func]]
  7743. ! subroutine for each element in the array.
  7744. !
  7745. !@note For integer, real, logical, and character arrays,
  7746. ! higher-level routines are provided (see `get` methods), so
  7747. ! this routine does not have to be used for those cases.
  7748. recursive subroutine json_get_array(json, me, array_callback)
  7749. implicit none
  7750. class(json_core),intent(inout) :: json
  7751. type(json_value),pointer,intent(in) :: me
  7752. procedure(json_array_callback_func) :: array_callback
  7753. type(json_value),pointer :: element !! temp variable for getting elements
  7754. integer(IK) :: i !! counter
  7755. integer(IK) :: count !! number of elements in the array
  7756. if ( json%exception_thrown ) return
  7757. select case (me%var_type)
  7758. case (json_array)
  7759. count = json%count(me)
  7760. element => me%children
  7761. do i = 1, count ! callback for each child
  7762. if (.not. associated(element)) then
  7763. call json%throw_exception('Error in json_get_array: '//&
  7764. 'Malformed JSON linked list')
  7765. return
  7766. end if
  7767. call array_callback(json, element, i, count)
  7768. if (json%exception_thrown) exit
  7769. element => element%next
  7770. end do
  7771. case default
  7772. call json%throw_exception('Error in json_get_array:'//&
  7773. ' Resolved value is not an array ')
  7774. end select
  7775. end subroutine json_get_array
  7776. !*****************************************************************************************
  7777. !*****************************************************************************************
  7778. !> author: Jacob Williams
  7779. ! date: 4/28/2016
  7780. !
  7781. ! Traverse a JSON structure.
  7782. ! This routine calls the user-specified [[json_traverse_callback_func]]
  7783. ! for each element of the structure.
  7784. subroutine json_traverse(json,p,traverse_callback)
  7785. implicit none
  7786. class(json_core),intent(inout) :: json
  7787. type(json_value),pointer,intent(in) :: p
  7788. procedure(json_traverse_callback_func) :: traverse_callback
  7789. logical(LK) :: finished !! can be used to stop the process
  7790. if (.not. json%exception_thrown) call traverse(p)
  7791. contains
  7792. recursive subroutine traverse(p)
  7793. !! recursive [[json_value]] traversal.
  7794. implicit none
  7795. type(json_value),pointer,intent(in) :: p
  7796. type(json_value),pointer :: element !! a child element
  7797. integer(IK) :: i !! counter
  7798. integer(IK) :: icount !! number of children
  7799. if (json%exception_thrown) return
  7800. call traverse_callback(json,p,finished) ! first call for this object
  7801. if (finished) return
  7802. !for arrays and objects, have to also call for all children:
  7803. if (p%var_type==json_array .or. p%var_type==json_object) then
  7804. icount = json%count(p) ! number of children
  7805. if (icount>0) then
  7806. element => p%children ! first one
  7807. do i = 1, icount ! call for each child
  7808. if (.not. associated(element)) then
  7809. call json%throw_exception('Error in json_traverse: '//&
  7810. 'Malformed JSON linked list')
  7811. return
  7812. end if
  7813. call traverse(element)
  7814. if (finished .or. json%exception_thrown) exit
  7815. element => element%next
  7816. end do
  7817. end if
  7818. nullify(element)
  7819. end if
  7820. end subroutine traverse
  7821. end subroutine json_traverse
  7822. !*****************************************************************************************
  7823. !*****************************************************************************************
  7824. !>
  7825. ! This routine calls the user-supplied array_callback subroutine
  7826. ! for each element in the array (specified by the path).
  7827. recursive subroutine json_get_array_by_path(json, me, path, array_callback, found)
  7828. implicit none
  7829. class(json_core),intent(inout) :: json
  7830. type(json_value),pointer,intent(in) :: me
  7831. character(kind=CK,len=*),intent(in) :: path
  7832. procedure(json_array_callback_func) :: array_callback
  7833. logical(LK),intent(out),optional :: found
  7834. type(json_value),pointer :: p
  7835. if ( json%exception_thrown ) then
  7836. if ( present(found) ) found = .false.
  7837. return
  7838. end if
  7839. nullify(p)
  7840. ! resolve the path to the value
  7841. call json%get(me=me, path=path, p=p)
  7842. if (.not. associated(p)) then
  7843. call json%throw_exception('Error in json_get_array:'//&
  7844. ' Unable to resolve path: '//trim(path),found)
  7845. else
  7846. call json%get(me=p,array_callback=array_callback)
  7847. nullify(p)
  7848. end if
  7849. if ( json%exception_thrown ) then
  7850. if ( present(found) ) then
  7851. found = .false.
  7852. call json%clear_exceptions()
  7853. end if
  7854. else
  7855. if ( present(found) ) found = .true.
  7856. end if
  7857. end subroutine json_get_array_by_path
  7858. !*****************************************************************************************
  7859. !*****************************************************************************************
  7860. !>
  7861. ! Alternate version of [[json_get_array_by_path]], where "path" is kind=CDK
  7862. recursive subroutine wrap_json_get_array_by_path(json, me, path, array_callback, found)
  7863. implicit none
  7864. class(json_core),intent(inout) :: json
  7865. type(json_value),pointer,intent(in) :: me
  7866. character(kind=CDK,len=*),intent(in) :: path
  7867. procedure(json_array_callback_func) :: array_callback
  7868. logical(LK),intent(out),optional :: found
  7869. call json%get(me, to_unicode(path), array_callback, found)
  7870. end subroutine wrap_json_get_array_by_path
  7871. !*****************************************************************************************
  7872. !*****************************************************************************************
  7873. !>
  7874. ! Internal routine to be called before parsing JSON.
  7875. ! Currently, all this does it allocate the `comment_char` if none was specified.
  7876. subroutine json_prepare_parser(json)
  7877. implicit none
  7878. class(json_core),intent(inout) :: json
  7879. if (json%allow_comments .and. .not. allocated(json%comment_char)) then
  7880. ! comments are enabled, but user hasn't set the comment char,
  7881. ! so in this case use the default:
  7882. json%comment_char = CK_'/!#'
  7883. end if
  7884. end subroutine json_prepare_parser
  7885. !*****************************************************************************************
  7886. !*****************************************************************************************
  7887. !>
  7888. ! Parse the JSON file and populate the [[json_value]] tree.
  7889. !
  7890. !### Inputs
  7891. !
  7892. ! The inputs can be:
  7893. !
  7894. ! * `file` & `unit` : the specified unit is used to read JSON from file.
  7895. ! [note if unit is already open, then the filename is ignored]
  7896. ! * `file` : JSON is read from file using internal unit number
  7897. !
  7898. !### Example
  7899. !
  7900. !````fortran
  7901. ! type(json_core) :: json
  7902. ! type(json_value),pointer :: p
  7903. ! call json%load(file='myfile.json', p=p)
  7904. !````
  7905. !
  7906. !### History
  7907. ! * Jacob Williams : 01/13/2015 : added read from string option.
  7908. ! * Izaak Beekman : 03/08/2015 : moved read from string to separate
  7909. ! subroutine, and error annotation to separate subroutine.
  7910. !
  7911. !@note When calling this routine, any exceptions thrown from previous
  7912. ! calls will automatically be cleared.
  7913. subroutine json_parse_file(json, file, p, unit)
  7914. implicit none
  7915. class(json_core),intent(inout) :: json
  7916. character(kind=CDK,len=*),intent(in) :: file !! JSON file name
  7917. type(json_value),pointer :: p !! output structure
  7918. integer(IK),intent(in),optional :: unit !! file unit number (/= 0)
  7919. integer(IK) :: iunit !! file unit actually used
  7920. integer(IK) :: istat !! iostat flag
  7921. logical(LK) :: is_open !! if the file is already open
  7922. logical(LK) :: has_duplicate !! if checking for duplicate keys
  7923. character(kind=CK,len=:),allocatable :: path !! path to any duplicate key
  7924. ! clear any exceptions and initialize:
  7925. call json%initialize()
  7926. call json%prepare_parser()
  7927. if ( present(unit) ) then
  7928. if (unit==0) then
  7929. call json%throw_exception('Error in json_parse_file: unit number must not be 0.')
  7930. return
  7931. end if
  7932. iunit = unit
  7933. ! check to see if the file is already open
  7934. ! if it is, then use it, otherwise open the file with the name given.
  7935. inquire(unit=iunit, opened=is_open, iostat=istat)
  7936. if (istat==0 .and. .not. is_open) then
  7937. ! open the file
  7938. open ( unit = iunit, &
  7939. file = file, &
  7940. status = 'OLD', &
  7941. action = 'READ', &
  7942. form = form_spec, &
  7943. access = access_spec, &
  7944. iostat = istat &
  7945. )
  7946. else
  7947. ! if the file is already open, then we need to make sure
  7948. ! that it is open with the correct form/access/etc...
  7949. end if
  7950. else
  7951. ! open the file with a new unit number:
  7952. open ( newunit = iunit, &
  7953. file = file, &
  7954. status = 'OLD', &
  7955. action = 'READ', &
  7956. form = form_spec, &
  7957. access = access_spec, &
  7958. iostat = istat &
  7959. )
  7960. end if
  7961. if (istat==0) then
  7962. if (use_unformatted_stream) then
  7963. ! save the file size to be read:
  7964. inquire(unit=iunit, size=json%filesize, iostat=istat)
  7965. end if
  7966. ! create the value and associate the pointer
  7967. call json_value_create(p)
  7968. ! Note: the name of the root json_value doesn't really matter,
  7969. ! but we'll allocate something here just in case.
  7970. p%name = trim(file) !use the file name
  7971. ! parse as a value
  7972. call json%parse_value(unit=iunit, str=CK_'', value=p)
  7973. call json%parse_end(unit=iunit, str=CK_'')
  7974. ! check for errors:
  7975. if (json%exception_thrown) then
  7976. call json%annotate_invalid_json(iunit,CK_'')
  7977. else
  7978. if (.not. json%allow_duplicate_keys) then
  7979. call json%check_for_duplicate_keys(p,has_duplicate,path=path)
  7980. if (.not. json%exception_thrown) then
  7981. if (has_duplicate) then
  7982. call json%throw_exception('Error in json_parse_file: '//&
  7983. 'Duplicate key found: '//path)
  7984. end if
  7985. end if
  7986. end if
  7987. end if
  7988. ! close the file:
  7989. close(unit=iunit, iostat=istat)
  7990. else
  7991. call json%throw_exception('Error in json_parse_file: Error opening file: '//trim(file))
  7992. nullify(p)
  7993. end if
  7994. end subroutine json_parse_file
  7995. !*****************************************************************************************
  7996. !*****************************************************************************************
  7997. !>
  7998. ! Parse the JSON string and populate the [[json_value]] tree.
  7999. !
  8000. !### See also
  8001. ! * [[json_parse_file]]
  8002. subroutine json_parse_string(json, p, str)
  8003. implicit none
  8004. class(json_core),intent(inout) :: json
  8005. type(json_value),pointer :: p !! output structure
  8006. character(kind=CK,len=*),intent(in) :: str !! string with JSON data
  8007. integer(IK),parameter :: iunit = 0 !! indicates that json data will be read from buffer
  8008. logical(LK) :: has_duplicate !! if checking for duplicate keys
  8009. character(kind=CK,len=:),allocatable :: path !! path to any duplicate key
  8010. ! clear any exceptions and initialize:
  8011. call json%initialize()
  8012. call json%prepare_parser()
  8013. ! create the value and associate the pointer
  8014. call json_value_create(p)
  8015. ! Note: the name of the root json_value doesn't really matter,
  8016. ! but we'll allocate something here just in case.
  8017. p%name = CK_''
  8018. ! parse as a value
  8019. call json%parse_value(unit=iunit, str=str, value=p)
  8020. call json%parse_end(unit=iunit, str=str)
  8021. if (json%exception_thrown) then
  8022. call json%annotate_invalid_json(iunit,str)
  8023. else
  8024. if (.not. json%allow_duplicate_keys) then
  8025. call json%check_for_duplicate_keys(p,has_duplicate,path=path)
  8026. if (.not. json%exception_thrown) then
  8027. if (has_duplicate) then
  8028. call json%throw_exception('Error in json_parse_string: '//&
  8029. 'Duplicate key found: '//path)
  8030. end if
  8031. end if
  8032. end if
  8033. end if
  8034. end subroutine json_parse_string
  8035. !*****************************************************************************************
  8036. !*****************************************************************************************
  8037. !>
  8038. ! An error checking routine to call after a file (or string) has been parsed.
  8039. ! It will throw an exception if there are any other non-whitespace characters
  8040. ! in the file.
  8041. subroutine json_parse_end(json, unit, str)
  8042. implicit none
  8043. class(json_core),intent(inout) :: json
  8044. integer(IK),intent(in) :: unit !! file unit number
  8045. character(kind=CK,len=*),intent(in) :: str !! string containing JSON
  8046. !! data (only used if `unit=0`)
  8047. logical(LK) :: eof !! end-of-file flag
  8048. character(kind=CK,len=1) :: c !! character read from file
  8049. !! (or string) by [[pop_char]]
  8050. ! first check for exceptions:
  8051. if (json%exception_thrown) return
  8052. ! pop the next non whitespace character off the file
  8053. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8054. skip_comments=json%allow_comments, popped=c)
  8055. if (.not. eof) then
  8056. call json%throw_exception('Error in json_parse_end:'//&
  8057. ' Unexpected character found after parsing value. "'//&
  8058. c//'"')
  8059. end if
  8060. end subroutine json_parse_end
  8061. !*****************************************************************************************
  8062. !*****************************************************************************************
  8063. !>
  8064. ! Alternate version of [[json_parse_string]], where `str` is kind=CDK.
  8065. subroutine wrap_json_parse_string(json, p, str)
  8066. implicit none
  8067. class(json_core),intent(inout) :: json
  8068. type(json_value),pointer :: p !! output structure
  8069. character(kind=CDK,len=*),intent(in) :: str !! string with JSON data
  8070. call json%deserialize(p,to_unicode(str))
  8071. end subroutine wrap_json_parse_string
  8072. !*****************************************************************************************
  8073. !*****************************************************************************************
  8074. !>
  8075. ! Generate a warning message if there was an error parsing a JSON
  8076. ! file or string.
  8077. subroutine annotate_invalid_json(json,iunit,str)
  8078. implicit none
  8079. class(json_core),intent(inout) :: json
  8080. integer(IK),intent(in) :: iunit !! file unit number
  8081. character(kind=CK,len=*),intent(in) :: str !! string with JSON data
  8082. character(kind=CK,len=:),allocatable :: line !! line containing the error
  8083. character(kind=CK,len=:),allocatable :: arrow_str !! arrow string that points
  8084. !! to the current character
  8085. character(kind=CK,len=max_integer_str_len) :: line_str !! current line number string
  8086. character(kind=CK,len=max_integer_str_len) :: char_str !! current character count string
  8087. integer(IK) :: i !! line number counter
  8088. integer(IK) :: i_nl_prev !! index of previous newline character
  8089. integer(IK) :: i_nl !! index of current newline character
  8090. ! If there was an error reading the file, then
  8091. ! print the line where the error occurred:
  8092. if (json%exception_thrown) then
  8093. !the counters for the current line and the last character read:
  8094. call integer_to_string(json%line_count, int_fmt, line_str)
  8095. call integer_to_string(json%char_count, int_fmt, char_str)
  8096. !draw the arrow string that points to the current character:
  8097. arrow_str = repeat('-',max( 0_IK, json%char_count - 1_IK) )//'^'
  8098. if (json%line_count>0 .and. json%char_count>0) then
  8099. if (iunit/=0) then
  8100. if (use_unformatted_stream) then
  8101. call json%get_current_line_from_file_stream(iunit,line)
  8102. else
  8103. call json%get_current_line_from_file_sequential(iunit,line)
  8104. end if
  8105. else
  8106. !get the current line from the string:
  8107. ! [this is done by counting the newline characters]
  8108. i_nl_prev = 0 !index of previous newline character
  8109. i_nl = 2 !just in case line_count = 0
  8110. do i=1,json%line_count
  8111. i_nl = index(str(i_nl_prev+1:),newline)
  8112. if (i_nl==0) then !last line - no newline character
  8113. i_nl = len(str)+1
  8114. exit
  8115. end if
  8116. i_nl = i_nl + i_nl_prev !index of current newline character
  8117. i_nl_prev = i_nl !update for next iteration
  8118. end do
  8119. line = str(i_nl_prev+1 : i_nl-1) !extract current line
  8120. end if
  8121. else
  8122. !in this case, it was an empty line or file
  8123. line = CK_''
  8124. end if
  8125. ! add a newline for the error display if necessary:
  8126. line = trim(line)
  8127. if (len(line)>0) then
  8128. i = len(line)
  8129. if (line(i:i)/=newline) line = line//newline
  8130. else
  8131. line = line//newline
  8132. end if
  8133. !create the error message:
  8134. if (allocated(json%err_message)) then
  8135. json%err_message = json%err_message//newline
  8136. else
  8137. json%err_message = ''
  8138. end if
  8139. json%err_message = json%err_message//&
  8140. 'line: '//trim(adjustl(line_str))//', '//&
  8141. 'character: '//trim(adjustl(char_str))//newline//&
  8142. line//arrow_str
  8143. if (allocated(line)) deallocate(line)
  8144. end if
  8145. end subroutine annotate_invalid_json
  8146. !*****************************************************************************************
  8147. !*****************************************************************************************
  8148. !> author: Jacob Williams
  8149. !
  8150. ! Rewind the file to the beginning of the current line, and return this line.
  8151. ! The file is assumed to be opened.
  8152. ! This is the SEQUENTIAL version (see also [[get_current_line_from_file_stream]]).
  8153. subroutine get_current_line_from_file_sequential(iunit,line)
  8154. implicit none
  8155. integer(IK),intent(in) :: iunit !! file unit number
  8156. character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
  8157. character(kind=CK,len=seq_chunk_size) :: chunk !! for reading line in chunks
  8158. integer(IK) :: istat !! iostat flag
  8159. integer(IK) :: isize !! number of characters read in read statement
  8160. !initialize:
  8161. line = CK_''
  8162. !rewind to beginning of the current record:
  8163. backspace(iunit, iostat=istat)
  8164. !loop to read in all the characters in the current record.
  8165. ![the line is read in chunks until the end of the line is reached]
  8166. if (istat==0) then
  8167. do
  8168. isize = 0
  8169. read(iunit,fmt='(A)',advance='NO',size=isize,iostat=istat) chunk
  8170. if (istat==0) then
  8171. line = line//chunk
  8172. else
  8173. if (isize>0 .and. isize<=seq_chunk_size) line = line//chunk(1:isize)
  8174. exit
  8175. end if
  8176. end do
  8177. end if
  8178. end subroutine get_current_line_from_file_sequential
  8179. !*****************************************************************************************
  8180. !*****************************************************************************************
  8181. !> author: Jacob Williams
  8182. !
  8183. ! Rewind the file to the beginning of the current line, and return this line.
  8184. ! The file is assumed to be opened.
  8185. ! This is the STREAM version (see also [[get_current_line_from_file_sequential]]).
  8186. subroutine get_current_line_from_file_stream(json,iunit,line)
  8187. implicit none
  8188. class(json_core),intent(inout) :: json
  8189. integer(IK),intent(in) :: iunit !! file unit number
  8190. character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
  8191. integer(IK) :: istart !! start position of current line
  8192. integer(IK) :: iend !! end position of current line
  8193. integer(IK) :: ios !! file read `iostat` code
  8194. character(kind=CK,len=1) :: c !! a character read from the file
  8195. logical :: done !! flag to exit the loop
  8196. istart = json%ipos
  8197. do
  8198. if (istart<=1) then
  8199. istart = 1
  8200. exit
  8201. end if
  8202. read(iunit,pos=istart,iostat=ios) c
  8203. done = ios /= 0_IK
  8204. if (.not. done) done = c==newline
  8205. if (done) then
  8206. if (istart/=1) istart = istart - 1
  8207. exit
  8208. end if
  8209. istart = istart-1 !rewind until the beginning of the line
  8210. end do
  8211. iend = json%ipos
  8212. do
  8213. read(iunit,pos=iend,iostat=ios) c
  8214. if (IS_IOSTAT_END(ios)) then
  8215. ! account for end of file without linebreak
  8216. iend=iend-1
  8217. exit
  8218. end if
  8219. if (c==newline .or. ios/=0) exit
  8220. iend=iend+1
  8221. end do
  8222. allocate( character(kind=CK,len=iend-istart+1) :: line )
  8223. read(iunit,pos=istart,iostat=ios) line
  8224. end subroutine get_current_line_from_file_stream
  8225. !*****************************************************************************************
  8226. !*****************************************************************************************
  8227. !>
  8228. ! Core parsing routine.
  8229. recursive subroutine parse_value(json, unit, str, value)
  8230. implicit none
  8231. class(json_core),intent(inout) :: json
  8232. integer(IK),intent(in) :: unit !! file unit number
  8233. character(kind=CK,len=*),intent(in) :: str !! string containing JSON
  8234. !! data (only used if `unit=0`)
  8235. type(json_value),pointer :: value !! JSON data that is extracted
  8236. logical(LK) :: eof !! end-of-file flag
  8237. character(kind=CK,len=1) :: c !! character read from file
  8238. !! (or string) by [[pop_char]]
  8239. # 10121
  8240. if (.not. json%exception_thrown) then
  8241. !the routine is being called incorrectly.
  8242. if (.not. associated(value)) then
  8243. call json%throw_exception('Error in parse_value: value pointer not associated.')
  8244. return
  8245. end if
  8246. ! pop the next non whitespace character off the file
  8247. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8248. skip_comments=json%allow_comments, popped=c)
  8249. if (eof) then
  8250. return
  8251. else
  8252. select case (c)
  8253. case (start_object)
  8254. ! start object
  8255. call json%to_object(value) !allocate class
  8256. call json%parse_object(unit, str, value)
  8257. case (start_array)
  8258. ! start array
  8259. call json%to_array(value) !allocate class
  8260. call json%parse_array(unit, str, value)
  8261. case (end_array)
  8262. ! end an empty array
  8263. call json%push_char(c)
  8264. if (associated(value)) then
  8265. deallocate(value)
  8266. nullify(value)
  8267. end if
  8268. case (quotation_mark)
  8269. ! string
  8270. call json%to_string(value) !allocate class
  8271. select case (value%var_type)
  8272. case (json_string)
  8273. # 10175
  8274. call json%parse_string(unit,str,value%str_value)
  8275. end select
  8276. case (CK_'t') !true_str(1:1) gfortran bug work around
  8277. !true
  8278. call json%parse_for_chars(unit, str, true_str(2:))
  8279. !allocate class and set value:
  8280. if (.not. json%exception_thrown) call json%to_logical(value,.true.)
  8281. case (CK_'f') !false_str(1:1) gfortran bug work around
  8282. !false
  8283. call json%parse_for_chars(unit, str, false_str(2:))
  8284. !allocate class and set value:
  8285. if (.not. json%exception_thrown) call json%to_logical(value,.false.)
  8286. case (CK_'n') !null_str(1:1) gfortran bug work around
  8287. !null
  8288. call json%parse_for_chars(unit, str, null_str(2:))
  8289. if (.not. json%exception_thrown) call json%to_null(value) ! allocate class
  8290. case(CK_'-', CK_'0': CK_'9', CK_'.', CK_'+')
  8291. call json%push_char(c)
  8292. call json%parse_number(unit, str, value)
  8293. case default
  8294. call json%throw_exception('Error in parse_value:'//&
  8295. ' Unexpected character while parsing value. "'//&
  8296. c//'"')
  8297. end select
  8298. end if
  8299. end if
  8300. end subroutine parse_value
  8301. !*****************************************************************************************
  8302. !*****************************************************************************************
  8303. !> author: Jacob Williams
  8304. !
  8305. ! Allocate a [[json_value]] pointer and make it a logical(LK) variable.
  8306. ! The pointer should not already be allocated.
  8307. !
  8308. !### Example
  8309. !````fortran
  8310. ! type(json_value),pointer :: p
  8311. ! type(json_core) :: json
  8312. ! call json%create_logical(p,'value',.true.)
  8313. !````
  8314. subroutine json_value_create_logical(json,p,val,name)
  8315. implicit none
  8316. class(json_core),intent(inout) :: json
  8317. type(json_value),pointer :: p
  8318. logical(LK),intent(in) :: val !! variable value
  8319. character(kind=CK,len=*),intent(in) :: name !! variable name
  8320. call json_value_create(p)
  8321. call json%to_logical(p,val,name)
  8322. end subroutine json_value_create_logical
  8323. !*****************************************************************************************
  8324. !*****************************************************************************************
  8325. !> author: Izaak Beekman
  8326. !
  8327. ! Wrapper for [[json_value_create_logical]] so `create_logical` method can
  8328. ! be called with name of character kind 'DEFAULT' or 'ISO_10646'
  8329. subroutine wrap_json_value_create_logical(json,p,val,name)
  8330. implicit none
  8331. class(json_core),intent(inout) :: json
  8332. type(json_value),pointer :: p
  8333. logical(LK),intent(in) :: val
  8334. character(kind=CDK,len=*),intent(in) :: name
  8335. call json%create_logical(p,val,to_unicode(name))
  8336. end subroutine wrap_json_value_create_logical
  8337. !*****************************************************************************************
  8338. !*****************************************************************************************
  8339. !> author: Jacob Williams
  8340. !
  8341. ! Allocate a [[json_value]] pointer and make it an integer(IK) variable.
  8342. ! The pointer should not already be allocated.
  8343. !
  8344. !### Example
  8345. !````fortran
  8346. ! type(json_value),pointer :: p
  8347. ! type(json_core) :: json
  8348. ! call json%create_integer(p,'value',1)
  8349. !````
  8350. subroutine json_value_create_integer(json,p,val,name)
  8351. implicit none
  8352. class(json_core),intent(inout) :: json
  8353. type(json_value),pointer :: p
  8354. integer(IK),intent(in) :: val
  8355. character(kind=CK,len=*),intent(in) :: name
  8356. call json_value_create(p)
  8357. call json%to_integer(p,val,name)
  8358. end subroutine json_value_create_integer
  8359. !*****************************************************************************************
  8360. !*****************************************************************************************
  8361. !> author: Izaak Beekman
  8362. !
  8363. ! A wrapper procedure for [[json_value_create_integer]] so that `create_integer`
  8364. ! method may be called with either a 'DEFAULT' or 'ISO_10646' character kind
  8365. ! `name` actual argument.
  8366. subroutine wrap_json_value_create_integer(json,p,val,name)
  8367. implicit none
  8368. class(json_core),intent(inout) :: json
  8369. type(json_value),pointer :: p
  8370. integer(IK),intent(in) :: val
  8371. character(kind=CDK,len=*),intent(in) :: name
  8372. call json%create_integer(p,val,to_unicode(name))
  8373. end subroutine wrap_json_value_create_integer
  8374. !*****************************************************************************************
  8375. !*****************************************************************************************
  8376. !> author: Jacob Williams
  8377. !
  8378. ! Allocate a [[json_value]] pointer and make it a real(RK) variable.
  8379. ! The pointer should not already be allocated.
  8380. !
  8381. !### Example
  8382. !````fortran
  8383. ! type(json_value),pointer :: p
  8384. ! type(json_core) :: json
  8385. ! call json%create_real(p,'value',1.0_RK)
  8386. !````
  8387. subroutine json_value_create_real(json,p,val,name)
  8388. implicit none
  8389. class(json_core),intent(inout) :: json
  8390. type(json_value),pointer :: p
  8391. real(RK),intent(in) :: val
  8392. character(kind=CK,len=*),intent(in) :: name
  8393. call json_value_create(p)
  8394. call json%to_real(p,val,name)
  8395. end subroutine json_value_create_real
  8396. !*****************************************************************************************
  8397. !*****************************************************************************************
  8398. !> author: Izaak Beekman
  8399. !
  8400. ! A wrapper for [[json_value_create_real]] so that `create_real` method
  8401. ! may be called with an actual argument corresponding to the dummy argument,
  8402. ! `name` that may be of 'DEFAULT' or 'ISO_10646' character kind.
  8403. subroutine wrap_json_value_create_real(json,p,val,name)
  8404. implicit none
  8405. class(json_core),intent(inout) :: json
  8406. type(json_value),pointer :: p
  8407. real(RK),intent(in) :: val
  8408. character(kind=CDK,len=*),intent(in) :: name
  8409. call json%create_real(p,val,to_unicode(name))
  8410. end subroutine wrap_json_value_create_real
  8411. !*****************************************************************************************
  8412. !*****************************************************************************************
  8413. !>
  8414. ! Alternate version of [[json_value_create_real]] where val=real32.
  8415. !
  8416. !@note The value is converted into a `real(RK)` variable internally.
  8417. subroutine json_value_create_real32(json,p,val,name)
  8418. implicit none
  8419. class(json_core),intent(inout) :: json
  8420. type(json_value),pointer :: p
  8421. real(real32),intent(in) :: val
  8422. character(kind=CK,len=*),intent(in) :: name
  8423. call json%create_real(p,real(val,RK),name)
  8424. end subroutine json_value_create_real32
  8425. !*****************************************************************************************
  8426. !*****************************************************************************************
  8427. !>
  8428. ! Alternate version of [[json_value_create_real32]] where "name" is kind(CDK).
  8429. subroutine wrap_json_value_create_real32(json,p,val,name)
  8430. implicit none
  8431. class(json_core),intent(inout) :: json
  8432. type(json_value),pointer :: p
  8433. real(real32),intent(in) :: val
  8434. character(kind=CDK,len=*),intent(in) :: name
  8435. call json%create_real(p,val,to_unicode(name))
  8436. end subroutine wrap_json_value_create_real32
  8437. !*****************************************************************************************
  8438. # 10443
  8439. !*****************************************************************************************
  8440. !> author: Jacob Williams
  8441. !
  8442. ! Allocate a json_value pointer and make it a string variable.
  8443. ! The pointer should not already be allocated.
  8444. !
  8445. !### Example
  8446. !````fortran
  8447. ! type(json_value),pointer :: p
  8448. ! type(json_core) :: json
  8449. ! call json%create_string(p,'value','hello')
  8450. !````
  8451. subroutine json_value_create_string(json,p,val,name,trim_str,adjustl_str)
  8452. implicit none
  8453. class(json_core),intent(inout) :: json
  8454. type(json_value),pointer :: p
  8455. character(kind=CK,len=*),intent(in) :: val
  8456. character(kind=CK,len=*),intent(in) :: name
  8457. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  8458. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  8459. call json_value_create(p)
  8460. call json%to_string(p,val,name,trim_str,adjustl_str)
  8461. end subroutine json_value_create_string
  8462. !*****************************************************************************************
  8463. !*****************************************************************************************
  8464. !> author: Izaak Beekman
  8465. !
  8466. ! Wrap [[json_value_create_string]] so that `create_string` method may be called
  8467. ! with actual character string arguments for `name` and `val` that are BOTH of
  8468. ! 'DEFAULT' or 'ISO_10646' character kind.
  8469. subroutine wrap_json_value_create_string(json,p,val,name,trim_str,adjustl_str)
  8470. implicit none
  8471. class(json_core),intent(inout) :: json
  8472. type(json_value),pointer :: p
  8473. character(kind=CDK,len=*),intent(in) :: val
  8474. character(kind=CDK,len=*),intent(in) :: name
  8475. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  8476. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  8477. call json%create_string(p,to_unicode(val),to_unicode(name),trim_str,adjustl_str)
  8478. end subroutine wrap_json_value_create_string
  8479. !*****************************************************************************************
  8480. !*****************************************************************************************
  8481. !> author: Jacob Williams
  8482. !
  8483. ! Allocate a json_value pointer and make it a null variable.
  8484. ! The pointer should not already be allocated.
  8485. !
  8486. !### Example
  8487. !````fortran
  8488. ! type(json_value),pointer :: p
  8489. ! type(json_core) :: json
  8490. ! call json%create_null(p,'value')
  8491. !````
  8492. subroutine json_value_create_null(json,p,name)
  8493. implicit none
  8494. class(json_core),intent(inout) :: json
  8495. type(json_value),pointer :: p
  8496. character(kind=CK,len=*),intent(in) :: name
  8497. call json_value_create(p)
  8498. call json%to_null(p,name)
  8499. end subroutine json_value_create_null
  8500. !*****************************************************************************************
  8501. !*****************************************************************************************
  8502. !> author: Izaak Beekman
  8503. !
  8504. ! Wrap [[json_value_create_null]] so that `create_null` method may be called with
  8505. ! an actual argument corresponding to the dummy argument `name` that is either
  8506. ! of 'DEFAULT' or 'ISO_10646' character kind.
  8507. subroutine wrap_json_value_create_null(json,p,name)
  8508. implicit none
  8509. class(json_core),intent(inout) :: json
  8510. type(json_value),pointer :: p
  8511. character(kind=CDK,len=*),intent(in) :: name
  8512. call json%create_null(p,to_unicode(name))
  8513. end subroutine wrap_json_value_create_null
  8514. !*****************************************************************************************
  8515. !*****************************************************************************************
  8516. !> author: Jacob Williams
  8517. !
  8518. ! Allocate a [[json_value]] pointer and make it an object variable.
  8519. ! The pointer should not already be allocated.
  8520. !
  8521. !### Example
  8522. !````fortran
  8523. ! type(json_value),pointer :: p
  8524. ! type(json_core) :: json
  8525. ! call json%create_object(p,'objectname')
  8526. !````
  8527. !
  8528. !@note The name is not significant for the root structure or an array element.
  8529. ! In those cases, an empty string can be used.
  8530. subroutine json_value_create_object(json,p,name)
  8531. implicit none
  8532. class(json_core),intent(inout) :: json
  8533. type(json_value),pointer :: p
  8534. character(kind=CK,len=*),intent(in) :: name
  8535. call json_value_create(p)
  8536. call json%to_object(p,name)
  8537. end subroutine json_value_create_object
  8538. !*****************************************************************************************
  8539. !*****************************************************************************************
  8540. !> author: Izaak Beekman
  8541. !
  8542. ! Wrap [[json_value_create_object]] so that `create_object` method may be called
  8543. ! with an actual argument corresponding to the dummy argument `name` that is of
  8544. ! either 'DEFAULT' or 'ISO_10646' character kind.
  8545. subroutine wrap_json_value_create_object(json,p,name)
  8546. implicit none
  8547. class(json_core),intent(inout) :: json
  8548. type(json_value),pointer :: p
  8549. character(kind=CDK,len=*),intent(in) :: name
  8550. call json%create_object(p,to_unicode(name))
  8551. end subroutine wrap_json_value_create_object
  8552. !*****************************************************************************************
  8553. !*****************************************************************************************
  8554. !> author: Jacob Williams
  8555. !
  8556. ! Allocate a [[json_value]] pointer and make it an array variable.
  8557. ! The pointer should not already be allocated.
  8558. !
  8559. !### Example
  8560. !````fortran
  8561. ! type(json_value),pointer :: p
  8562. ! type(json_core) :: json
  8563. ! call json%create_array(p,'arrayname')
  8564. !````
  8565. subroutine json_value_create_array(json,p,name)
  8566. implicit none
  8567. class(json_core),intent(inout) :: json
  8568. type(json_value),pointer :: p
  8569. character(kind=CK,len=*),intent(in) :: name
  8570. call json_value_create(p)
  8571. call json%to_array(p,name)
  8572. end subroutine json_value_create_array
  8573. !*****************************************************************************************
  8574. !*****************************************************************************************
  8575. !> author: Izaak Beekman
  8576. !
  8577. ! A wrapper for [[json_value_create_array]] so that `create_array` method may be
  8578. ! called with an actual argument, corresponding to the dummy argument `name`,
  8579. ! that is either of 'DEFAULT' or 'ISO_10646' character kind.
  8580. subroutine wrap_json_value_create_array(json,p,name)
  8581. implicit none
  8582. class(json_core),intent(inout) :: json
  8583. type(json_value),pointer :: p
  8584. character(kind=CDK,len=*),intent(in) :: name
  8585. call json%create_array(p,to_unicode(name))
  8586. end subroutine wrap_json_value_create_array
  8587. !*****************************************************************************************
  8588. !*****************************************************************************************
  8589. !> author: Jacob Williams
  8590. !
  8591. ! Change the [[json_value]] variable to a logical.
  8592. subroutine to_logical(json,p,val,name)
  8593. implicit none
  8594. class(json_core),intent(inout) :: json
  8595. type(json_value),pointer :: p
  8596. logical(LK),intent(in),optional :: val !! if the value is also to be set
  8597. !! (if not present, then .false. is used).
  8598. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8599. !set type and value:
  8600. call destroy_json_data(p)
  8601. p%var_type = json_logical
  8602. allocate(p%log_value)
  8603. if (present(val)) then
  8604. p%log_value = val
  8605. else
  8606. p%log_value = .false. !default value
  8607. end if
  8608. !name:
  8609. if (present(name)) call json%rename(p,name)
  8610. end subroutine to_logical
  8611. !*****************************************************************************************
  8612. !*****************************************************************************************
  8613. !> author: Jacob Williams
  8614. !
  8615. ! Change the [[json_value]] variable to an integer.
  8616. subroutine to_integer(json,p,val,name)
  8617. implicit none
  8618. class(json_core),intent(inout) :: json
  8619. type(json_value),pointer :: p
  8620. integer(IK),intent(in),optional :: val !! if the value is also to be set
  8621. !! (if not present, then 0 is used).
  8622. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8623. !set type and value:
  8624. call destroy_json_data(p)
  8625. p%var_type = json_integer
  8626. allocate(p%int_value)
  8627. if (present(val)) then
  8628. p%int_value = val
  8629. else
  8630. p%int_value = 0_IK !default value
  8631. end if
  8632. !name:
  8633. if (present(name)) call json%rename(p,name)
  8634. end subroutine to_integer
  8635. !*****************************************************************************************
  8636. !*****************************************************************************************
  8637. !> author: Jacob Williams
  8638. !
  8639. ! Change the [[json_value]] variable to a real.
  8640. subroutine to_real(json,p,val,name)
  8641. implicit none
  8642. class(json_core),intent(inout) :: json
  8643. type(json_value),pointer :: p
  8644. real(RK),intent(in),optional :: val !! if the value is also to be set
  8645. !! (if not present, then 0.0_rk is used).
  8646. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8647. !set type and value:
  8648. call destroy_json_data(p)
  8649. p%var_type = json_real
  8650. allocate(p%dbl_value)
  8651. if (present(val)) then
  8652. p%dbl_value = val
  8653. else
  8654. p%dbl_value = 0.0_RK !default value
  8655. end if
  8656. !name:
  8657. if (present(name)) call json%rename(p,name)
  8658. end subroutine to_real
  8659. !*****************************************************************************************
  8660. !*****************************************************************************************
  8661. !> author: Jacob Williams
  8662. !
  8663. ! Change the [[json_value]] variable to a string.
  8664. !
  8665. !### Modified
  8666. ! * Izaak Beekman : 02/24/2015
  8667. subroutine to_string(json,p,val,name,trim_str,adjustl_str)
  8668. implicit none
  8669. class(json_core),intent(inout) :: json
  8670. type(json_value),pointer :: p
  8671. character(kind=CK,len=*),intent(in),optional :: val !! if the value is also to be set
  8672. !! (if not present, then '' is used).
  8673. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8674. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  8675. !! (only used if `val` is present)
  8676. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  8677. !! (only used if `val` is present)
  8678. !! (note that ADJUSTL is done before TRIM)
  8679. character(kind=CK,len=:),allocatable :: str !! temp string for `trim()` and/or `adjustl()`
  8680. logical :: trim_string !! if the string is to be trimmed
  8681. logical :: adjustl_string !! if the string is to be adjusted left
  8682. !set type and value:
  8683. call destroy_json_data(p)
  8684. p%var_type = json_string
  8685. if (present(val)) then
  8686. if (present(trim_str)) then
  8687. trim_string = trim_str
  8688. else
  8689. trim_string = .false.
  8690. end if
  8691. if (present(adjustl_str)) then
  8692. adjustl_string = adjustl_str
  8693. else
  8694. adjustl_string = .false.
  8695. end if
  8696. if (trim_string .or. adjustl_string) then
  8697. str = val
  8698. if (adjustl_string) str = adjustl(str)
  8699. if (trim_string) str = trim(str)
  8700. p%str_value = str
  8701. else
  8702. p%str_value = val
  8703. end if
  8704. else
  8705. p%str_value = CK_'' ! default value
  8706. end if
  8707. !name:
  8708. if (present(name)) call json%rename(p,name)
  8709. end subroutine to_string
  8710. !*****************************************************************************************
  8711. !*****************************************************************************************
  8712. !> author: Jacob Williams
  8713. !
  8714. ! Change the [[json_value]] variable to a null.
  8715. subroutine to_null(json,p,name)
  8716. implicit none
  8717. class(json_core),intent(inout) :: json
  8718. type(json_value),pointer :: p
  8719. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8720. !set type and value:
  8721. call destroy_json_data(p)
  8722. p%var_type = json_null
  8723. !name:
  8724. if (present(name)) call json%rename(p,name)
  8725. end subroutine to_null
  8726. !*****************************************************************************************
  8727. !*****************************************************************************************
  8728. !> author: Jacob Williams
  8729. !
  8730. ! Change the [[json_value]] variable to an object.
  8731. subroutine to_object(json,p,name)
  8732. implicit none
  8733. class(json_core),intent(inout) :: json
  8734. type(json_value),pointer :: p
  8735. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8736. !set type and value:
  8737. call destroy_json_data(p)
  8738. p%var_type = json_object
  8739. !name:
  8740. if (present(name)) call json%rename(p,name)
  8741. end subroutine to_object
  8742. !*****************************************************************************************
  8743. !*****************************************************************************************
  8744. !> author: Jacob Williams
  8745. !
  8746. ! Change the [[json_value]] variable to an array.
  8747. subroutine to_array(json,p,name)
  8748. implicit none
  8749. class(json_core),intent(inout) :: json
  8750. type(json_value),pointer :: p
  8751. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8752. !set type and value:
  8753. call destroy_json_data(p)
  8754. p%var_type = json_array
  8755. !name:
  8756. if (present(name)) call json%rename(p,name)
  8757. end subroutine to_array
  8758. !*****************************************************************************************
  8759. !*****************************************************************************************
  8760. !>
  8761. ! Core parsing routine.
  8762. recursive subroutine parse_object(json, unit, str, parent)
  8763. implicit none
  8764. class(json_core),intent(inout) :: json
  8765. integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
  8766. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
  8767. type(json_value),pointer :: parent !! the parsed object will be added as a child of this
  8768. type(json_value),pointer :: pair !! temp variable
  8769. logical(LK) :: eof !! end of file flag
  8770. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8771. # 10885
  8772. if (.not. json%exception_thrown) then
  8773. !the routine is being called incorrectly.
  8774. if (.not. associated(parent)) then
  8775. call json%throw_exception('Error in parse_object: parent pointer not associated.')
  8776. end if
  8777. nullify(pair) !probably not necessary
  8778. ! pair name
  8779. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8780. skip_comments=json%allow_comments, popped=c)
  8781. if (eof) then
  8782. call json%throw_exception('Error in parse_object:'//&
  8783. ' Unexpected end of file while parsing start of object.')
  8784. return
  8785. else if (end_object == c) then
  8786. ! end of an empty object
  8787. return
  8788. else if (quotation_mark == c) then
  8789. call json_value_create(pair)
  8790. # 10912
  8791. call json%parse_string(unit,str,pair%name)
  8792. if (json%exception_thrown) then
  8793. call json%destroy(pair)
  8794. return
  8795. end if
  8796. else
  8797. call json%throw_exception('Error in parse_object: Expecting string: "'//c//'"')
  8798. return
  8799. end if
  8800. ! pair value
  8801. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8802. skip_comments=json%allow_comments, popped=c)
  8803. if (eof) then
  8804. call json%destroy(pair)
  8805. call json%throw_exception('Error in parse_object:'//&
  8806. ' Unexpected end of file while parsing object member.')
  8807. return
  8808. else if (colon_char == c) then
  8809. ! parse the value
  8810. call json%parse_value(unit, str, pair)
  8811. if (json%exception_thrown) then
  8812. call json%destroy(pair)
  8813. return
  8814. else
  8815. call json%add(parent, pair)
  8816. end if
  8817. else
  8818. call json%destroy(pair)
  8819. call json%throw_exception('Error in parse_object:'//&
  8820. ' Expecting : and then a value: '//c)
  8821. return
  8822. end if
  8823. ! another possible pair
  8824. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8825. skip_comments=json%allow_comments, popped=c)
  8826. if (eof) then
  8827. call json%throw_exception('Error in parse_object: '//&
  8828. 'End of file encountered when parsing an object')
  8829. return
  8830. else if (delimiter == c) then
  8831. ! read the next member
  8832. call json%parse_object(unit = unit, str=str, parent = parent)
  8833. else if (end_object == c) then
  8834. ! end of object
  8835. return
  8836. else
  8837. call json%throw_exception('Error in parse_object: Expecting end of object: '//c)
  8838. return
  8839. end if
  8840. end if
  8841. end subroutine parse_object
  8842. !*****************************************************************************************
  8843. !*****************************************************************************************
  8844. !>
  8845. ! Core parsing routine.
  8846. recursive subroutine parse_array(json, unit, str, array)
  8847. implicit none
  8848. class(json_core),intent(inout) :: json
  8849. integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
  8850. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
  8851. type(json_value),pointer :: array
  8852. type(json_value),pointer :: element !! temp variable for array element
  8853. logical(LK) :: eof !! end of file flag
  8854. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8855. do
  8856. if (json%exception_thrown) exit
  8857. ! try to parse an element value
  8858. nullify(element)
  8859. call json_value_create(element)
  8860. call json%parse_value(unit, str, element)
  8861. if (json%exception_thrown) then
  8862. if (associated(element)) call json%destroy(element)
  8863. exit
  8864. end if
  8865. ! parse value will deallocate an empty array value
  8866. if (associated(element)) call json%add(array, element)
  8867. ! popped the next character
  8868. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8869. skip_comments=json%allow_comments, popped=c)
  8870. if (eof) then
  8871. ! The file ended before array was finished:
  8872. call json%throw_exception('Error in parse_array: '//&
  8873. 'End of file encountered when parsing an array.')
  8874. exit
  8875. else if (delimiter == c) then
  8876. ! parse the next element
  8877. cycle
  8878. else if (end_array == c) then
  8879. ! end of array
  8880. exit
  8881. else
  8882. call json%throw_exception('Error in parse_array: '//&
  8883. 'Unexpected character encountered when parsing array.')
  8884. exit
  8885. end if
  8886. end do
  8887. end subroutine parse_array
  8888. !*****************************************************************************************
  8889. !*****************************************************************************************
  8890. !>
  8891. ! Parses a string while reading a JSON file.
  8892. !
  8893. !### History
  8894. ! * Jacob Williams : 6/16/2014 : Added hex validation.
  8895. ! * Jacob Williams : 12/3/2015 : Fixed some bugs.
  8896. ! * Jacob Williams : 8/23/2015 : `string` is now returned unescaped.
  8897. ! * Jacob Williams : 7/21/2018 : moved hex validate to [[unescape_string]].
  8898. subroutine parse_string(json, unit, str, string)
  8899. implicit none
  8900. class(json_core),intent(inout) :: json
  8901. integer(IK),intent(in) :: unit !! file unit number (if
  8902. !! parsing from a file)
  8903. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing
  8904. !! from a string)
  8905. character(kind=CK,len=:),allocatable,intent(out) :: string !! the string (unescaped
  8906. !! if necessary)
  8907. logical(LK) :: eof !! end of file flag
  8908. logical(LK) :: escape !! for escape string parsing
  8909. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8910. integer(IK) :: ip !! index to put next character,
  8911. !! to speed up by reducing the number
  8912. !! of character string reallocations.
  8913. character(kind=CK,len=:),allocatable :: error_message !! for string unescaping
  8914. !at least return a blank string if there is a problem:
  8915. string = blank_chunk
  8916. if (.not. json%exception_thrown) then
  8917. !initialize:
  8918. escape = .false.
  8919. ip = 1
  8920. do
  8921. !get the next character from the file:
  8922. call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c)
  8923. if (eof) then
  8924. call json%throw_exception('Error in parse_string: Expecting end of string')
  8925. return
  8926. else if (c==quotation_mark .and. .not. escape) then !end of string
  8927. exit
  8928. else
  8929. !if the string is not big enough, then add another chunk:
  8930. if (ip>len(string)) string = string // blank_chunk
  8931. !append to string:
  8932. string(ip:ip) = c
  8933. ip = ip + 1
  8934. ! check for escape character, so we don't
  8935. ! exit prematurely if escaping a quotation
  8936. ! character:
  8937. if (escape) then
  8938. escape = .false.
  8939. else
  8940. escape = (c==backslash)
  8941. end if
  8942. end if
  8943. end do
  8944. !trim the string if necessary:
  8945. if (ip<len(string)+1) then
  8946. if (ip==1) then
  8947. string = CK_''
  8948. else
  8949. string = string(1:ip-1)
  8950. end if
  8951. end if
  8952. ! string is returned unescaped:
  8953. ! (this will also validate any hex strings present)
  8954. call unescape_string(string,error_message)
  8955. if (allocated(error_message)) then
  8956. call json%throw_exception(error_message)
  8957. deallocate(error_message) !cleanup
  8958. end if
  8959. end if
  8960. end subroutine parse_string
  8961. !*****************************************************************************************
  8962. !*****************************************************************************************
  8963. !>
  8964. ! Core parsing routine.
  8965. !
  8966. ! This is used to verify the strings `true`, `false`, and `null` during parsing.
  8967. subroutine parse_for_chars(json, unit, str, chars)
  8968. implicit none
  8969. class(json_core),intent(inout) :: json
  8970. integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
  8971. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
  8972. character(kind=CK,len=*),intent(in) :: chars !! the string to check for.
  8973. integer(IK) :: i !! counter
  8974. integer(IK) :: length !! trimmed length of `chars`
  8975. logical(LK) :: eof !! end of file flag
  8976. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8977. if (.not. json%exception_thrown) then
  8978. length = len_trim(chars)
  8979. do i = 1, length
  8980. call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c)
  8981. if (eof) then
  8982. call json%throw_exception('Error in parse_for_chars:'//&
  8983. ' Unexpected end of file while parsing.')
  8984. return
  8985. else if (c /= chars(i:i)) then
  8986. call json%throw_exception('Error in parse_for_chars:'//&
  8987. ' Unexpected character: "'//c//'" (expecting "'//&
  8988. chars(i:i)//'")')
  8989. return
  8990. end if
  8991. end do
  8992. end if
  8993. end subroutine parse_for_chars
  8994. !*****************************************************************************************
  8995. !*****************************************************************************************
  8996. !> author: Jacob Williams
  8997. ! date: 1/20/2014
  8998. !
  8999. ! Read a numerical value from the file (or string).
  9000. ! The routine will determine if it is an integer or a real, and
  9001. ! allocate the type accordingly.
  9002. !
  9003. !@note Complete rewrite of the original FSON routine, which had some problems.
  9004. subroutine parse_number(json, unit, str, value)
  9005. implicit none
  9006. class(json_core),intent(inout) :: json
  9007. integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
  9008. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
  9009. type(json_value),pointer :: value
  9010. character(kind=CK,len=:),allocatable :: tmp !! temp string
  9011. character(kind=CK,len=:),allocatable :: saved_err_message !! temp error message for
  9012. !! string to int conversion
  9013. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  9014. logical(LK) :: eof !! end of file flag
  9015. real(RK) :: rval !! real value
  9016. integer(IK) :: ival !! integer value
  9017. logical(LK) :: first !! first character
  9018. logical(LK) :: is_integer !! it is an integer
  9019. integer(IK) :: ip !! index to put next character
  9020. !! [to speed up by reducing the number
  9021. !! of character string reallocations]
  9022. if (.not. json%exception_thrown) then
  9023. tmp = blank_chunk
  9024. ip = 1
  9025. first = .true.
  9026. is_integer = .true. !assume it may be an integer, unless otherwise determined
  9027. !read one character at a time and accumulate the string:
  9028. do
  9029. !get the next character:
  9030. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., popped=c)
  9031. select case (c)
  9032. case(CK_'-',CK_'+') !note: allowing a '+' as the first character here.
  9033. if (is_integer .and. (.not. first)) is_integer = .false.
  9034. !add it to the string:
  9035. !tmp = tmp // c !...original
  9036. if (ip>len(tmp)) tmp = tmp // blank_chunk
  9037. tmp(ip:ip) = c
  9038. ip = ip + 1
  9039. case(CK_'.',CK_'E',CK_'e',CK_'D',CK_'d') !can be present in real numbers
  9040. if (is_integer) is_integer = .false.
  9041. !add it to the string:
  9042. !tmp = tmp // c !...original
  9043. if (ip>len(tmp)) tmp = tmp // blank_chunk
  9044. tmp(ip:ip) = c
  9045. ip = ip + 1
  9046. case(CK_'0':CK_'9') !valid characters for numbers
  9047. !add it to the string:
  9048. !tmp = tmp // c !...original
  9049. if (ip>len(tmp)) tmp = tmp // blank_chunk
  9050. tmp(ip:ip) = c
  9051. ip = ip + 1
  9052. case default
  9053. !push back the last character read:
  9054. call json%push_char(c)
  9055. !string to value:
  9056. if (is_integer) then
  9057. ! it is an integer:
  9058. ival = json%string_to_int(tmp)
  9059. if (json%exception_thrown .and. .not. json%strict_integer_type_checking) then
  9060. ! if it couldn't be converted to an integer,
  9061. ! then try to convert it to a real value and see if that works
  9062. saved_err_message = json%err_message ! keep the original error message
  9063. call json%clear_exceptions() ! clear exceptions
  9064. rval = json%string_to_dble(tmp)
  9065. if (json%exception_thrown) then
  9066. ! restore original error message and continue
  9067. json%err_message = saved_err_message
  9068. call json%to_integer(value,ival) ! just so we have something
  9069. else
  9070. ! in this case, we return a real
  9071. call json%to_real(value,rval)
  9072. end if
  9073. else
  9074. call json%to_integer(value,ival)
  9075. end if
  9076. else
  9077. ! it is a real:
  9078. rval = json%string_to_dble(tmp)
  9079. call json%to_real(value,rval)
  9080. end if
  9081. exit !finished
  9082. end select
  9083. if (first) first = .false.
  9084. end do
  9085. !cleanup:
  9086. if (allocated(tmp)) deallocate(tmp)
  9087. end if
  9088. end subroutine parse_number
  9089. !*****************************************************************************************
  9090. !*****************************************************************************************
  9091. !>
  9092. ! Get the next character from the file (or string).
  9093. !
  9094. !### See also
  9095. ! * [[push_char]]
  9096. !
  9097. !@note This routine ignores non-printing ASCII characters
  9098. ! (`iachar<=31`) that are in strings.
  9099. subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped)
  9100. implicit none
  9101. class(json_core),intent(inout) :: json
  9102. integer(IK),intent(in) :: unit !! file unit number (if parsing
  9103. !! from a file)
  9104. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a
  9105. !! string) -- only used if `unit=0`
  9106. logical(LK),intent(in),optional :: skip_ws !! to ignore whitespace [default False]
  9107. logical(LK),intent(in),optional :: skip_comments !! to ignore comment lines [default False]
  9108. logical(LK),intent(out) :: eof !! true if the end of the file has
  9109. !! been reached.
  9110. character(kind=CK,len=1),intent(out) :: popped !! the popped character returned
  9111. integer(IK) :: ios !! `iostat` flag
  9112. integer(IK) :: str_len !! length of `str`
  9113. character(kind=CK,len=1) :: c !! a character read from the file (or string)
  9114. logical(LK) :: ignore !! if whitespace is to be ignored
  9115. logical(LK) :: ignore_comments !! if comment lines are to be ignored
  9116. logical(LK) :: parsing_comment !! if we are in the process
  9117. !! of parsing a comment line
  9118. if (.not. json%exception_thrown) then
  9119. eof = .false.
  9120. if (.not. present(skip_ws)) then
  9121. ignore = .false.
  9122. else
  9123. ignore = skip_ws
  9124. end if
  9125. parsing_comment = .false.
  9126. if (.not. present(skip_comments)) then
  9127. ignore_comments = .false.
  9128. else
  9129. ignore_comments = skip_comments
  9130. end if
  9131. do
  9132. if (json%pushed_index > 0) then
  9133. ! there is a character pushed back on, most likely
  9134. ! from the number parsing. Note: this can only occur if
  9135. ! reading from a file when use_unformatted_stream=.false.
  9136. c = json%pushed_char(json%pushed_index:json%pushed_index)
  9137. json%pushed_index = json%pushed_index - 1
  9138. else
  9139. if (unit/=0) then !read from the file
  9140. !read the next character:
  9141. if (use_unformatted_stream) then
  9142. ! in this case, we read the file in chunks.
  9143. ! if we already have the character we need,
  9144. ! then get it from the chunk. Otherwise,
  9145. ! read in another chunk.
  9146. if (json%ichunk<1) then
  9147. ! read in a chunk:
  9148. json%ichunk = 0
  9149. if (json%filesize<json%ipos+len(json%chunk)-1) then
  9150. ! for the last chunk, we resize
  9151. ! it to the correct size:
  9152. json%chunk = repeat(space, json%filesize-json%ipos+1)
  9153. end if
  9154. read(unit=unit,pos=json%ipos,iostat=ios) json%chunk
  9155. else
  9156. ios = 0
  9157. end if
  9158. json%ichunk = json%ichunk + 1
  9159. if (json%ichunk>len(json%chunk)) then
  9160. ! check this just in case
  9161. ios = IOSTAT_END
  9162. else
  9163. ! get the next character from the chunk:
  9164. c = json%chunk(json%ichunk:json%ichunk)
  9165. if (json%ichunk==len(json%chunk)) then
  9166. json%ichunk = 0 ! reset for next chunk
  9167. end if
  9168. end if
  9169. else
  9170. ! a formatted read:
  9171. read(unit=unit,fmt='(A1)',advance='NO',iostat=ios) c
  9172. end if
  9173. json%ipos = json%ipos + 1
  9174. else !read from the string
  9175. str_len = len(str) !length of the string
  9176. if (json%ipos<=str_len) then
  9177. c = str(json%ipos:json%ipos)
  9178. ios = 0
  9179. else
  9180. ios = IOSTAT_END !end of the string
  9181. end if
  9182. json%ipos = json%ipos + 1
  9183. end if
  9184. json%char_count = json%char_count + 1 !character count in the current line
  9185. if (IS_IOSTAT_END(ios)) then !end of file
  9186. ! no character to return
  9187. json%char_count = 0
  9188. eof = .true.
  9189. popped = space ! just to set a value
  9190. exit
  9191. else if (IS_IOSTAT_EOR(ios) .or. c==newline) then !end of record
  9192. json%char_count = 0
  9193. json%line_count = json%line_count + 1
  9194. if (ignore_comments) parsing_comment = .false. ! done parsing this comment line
  9195. cycle
  9196. end if
  9197. end if
  9198. if (ignore_comments .and. (parsing_comment .or. scan(c,json%comment_char,kind=IK)>0_IK) ) then
  9199. ! skipping the comment
  9200. parsing_comment = .true.
  9201. cycle
  9202. else if (any(c == control_chars)) then
  9203. ! non printing ascii characters
  9204. cycle
  9205. else if (ignore .and. c == space) then
  9206. ! ignoring whitespace
  9207. cycle
  9208. else
  9209. ! return the character
  9210. popped = c
  9211. exit
  9212. end if
  9213. end do
  9214. end if
  9215. end subroutine pop_char
  9216. !*****************************************************************************************
  9217. !*****************************************************************************************
  9218. !>
  9219. ! Core routine.
  9220. !
  9221. !### See also
  9222. ! * [[pop_char]]
  9223. !
  9224. !### History
  9225. ! * Jacob Williams : 5/3/2015 : replaced original version of this routine.
  9226. subroutine push_char(json,c)
  9227. implicit none
  9228. class(json_core),intent(inout) :: json
  9229. character(kind=CK,len=1),intent(in) :: c !! to character to push
  9230. character(kind=CK,len=max_numeric_str_len) :: istr !! for error printing
  9231. if (.not. json%exception_thrown) then
  9232. if (use_unformatted_stream) then
  9233. !in this case, c is ignored, and we just
  9234. !decrement the stream position counter:
  9235. json%ipos = json%ipos - 1
  9236. json%ichunk = json%ichunk - 1
  9237. else
  9238. json%pushed_index = json%pushed_index + 1
  9239. if (json%pushed_index>0 .and. json%pushed_index<=len(json%pushed_char)) then
  9240. json%pushed_char(json%pushed_index:json%pushed_index) = c
  9241. else
  9242. call integer_to_string(json%pushed_index,int_fmt,istr)
  9243. call json%throw_exception('Error in push_char: '//&
  9244. 'invalid valid of pushed_index: '//trim(istr))
  9245. end if
  9246. end if
  9247. !character count in the current line
  9248. json%char_count = json%char_count - 1
  9249. end if
  9250. end subroutine push_char
  9251. !*****************************************************************************************
  9252. !*****************************************************************************************
  9253. !> author: Jacob Williams
  9254. !
  9255. ! Print any error message, and then clear the exceptions.
  9256. !
  9257. !@note This routine is used by the unit tests.
  9258. ! It was originally in json_example.f90, and was
  9259. ! moved here 2/26/2015 by Izaak Beekman.
  9260. subroutine json_print_error_message(json,io_unit)
  9261. implicit none
  9262. class(json_core),intent(inout) :: json
  9263. integer, intent(in), optional :: io_unit !! unit number for
  9264. !! printing error message
  9265. character(kind=CK,len=:),allocatable :: error_msg !! error message
  9266. logical :: status_ok !! false if there were any errors thrown
  9267. !get error message:
  9268. call json%check_for_errors(status_ok, error_msg)
  9269. !print it if there is one:
  9270. if (.not. status_ok) then
  9271. if (present(io_unit)) then
  9272. write(io_unit,'(A)') error_msg
  9273. else
  9274. write(output_unit,'(A)') error_msg
  9275. end if
  9276. deallocate(error_msg)
  9277. call json%clear_exceptions()
  9278. end if
  9279. end subroutine json_print_error_message
  9280. !*****************************************************************************************
  9281. !*****************************************************************************************
  9282. end module json_value_module
  9283. !*****************************************************************************************