Simulation Core
25'ten fazla konu seçemezsiniz Konular bir harf veya rakamla başlamalı, kısa çizgiler ('-') içerebilir ve en fazla 35 karakter uzunluğunda olabilir.
 
 
 
 
 
 

11550 satır
446 KiB

  1. !*****************************************************************************************
  2. !> author: Jacob Williams
  3. ! license: BSD
  4. !
  5. ! This module provides a low-level interface for manipulation of JSON data.
  6. ! The two public entities are [[json_value]], and [[json_core(type)]].
  7. ! The [[json_file_module]] provides a higher-level interface to some
  8. ! of these routines.
  9. !
  10. !### License
  11. ! * JSON-Fortran is released under a BSD-style license.
  12. ! See the [LICENSE](https://github.com/jacobwilliams/json-fortran/blob/master/LICENSE)
  13. ! file for details.
  14. module json_value_module
  15. use,intrinsic :: iso_fortran_env, only: iostat_end,error_unit,output_unit
  16. use,intrinsic :: ieee_arithmetic
  17. use json_kinds
  18. use json_parameters
  19. use json_string_utilities
  20. implicit none
  21. private
  22. #include "json_macros.inc"
  23. !*********************************************************
  24. !>
  25. ! If Unicode is not enabled, then
  26. ! JSON files are opened using access='STREAM' and
  27. ! form='UNFORMATTED'. This allows the file to
  28. ! be read faster.
  29. !
  30. #ifdef USE_UCS4
  31. logical,parameter :: use_unformatted_stream = .false.
  32. #else
  33. logical,parameter :: use_unformatted_stream = .true.
  34. #endif
  35. !*********************************************************
  36. !*********************************************************
  37. !>
  38. ! If Unicode is not enabled, then
  39. ! JSON files are opened using access='STREAM' and
  40. ! form='UNFORMATTED'. This allows the file to
  41. ! be read faster.
  42. !
  43. #ifdef USE_UCS4
  44. character(kind=CDK,len=*),parameter :: access_spec = 'SEQUENTIAL'
  45. #else
  46. character(kind=CDK,len=*),parameter :: access_spec = 'STREAM'
  47. #endif
  48. !*********************************************************
  49. !*********************************************************
  50. !>
  51. ! If Unicode is not enabled, then
  52. ! JSON files are opened using access='STREAM' and
  53. ! form='UNFORMATTED'. This allows the file to
  54. ! be read faster.
  55. !
  56. #ifdef USE_UCS4
  57. character(kind=CDK,len=*),parameter :: form_spec = 'FORMATTED'
  58. #else
  59. character(kind=CDK,len=*),parameter :: form_spec = 'UNFORMATTED'
  60. #endif
  61. !*********************************************************
  62. !*********************************************************
  63. !>
  64. ! Type used to construct the linked-list JSON structure.
  65. ! Normally, this should always be a pointer variable.
  66. ! This type should only be used by an instance of [[json_core(type)]].
  67. !
  68. !### Example
  69. !
  70. ! The following test program:
  71. !
  72. !````fortran
  73. ! program test
  74. ! use json_module
  75. ! implicit none
  76. ! type(json_core) :: json
  77. ! type(json_value),pointer :: p
  78. ! call json%create_object(p,'') !create the root
  79. ! call json%add(p,'year',1805) !add some data
  80. ! call json%add(p,'value',1.0_RK) !add some data
  81. ! call json%print(p,'test.json') !write it to a file
  82. ! call json%destroy(p) !cleanup
  83. ! end program test
  84. !````
  85. !
  86. ! Produces the JSON file **test.json**:
  87. !
  88. !````json
  89. ! {
  90. ! "year": 1805,
  91. ! "value": 0.1E+1
  92. ! }
  93. !````
  94. !
  95. !@warning Pointers of this type should only be allocated
  96. ! using the methods from [[json_core(type)]].
  97. type,public :: json_value
  98. !force the constituents to be stored contiguously
  99. ![note: on Intel, the order of the variables below
  100. ! is significant to avoid the misaligned field warnings]
  101. sequence
  102. private
  103. !for the linked list:
  104. type(json_value),pointer :: previous => null() !! previous item in the list
  105. type(json_value),pointer :: next => null() !! next item in the list
  106. type(json_value),pointer :: parent => null() !! parent item of this
  107. type(json_value),pointer :: children => null() !! first child item of this
  108. type(json_value),pointer :: tail => null() !! last child item of this
  109. character(kind=CK,len=:),allocatable :: name !! variable name (unescaped)
  110. real(RK),allocatable :: dbl_value !! real data for this variable
  111. logical(LK),allocatable :: log_value !! logical data for this variable
  112. character(kind=CK,len=:),allocatable :: str_value !! string data for this variable
  113. !! (unescaped)
  114. integer(IK),allocatable :: int_value !! integer data for this variable
  115. integer(IK) :: var_type = json_unknown !! variable type
  116. integer(IK),private :: n_children = 0 !! number of children
  117. end type json_value
  118. !*********************************************************
  119. !*********************************************************
  120. !>
  121. ! To access the core routines for manipulation
  122. ! of [[json_value]] pointer variables. This class allows
  123. ! for thread safe use of the module.
  124. !
  125. !### Usage
  126. !````fortran
  127. ! program test
  128. ! use json_module, wp=>json_RK
  129. ! implicit none
  130. ! type(json_core) :: json !<--have to declare this
  131. ! type(json_value),pointer :: p
  132. ! call json%create_object(p,'') !create the root
  133. ! call json%add(p,'year',1805) !add some data
  134. ! call json%add(p,'value',1.0_wp) !add some data
  135. ! call json%print(p,'test.json') !write it to a file
  136. ! call json%destroy(p) !cleanup
  137. ! end program test
  138. !````
  139. type,public :: json_core
  140. private
  141. integer(IK) :: spaces_per_tab = 2 !! number of spaces for indenting
  142. logical(LK) :: compact_real = .true. !! to use the "compact" form of real
  143. !! numbers for output
  144. character(kind=CDK,len=:),allocatable :: real_fmt !! the format string to use
  145. !! for converting real numbers to strings.
  146. !! It can be set in [[json_initialize]],
  147. !! and used in [[json_value_print]]
  148. !! If not set, then `default_real_fmt`
  149. !! is used instead.
  150. logical(LK) :: is_verbose = .false. !! if true, all exceptions are
  151. !! immediately printed to console.
  152. logical(LK) :: stop_on_error = .false. !! if true, then the program is
  153. !! stopped immediately when an
  154. !! exception is raised.
  155. logical(LK) :: exception_thrown = .false. !! The error flag. Will be set to true
  156. !! when an error is thrown in the class.
  157. !! Many of the methods will check this
  158. !! and return immediately if it is true.
  159. character(kind=CK,len=:),allocatable :: err_message
  160. !! the error message.
  161. !! if `exception_thrown=False` then
  162. !! this variable is not allocated.
  163. integer(IK) :: char_count = 0 !! character position in the current line
  164. integer(IK) :: line_count = 1 !! lines read counter
  165. integer(IK) :: pushed_index = 0 !! used when parsing lines in file
  166. character(kind=CK,len=pushed_char_size) :: pushed_char = CK_'' !! used when parsing
  167. !! lines in file
  168. integer(IK) :: ipos = 1 !! for allocatable strings: next character to read
  169. logical(LK) :: strict_type_checking = .false. !! if true, then no type conversions are done
  170. !! in the `get` routines if the actual variable
  171. !! type is different from the return type (for
  172. !! example, integer to real).
  173. logical(LK) :: trailing_spaces_significant = .false. !! for name and path comparisons, if trailing
  174. !! space is to be considered significant.
  175. logical(LK) :: case_sensitive_keys = .true. !! if name and path comparisons
  176. !! are case sensitive.
  177. logical(LK) :: no_whitespace = .false. !! when printing a JSON string, don't include
  178. !! non-significant spaces or line breaks.
  179. !! If true, the entire structure will be
  180. !! printed on one line.
  181. logical(LK) :: unescaped_strings = .true. !! If false, then the escaped
  182. !! string is returned from [[json_get_string]]
  183. !! and similar routines. If true [default],
  184. !! then the string is returned unescaped.
  185. logical(LK) :: allow_comments = .true. !! if true, any comments will be ignored when
  186. !! parsing a file. The comment tokens are defined
  187. !! by the `comment_char` character variable.
  188. character(kind=CK,len=:),allocatable :: comment_char !! comment tokens when
  189. !! `allow_comments` is true.
  190. !! Examples: '`!`' or '`#`'.
  191. !! Default is `CK_'/!#'`.
  192. integer(IK) :: path_mode = 1_IK !! How the path strings are interpreted in the
  193. !! `get_by_path` routines:
  194. !!
  195. !! * 1 -- Default mode (see [[json_get_by_path_default]])
  196. !! * 2 -- as RFC 6901 "JSON Pointer" paths
  197. !! (see [[json_get_by_path_rfc6901]])
  198. !! * 3 -- JSONPath "bracket-notation"
  199. !! see [[json_get_by_path_jsonpath_bracket]])
  200. character(kind=CK,len=1) :: path_separator = dot !! The `path` separator to use
  201. !! in the "default" mode for
  202. !! the paths in the various
  203. !! `get_by_path` routines.
  204. !! Note: if `path_mode/=1`
  205. !! then this is ignored.
  206. logical(LK) :: compress_vectors = .false. !! If true, then arrays of integers,
  207. !! nulls, reals, & logicals are
  208. !! printed all on one line.
  209. !! [Note: `no_whitespace` will
  210. !! override this option if necessary]
  211. logical(LK) :: allow_duplicate_keys = .true. !! If False, then after parsing, if any
  212. !! duplicate keys are found, an error is
  213. !! thrown. A call to [[json_value_validate]]
  214. !! will also check for duplicates. If True
  215. !! [default] then no special checks are done
  216. logical(LK) :: escape_solidus = .false. !! If True then the solidus "`/`" is always escaped
  217. !! ("`\/`") when serializing JSON.
  218. !! If False [default], then it is not escaped.
  219. !! Note that this option does not affect parsing
  220. !! (both escaped and unescaped versions are still
  221. !! valid in all cases).
  222. integer(IK) :: null_to_real_mode = 2_IK !! if `strict_type_checking=false`:
  223. !!
  224. !! * 1 : an exception will be raised if
  225. !! try to retrieve a `null` as a real.
  226. !! * 2 : a `null` retrieved as a real
  227. !! will return NaN. [default]
  228. !! * 3 : a `null` retrieved as a real
  229. !! will return 0.0.
  230. logical(LK) :: non_normals_to_null = .false. !! How to serialize NaN, Infinity,
  231. !! and -Infinity real values:
  232. !!
  233. !! * If true : as JSON `null` values
  234. !! * If false : as strings (e.g., "NaN",
  235. !! "Infinity", "-Infinity") [default]
  236. logical(LK) :: use_quiet_nan = .true. !! if true [default], `null_to_real_mode=2`
  237. !! and [[string_to_real]] will use
  238. !! `ieee_quiet_nan` for NaN values. If false,
  239. !! `ieee_signaling_nan` will be used.
  240. logical(LK) :: strict_integer_type_checking = .true.
  241. !! * If false, when parsing JSON, if an integer numeric value
  242. !! cannot be converted to an integer (`integer(IK)`),
  243. !! then an attempt is then make to convert it
  244. !! to a real (`real(RK)`).
  245. !! * If true [default], an exception will be raised if an integer
  246. !! value cannot be read when parsing JSON.
  247. integer :: ichunk = 0 !! index in `chunk` for [[pop_char]]
  248. !! when `use_unformatted_stream=True`
  249. integer :: filesize = 0 !! the file size when when `use_unformatted_stream=True`
  250. character(kind=CK,len=:),allocatable :: chunk !! a chunk read from a stream file
  251. !! when `use_unformatted_stream=True`
  252. contains
  253. private
  254. !>
  255. ! Return a child of a [[json_value]] structure.
  256. generic,public :: get_child => json_value_get_child_by_index, &
  257. json_value_get_child,&
  258. MAYBEWRAP(json_value_get_child_by_name)
  259. procedure,private :: json_value_get_child_by_index
  260. procedure,private :: MAYBEWRAP(json_value_get_child_by_name)
  261. procedure,private :: json_value_get_child
  262. !>
  263. ! Add objects to a linked list of [[json_value]]s.
  264. !
  265. !@note It might make more sense to call this `add_child`.
  266. generic,public :: add => json_value_add_member, &
  267. MAYBEWRAP(json_value_add_null), &
  268. MAYBEWRAP(json_value_add_integer), &
  269. MAYBEWRAP(json_value_add_integer_vec), &
  270. #ifndef REAL32
  271. MAYBEWRAP(json_value_add_real32), &
  272. MAYBEWRAP(json_value_add_real32_vec), &
  273. #endif
  274. MAYBEWRAP(json_value_add_real), &
  275. MAYBEWRAP(json_value_add_real_vec), &
  276. #ifdef REAL128
  277. MAYBEWRAP(json_value_add_real64), &
  278. MAYBEWRAP(json_value_add_real64_vec), &
  279. #endif
  280. MAYBEWRAP(json_value_add_logical), &
  281. MAYBEWRAP(json_value_add_logical_vec), &
  282. MAYBEWRAP(json_value_add_string), &
  283. MAYBEWRAP(json_value_add_string_vec)
  284. #ifdef USE_UCS4
  285. generic,public :: add => json_value_add_string_name_ascii, &
  286. json_value_add_string_val_ascii, &
  287. json_value_add_string_vec_name_ascii, &
  288. json_value_add_string_vec_val_ascii
  289. #endif
  290. procedure,private :: json_value_add_member
  291. procedure,private :: MAYBEWRAP(json_value_add_integer)
  292. procedure,private :: MAYBEWRAP(json_value_add_null)
  293. procedure,private :: MAYBEWRAP(json_value_add_integer_vec)
  294. #ifndef REAL32
  295. procedure,private :: MAYBEWRAP(json_value_add_real32)
  296. procedure,private :: MAYBEWRAP(json_value_add_real32_vec)
  297. #endif
  298. procedure,private :: MAYBEWRAP(json_value_add_real)
  299. procedure,private :: MAYBEWRAP(json_value_add_real_vec)
  300. #ifdef REAL128
  301. procedure,private :: MAYBEWRAP(json_value_add_real64)
  302. procedure,private :: MAYBEWRAP(json_value_add_real64_vec)
  303. #endif
  304. procedure,private :: MAYBEWRAP(json_value_add_logical)
  305. procedure,private :: MAYBEWRAP(json_value_add_logical_vec)
  306. procedure,private :: MAYBEWRAP(json_value_add_string)
  307. procedure,private :: MAYBEWRAP(json_value_add_string_vec)
  308. #ifdef USE_UCS4
  309. procedure,private :: json_value_add_string_name_ascii
  310. procedure,private :: json_value_add_string_val_ascii
  311. procedure,private :: json_value_add_string_vec_name_ascii
  312. procedure,private :: json_value_add_string_vec_val_ascii
  313. #endif
  314. !>
  315. ! These are like the `add` methods, except if a variable with the
  316. ! same path is already present, then its value is simply updated.
  317. ! Note that currently, these only work for scalar variables.
  318. ! These routines can also change the variable's type (but an error will be
  319. ! thrown if the existing variable is not a scalar).
  320. !
  321. !### See also
  322. ! * [[json_core(type):add_by_path]] - this one can be used to change
  323. ! arrays and objects to scalars if so desired.
  324. !
  325. !@note Unlike some routines, the `found` output is not optional,
  326. ! so it doesn't present exceptions from being thrown.
  327. !
  328. !@note These have been mostly supplanted by the [[json_core(type):add_by_path]]
  329. ! methods, which do a similar thing (and can be used for
  330. ! scalars and vectors, etc.)
  331. generic,public :: update => MAYBEWRAP(json_update_logical),&
  332. #ifndef REAL32
  333. MAYBEWRAP(json_update_real32),&
  334. #endif
  335. MAYBEWRAP(json_update_real),&
  336. #ifdef REAL128
  337. MAYBEWRAP(json_update_real64),&
  338. #endif
  339. MAYBEWRAP(json_update_integer),&
  340. MAYBEWRAP(json_update_string)
  341. #ifdef USE_UCS4
  342. generic,public :: update => json_update_string_name_ascii,&
  343. json_update_string_val_ascii
  344. #endif
  345. procedure,private :: MAYBEWRAP(json_update_logical)
  346. #ifndef REAL32
  347. procedure,private :: MAYBEWRAP(json_update_real32)
  348. #endif
  349. procedure,private :: MAYBEWRAP(json_update_real)
  350. #ifdef REAL128
  351. procedure,private :: MAYBEWRAP(json_update_real64)
  352. #endif
  353. procedure,private :: MAYBEWRAP(json_update_integer)
  354. procedure,private :: MAYBEWRAP(json_update_string)
  355. #ifdef USE_UCS4
  356. procedure,private :: json_update_string_name_ascii
  357. procedure,private :: json_update_string_val_ascii
  358. #endif
  359. !>
  360. ! Add variables to a [[json_value]] linked list
  361. ! by specifying their paths.
  362. !
  363. !### Example
  364. !
  365. !````fortran
  366. ! use, intrinsic :: iso_fortran_env, only: output_unit
  367. ! use json_module, wp=>json_RK
  368. ! type(json_core) :: json
  369. ! type(json_value) :: p
  370. ! call json%create_object(p,'root') ! create the root
  371. ! ! now add some variables using the paths:
  372. ! call json%add_by_path(p,'inputs.t', 0.0_wp )
  373. ! call json%add_by_path(p,'inputs.x(1)', 100.0_wp)
  374. ! call json%add_by_path(p,'inputs.x(2)', 200.0_wp)
  375. ! call json%print(p) ! now print to console
  376. !````
  377. !
  378. !### Notes
  379. ! * This uses [[json_create_by_path]]
  380. !
  381. !### See also
  382. ! * The `json_core%update` methods.
  383. ! * [[json_create_by_path]]
  384. generic,public :: add_by_path => MAYBEWRAP(json_add_member_by_path),&
  385. MAYBEWRAP(json_add_integer_by_path),&
  386. #ifndef REAL32
  387. MAYBEWRAP(json_add_real32_by_path),&
  388. #endif
  389. MAYBEWRAP(json_add_real_by_path),&
  390. #ifdef REAL128
  391. MAYBEWRAP(json_add_real64_by_path),&
  392. #endif
  393. MAYBEWRAP(json_add_logical_by_path),&
  394. MAYBEWRAP(json_add_string_by_path),&
  395. MAYBEWRAP(json_add_integer_vec_by_path),&
  396. #ifndef REAL32
  397. MAYBEWRAP(json_add_real32_vec_by_path),&
  398. #endif
  399. MAYBEWRAP(json_add_real_vec_by_path),&
  400. #ifdef REAL128
  401. MAYBEWRAP(json_add_real64_vec_by_path),&
  402. #endif
  403. MAYBEWRAP(json_add_logical_vec_by_path),&
  404. MAYBEWRAP(json_add_string_vec_by_path)
  405. #ifdef USE_UCS4
  406. generic,public :: add_by_path => json_add_string_by_path_value_ascii,&
  407. json_add_string_by_path_path_ascii,&
  408. json_add_string_vec_by_path_value_ascii,&
  409. json_add_string_vec_by_path_path_ascii
  410. #endif
  411. procedure :: MAYBEWRAP(json_add_member_by_path)
  412. procedure :: MAYBEWRAP(json_add_integer_by_path)
  413. #ifndef REAL32
  414. procedure :: MAYBEWRAP(json_add_real32_by_path)
  415. #endif
  416. procedure :: MAYBEWRAP(json_add_real_by_path)
  417. #ifdef REAL128
  418. procedure :: MAYBEWRAP(json_add_real64_by_path)
  419. #endif
  420. procedure :: MAYBEWRAP(json_add_logical_by_path)
  421. procedure :: MAYBEWRAP(json_add_string_by_path)
  422. procedure :: MAYBEWRAP(json_add_integer_vec_by_path)
  423. #ifndef REAL32
  424. procedure :: MAYBEWRAP(json_add_real32_vec_by_path)
  425. #endif
  426. procedure :: MAYBEWRAP(json_add_real_vec_by_path)
  427. #ifdef REAL128
  428. procedure :: MAYBEWRAP(json_add_real64_vec_by_path)
  429. #endif
  430. procedure :: MAYBEWRAP(json_add_logical_vec_by_path)
  431. procedure :: MAYBEWRAP(json_add_string_vec_by_path)
  432. #ifdef USE_UCS4
  433. procedure :: json_add_string_by_path_value_ascii
  434. procedure :: json_add_string_by_path_path_ascii
  435. procedure :: json_add_string_vec_by_path_value_ascii
  436. procedure :: json_add_string_vec_by_path_path_ascii
  437. #endif
  438. !>
  439. ! Create a [[json_value]] linked list using the
  440. ! path to the variables. Optionally return a
  441. ! pointer to the variable.
  442. !
  443. ! (This will create a `null` variable)
  444. !
  445. !### See also
  446. ! * [[json_core(type):add_by_path]]
  447. generic,public :: create => MAYBEWRAP(json_create_by_path)
  448. procedure :: MAYBEWRAP(json_create_by_path)
  449. !>
  450. ! Get data from a [[json_value]] linked list.
  451. !
  452. !@note There are two versions (e.g. [[json_get_integer]] and [[json_get_integer_by_path]]).
  453. ! The first one gets the value from the [[json_value]] passed into the routine,
  454. ! while the second one gets the value from the [[json_value]] found by parsing the
  455. ! path. The path version is split up into unicode and non-unicode versions.
  456. generic,public :: get => &
  457. MAYBEWRAP(json_get_by_path), &
  458. json_get_integer, MAYBEWRAP(json_get_integer_by_path), &
  459. json_get_integer_vec, MAYBEWRAP(json_get_integer_vec_by_path), &
  460. #ifndef REAL32
  461. json_get_real32, MAYBEWRAP(json_get_real32_by_path), &
  462. json_get_real32_vec, MAYBEWRAP(json_get_real32_vec_by_path), &
  463. #endif
  464. json_get_real, MAYBEWRAP(json_get_real_by_path), &
  465. json_get_real_vec, MAYBEWRAP(json_get_real_vec_by_path), &
  466. #ifdef REAL128
  467. json_get_real64, MAYBEWRAP(json_get_real64_by_path), &
  468. json_get_real64_vec, MAYBEWRAP(json_get_real64_vec_by_path), &
  469. #endif
  470. json_get_logical, MAYBEWRAP(json_get_logical_by_path), &
  471. json_get_logical_vec, MAYBEWRAP(json_get_logical_vec_by_path), &
  472. json_get_string, MAYBEWRAP(json_get_string_by_path), &
  473. json_get_string_vec, MAYBEWRAP(json_get_string_vec_by_path), &
  474. json_get_alloc_string_vec, MAYBEWRAP(json_get_alloc_string_vec_by_path),&
  475. json_get_array, MAYBEWRAP(json_get_array_by_path)
  476. procedure,private :: json_get_integer
  477. procedure,private :: json_get_integer_vec
  478. #ifndef REAL32
  479. procedure,private :: json_get_real32
  480. procedure,private :: json_get_real32_vec
  481. #endif
  482. procedure,private :: json_get_real
  483. procedure,private :: json_get_real_vec
  484. #ifdef REAL128
  485. procedure,private :: json_get_real64
  486. procedure,private :: json_get_real64_vec
  487. #endif
  488. procedure,private :: json_get_logical
  489. procedure,private :: json_get_logical_vec
  490. procedure,private :: json_get_string
  491. procedure,private :: json_get_string_vec
  492. procedure,private :: json_get_alloc_string_vec
  493. procedure,private :: json_get_array
  494. procedure,private :: MAYBEWRAP(json_get_by_path)
  495. procedure,private :: MAYBEWRAP(json_get_integer_by_path)
  496. procedure,private :: MAYBEWRAP(json_get_integer_vec_by_path)
  497. #ifndef REAL32
  498. procedure,private :: MAYBEWRAP(json_get_real32_by_path)
  499. procedure,private :: MAYBEWRAP(json_get_real32_vec_by_path)
  500. #endif
  501. procedure,private :: MAYBEWRAP(json_get_real_by_path)
  502. procedure,private :: MAYBEWRAP(json_get_real_vec_by_path)
  503. #ifdef REAL128
  504. procedure,private :: MAYBEWRAP(json_get_real64_by_path)
  505. procedure,private :: MAYBEWRAP(json_get_real64_vec_by_path)
  506. #endif
  507. procedure,private :: MAYBEWRAP(json_get_logical_by_path)
  508. procedure,private :: MAYBEWRAP(json_get_logical_vec_by_path)
  509. procedure,private :: MAYBEWRAP(json_get_string_by_path)
  510. procedure,private :: MAYBEWRAP(json_get_string_vec_by_path)
  511. procedure,private :: MAYBEWRAP(json_get_array_by_path)
  512. procedure,private :: MAYBEWRAP(json_get_alloc_string_vec_by_path)
  513. procedure,private :: json_get_by_path_default
  514. procedure,private :: json_get_by_path_rfc6901
  515. procedure,private :: json_get_by_path_jsonpath_bracket
  516. !>
  517. ! Print the [[json_value]] to an output unit or file.
  518. !
  519. !### Example
  520. !
  521. !````fortran
  522. ! type(json_core) :: json
  523. ! type(json_value) :: p
  524. ! !...
  525. ! call json%print(p,'test.json') !this is [[json_print_to_filename]]
  526. !````
  527. generic,public :: print => json_print_to_console,&
  528. json_print_to_unit,&
  529. json_print_to_filename
  530. procedure :: json_print_to_console
  531. procedure :: json_print_to_unit
  532. procedure :: json_print_to_filename
  533. !>
  534. ! Destructor routine for a [[json_value]] pointer.
  535. ! This must be called explicitly if it is no longer needed,
  536. ! before it goes out of scope. Otherwise, a memory leak will result.
  537. !
  538. !### Example
  539. !
  540. ! Destroy the [[json_value]] pointer before the variable goes out of scope:
  541. !````fortran
  542. ! subroutine example1()
  543. ! type(json_core) :: json
  544. ! type(json_value),pointer :: p
  545. ! call json%create_object(p,'')
  546. ! call json%add(p,'year',2015)
  547. ! call json%print(p)
  548. ! call json%destroy(p)
  549. ! end subroutine example1
  550. !````
  551. !
  552. ! Note: it should NOT be called for a [[json_value]] pointer than has already been
  553. ! added to another [[json_value]] structure, since doing so may render the
  554. ! other structure invalid. Consider the following example:
  555. !````fortran
  556. ! subroutine example2(p)
  557. ! type(json_core) :: json
  558. ! type(json_value),pointer,intent(out) :: p
  559. ! type(json_value),pointer :: q
  560. ! call json%create_object(p,'')
  561. ! call json%add(p,'year',2015)
  562. ! call json%create_object(q,'q')
  563. ! call json%add(q,'val',1)
  564. ! call json%add(p, q) !add q to p structure
  565. ! ! do NOT call json%destroy(q) here, because q is
  566. ! ! now part of the output structure p. p should be destroyed
  567. ! ! somewhere upstream by the caller of this routine.
  568. ! nullify(q) !OK, but not strictly necessary
  569. ! end subroutine example2
  570. !````
  571. generic,public :: destroy => json_value_destroy,destroy_json_core
  572. procedure :: json_value_destroy
  573. procedure :: destroy_json_core
  574. !>
  575. ! If the child variable is present, then remove it.
  576. generic,public :: remove_if_present => MAYBEWRAP(json_value_remove_if_present)
  577. procedure :: MAYBEWRAP(json_value_remove_if_present)
  578. !>
  579. ! Allocate a [[json_value]] pointer and make it a real variable.
  580. ! The pointer should not already be allocated.
  581. !
  582. !### Example
  583. !
  584. !````fortran
  585. ! type(json_core) :: json
  586. ! type(json_value),pointer :: p
  587. ! call json%create_real(p,'value',1.0_RK)
  588. !````
  589. !
  590. !### Note
  591. ! * [[json_core(type):create_real]] is just an alias
  592. ! to this one for backward compatibility.
  593. generic,public :: create_real => MAYBEWRAP(json_value_create_real)
  594. procedure :: MAYBEWRAP(json_value_create_real)
  595. #ifndef REAL32
  596. generic,public :: create_real => MAYBEWRAP(json_value_create_real32)
  597. procedure :: MAYBEWRAP(json_value_create_real32)
  598. #endif
  599. #ifdef REAL128
  600. generic,public :: create_real => MAYBEWRAP(json_value_create_real64)
  601. procedure :: MAYBEWRAP(json_value_create_real64)
  602. #endif
  603. !>
  604. ! This is equivalent to [[json_core(type):create_real]],
  605. ! and is here only for backward compatibility.
  606. generic,public :: create_double => MAYBEWRAP(json_value_create_real)
  607. #ifndef REAL32
  608. generic,public :: create_double => MAYBEWRAP(json_value_create_real32)
  609. #endif
  610. #ifdef REAL128
  611. generic,public :: create_double => MAYBEWRAP(json_value_create_real64)
  612. #endif
  613. !>
  614. ! Allocate a [[json_value]] pointer and make it an array variable.
  615. ! The pointer should not already be allocated.
  616. !
  617. !### Example
  618. !
  619. !````fortran
  620. ! type(json_core) :: json
  621. ! type(json_value),pointer :: p
  622. ! call json%create_array(p,'arrayname')
  623. !````
  624. generic,public :: create_array => MAYBEWRAP(json_value_create_array)
  625. procedure :: MAYBEWRAP(json_value_create_array)
  626. !>
  627. ! Allocate a [[json_value]] pointer and make it an object variable.
  628. ! The pointer should not already be allocated.
  629. !
  630. !### Example
  631. !
  632. !````fortran
  633. ! type(json_core) :: json
  634. ! type(json_value),pointer :: p
  635. ! call json%create_object(p,'objectname')
  636. !````
  637. !
  638. !@note The name is not significant for the root structure or an array element.
  639. ! In those cases, an empty string can be used.
  640. generic,public :: create_object => MAYBEWRAP(json_value_create_object)
  641. procedure :: MAYBEWRAP(json_value_create_object)
  642. !>
  643. ! Allocate a json_value pointer and make it a null variable.
  644. ! The pointer should not already be allocated.
  645. !
  646. !### Example
  647. !
  648. !````fortran
  649. ! type(json_core) :: json
  650. ! type(json_value),pointer :: p
  651. ! call json%create_null(p,'value')
  652. !````
  653. generic,public :: create_null => MAYBEWRAP(json_value_create_null)
  654. procedure :: MAYBEWRAP(json_value_create_null)
  655. !>
  656. ! Allocate a json_value pointer and make it a string variable.
  657. ! The pointer should not already be allocated.
  658. !
  659. !### Example
  660. !
  661. !````fortran
  662. ! type(json_core) :: json
  663. ! type(json_value),pointer :: p
  664. ! call json%create_string(p,'value','foobar')
  665. !````
  666. generic,public :: create_string => MAYBEWRAP(json_value_create_string)
  667. procedure :: MAYBEWRAP(json_value_create_string)
  668. !>
  669. ! Allocate a json_value pointer and make it an integer variable.
  670. ! The pointer should not already be allocated.
  671. !
  672. !### Example
  673. !
  674. !````fortran
  675. ! type(json_core) :: json
  676. ! type(json_value),pointer :: p
  677. ! call json%create_integer(p,42,'value')
  678. !````
  679. generic,public :: create_integer => MAYBEWRAP(json_value_create_integer)
  680. procedure :: MAYBEWRAP(json_value_create_integer)
  681. !>
  682. ! Allocate a json_value pointer and make it a logical variable.
  683. ! The pointer should not already be allocated.
  684. !
  685. !### Example
  686. !
  687. !````fortran
  688. ! type(json_core) :: json
  689. ! type(json_value),pointer :: p
  690. ! call json%create_logical(p,'value',.true.)
  691. !````
  692. generic,public :: create_logical => MAYBEWRAP(json_value_create_logical)
  693. procedure :: MAYBEWRAP(json_value_create_logical)
  694. !>
  695. ! Parse the JSON file and populate the [[json_value]] tree.
  696. generic,public :: load => json_parse_file
  697. procedure :: json_parse_file
  698. !>
  699. ! Print the [[json_value]] structure to an allocatable string
  700. procedure,public :: serialize => json_value_to_string
  701. !>
  702. ! The same as `serialize`, but only here for backward compatibility
  703. procedure,public :: print_to_string => json_value_to_string
  704. !>
  705. ! Parse the JSON string and populate the [[json_value]] tree.
  706. generic,public :: deserialize => MAYBEWRAP(json_parse_string)
  707. procedure :: MAYBEWRAP(json_parse_string)
  708. !>
  709. ! Same as `load` and `deserialize` but only here for backward compatibility.
  710. generic,public :: parse => json_parse_file, &
  711. MAYBEWRAP(json_parse_string)
  712. !>
  713. ! Throw an exception.
  714. generic,public :: throw_exception => MAYBEWRAP(json_throw_exception)
  715. procedure :: MAYBEWRAP(json_throw_exception)
  716. !>
  717. ! Rename a [[json_value]] variable.
  718. generic,public :: rename => MAYBEWRAP(json_value_rename),&
  719. MAYBEWRAP(json_rename_by_path)
  720. procedure :: MAYBEWRAP(json_value_rename)
  721. procedure :: MAYBEWRAP(json_rename_by_path)
  722. #ifdef USE_UCS4
  723. generic,public :: rename => json_rename_by_path_name_ascii,&
  724. json_rename_by_path_path_ascii
  725. procedure :: json_rename_by_path_name_ascii
  726. procedure :: json_rename_by_path_path_ascii
  727. #endif
  728. !>
  729. ! get info about a [[json_value]]
  730. generic,public :: info => json_info, MAYBEWRAP(json_info_by_path)
  731. procedure :: json_info
  732. procedure :: MAYBEWRAP(json_info_by_path)
  733. !>
  734. ! get string info about a [[json_value]]
  735. generic,public :: string_info => json_string_info
  736. procedure :: json_string_info
  737. !>
  738. ! get matrix info about a [[json_value]]
  739. generic,public :: matrix_info => json_matrix_info, MAYBEWRAP(json_matrix_info_by_path)
  740. procedure :: json_matrix_info
  741. procedure :: MAYBEWRAP(json_matrix_info_by_path)
  742. !>
  743. ! insert a new element after an existing one,
  744. ! updating the JSON structure accordingly
  745. generic,public :: insert_after => json_value_insert_after, &
  746. json_value_insert_after_child_by_index
  747. procedure :: json_value_insert_after
  748. procedure :: json_value_insert_after_child_by_index
  749. !>
  750. ! get the path to a JSON variable in a structure:
  751. generic,public :: get_path => MAYBEWRAP(json_get_path)
  752. procedure :: MAYBEWRAP(json_get_path)
  753. !>
  754. ! verify if a path is valid
  755. ! (i.e., a variable with this path exists in the file).
  756. generic,public :: valid_path => MAYBEWRAP(json_valid_path)
  757. procedure :: MAYBEWRAP(json_valid_path)
  758. procedure,public :: remove => json_value_remove !! Remove a [[json_value]] from a
  759. !! linked-list structure.
  760. procedure,public :: replace => json_value_replace !! Replace a [[json_value]] in a
  761. !! linked-list structure.
  762. procedure,public :: reverse => json_value_reverse !! Reverse the order of the children
  763. !! of an array of object.
  764. procedure,public :: check_for_errors => json_check_for_errors !! check for error and get error message
  765. procedure,public :: clear_exceptions => json_clear_exceptions !! clear exceptions
  766. procedure,public :: count => json_count !! count the number of children
  767. procedure,public :: clone => json_clone !! clone a JSON structure (deep copy)
  768. procedure,public :: failed => json_failed !! check for error
  769. procedure,public :: get_parent => json_get_parent !! get pointer to json_value parent
  770. procedure,public :: get_next => json_get_next !! get pointer to json_value next
  771. procedure,public :: get_previous => json_get_previous !! get pointer to json_value previous
  772. procedure,public :: get_tail => json_get_tail !! get pointer to json_value tail
  773. procedure,public :: initialize => json_initialize !! to initialize some parsing parameters
  774. procedure,public :: traverse => json_traverse !! to traverse all elements of a JSON
  775. !! structure
  776. procedure,public :: print_error_message => json_print_error_message !! simply routine to print error
  777. !! messages
  778. procedure,public :: swap => json_value_swap !! Swap two [[json_value]] pointers
  779. !! in a structure (or two different
  780. !! structures).
  781. procedure,public :: is_child_of => json_value_is_child_of !! Check if a [[json_value]] is a
  782. !! descendant of another.
  783. procedure,public :: validate => json_value_validate !! Check that a [[json_value]] linked
  784. !! list is valid (i.e., is properly
  785. !! constructed). This may be useful
  786. !! if it has been constructed externally.
  787. procedure,public :: check_for_duplicate_keys &
  788. => json_check_all_for_duplicate_keys !! Check entire JSON structure
  789. !! for duplicate keys (recursively)
  790. procedure,public :: check_children_for_duplicate_keys &
  791. => json_check_children_for_duplicate_keys !! Check a `json_value` object's
  792. !! children for duplicate keys
  793. !other private routines:
  794. procedure :: name_equal
  795. procedure :: name_strings_equal
  796. procedure :: json_value_print
  797. procedure :: string_to_int
  798. procedure :: string_to_dble
  799. procedure :: prepare_parser => json_prepare_parser
  800. procedure :: parse_end => json_parse_end
  801. procedure :: parse_value
  802. procedure :: parse_number
  803. procedure :: parse_string
  804. procedure :: parse_for_chars
  805. procedure :: parse_object
  806. procedure :: parse_array
  807. procedure :: annotate_invalid_json
  808. procedure :: pop_char
  809. procedure :: push_char
  810. procedure :: get_current_line_from_file_stream
  811. procedure,nopass :: get_current_line_from_file_sequential
  812. procedure :: convert
  813. procedure :: to_string
  814. procedure :: to_logical
  815. procedure :: to_integer
  816. procedure :: to_real
  817. procedure :: to_null
  818. procedure :: to_object
  819. procedure :: to_array
  820. procedure,nopass :: json_value_clone_func
  821. procedure :: is_vector => json_is_vector
  822. end type json_core
  823. !*********************************************************
  824. !*********************************************************
  825. !>
  826. ! Structure constructor to initialize a
  827. ! [[json_core(type)]] object
  828. !
  829. !### Example
  830. !
  831. !```fortran
  832. ! type(json_file) :: json_core
  833. ! json_core = json_core()
  834. !```
  835. interface json_core
  836. module procedure initialize_json_core
  837. end interface
  838. !*********************************************************
  839. !*************************************************************************************
  840. abstract interface
  841. subroutine json_array_callback_func(json, element, i, count)
  842. !! Array element callback function. Used by [[json_get_array]]
  843. import :: json_value,json_core,IK
  844. implicit none
  845. class(json_core),intent(inout) :: json
  846. type(json_value),pointer,intent(in) :: element
  847. integer(IK),intent(in) :: i !! index
  848. integer(IK),intent(in) :: count !! size of array
  849. end subroutine json_array_callback_func
  850. subroutine json_traverse_callback_func(json,p,finished)
  851. !! Callback function used by [[json_traverse]]
  852. import :: json_value,json_core,LK
  853. implicit none
  854. class(json_core),intent(inout) :: json
  855. type(json_value),pointer,intent(in) :: p
  856. logical(LK),intent(out) :: finished !! set true to stop traversing
  857. end subroutine json_traverse_callback_func
  858. end interface
  859. public :: json_array_callback_func
  860. public :: json_traverse_callback_func
  861. !*************************************************************************************
  862. contains
  863. !*****************************************************************************************
  864. !*****************************************************************************************
  865. !> author: Jacob Williams
  866. ! date: 4/17/2016
  867. !
  868. ! Destructor for the [[json_core(type)]] type.
  869. subroutine destroy_json_core(me)
  870. implicit none
  871. class(json_core),intent(out) :: me
  872. end subroutine destroy_json_core
  873. !*****************************************************************************************
  874. !*****************************************************************************************
  875. !> author: Jacob Williams
  876. ! date: 4/26/2016
  877. !
  878. ! Function constructor for a [[json_core(type)]].
  879. ! This is just a wrapper for [[json_initialize]].
  880. !
  881. !@note [[initialize_json_core]], [[json_initialize]],
  882. ! [[initialize_json_core_in_file]], and [[initialize_json_file]]
  883. ! all have a similar interface.
  884. function initialize_json_core(&
  885. #include "json_initialize_dummy_arguments.inc"
  886. ) result(json_core_object)
  887. implicit none
  888. type(json_core) :: json_core_object
  889. #include "json_initialize_arguments.inc"
  890. call json_core_object%initialize(&
  891. #include "json_initialize_dummy_arguments.inc"
  892. )
  893. end function initialize_json_core
  894. !*****************************************************************************************
  895. !*****************************************************************************************
  896. !> author: Jacob Williams
  897. ! date: 12/4/2013
  898. !
  899. ! Initialize the [[json_core(type)]] instance.
  900. !
  901. ! The routine may be called before any of the [[json_core(type)]] methods are used in
  902. ! order to specify certain parameters. If it is not called, then the defaults
  903. ! are used. This routine is also called internally by various routines.
  904. ! It can also be called to clear exceptions, or to reset some
  905. ! of the variables (note that only the arguments present are changed).
  906. !
  907. !### Modified
  908. ! * Izaak Beekman : 02/24/2015
  909. !
  910. !@note [[initialize_json_core]], [[json_initialize]],
  911. ! [[initialize_json_core_in_file]], and [[initialize_json_file]]
  912. ! all have a similar interface.
  913. subroutine json_initialize(me,&
  914. #include "json_initialize_dummy_arguments.inc"
  915. )
  916. implicit none
  917. class(json_core),intent(inout) :: me
  918. #include "json_initialize_arguments.inc"
  919. character(kind=CDK,len=10) :: w !! max string length
  920. character(kind=CDK,len=10) :: d !! real precision digits
  921. character(kind=CDK,len=10) :: e !! real exponent digits
  922. character(kind=CDK,len=2) :: sgn !! sign flag: `ss` or `sp`
  923. character(kind=CDK,len=2) :: rl_edit_desc !! `G`, `E`, `EN`, or `ES`
  924. integer(IK) :: istat !! `iostat` flag for
  925. !! write statements
  926. logical(LK) :: sgn_prnt !! print sign flag
  927. character(kind=CK,len=max_integer_str_len) :: istr !! for integer to
  928. !! string conversion
  929. !reset exception to false:
  930. call me%clear_exceptions()
  931. !Just in case, clear these global variables also:
  932. me%pushed_index = 0
  933. me%pushed_char = CK_''
  934. me%char_count = 0
  935. me%line_count = 1
  936. me%ipos = 1
  937. if (use_unformatted_stream) then
  938. me%filesize = 0
  939. me%ichunk = 0
  940. me%chunk = repeat(space, stream_chunk_size) ! default chunk size
  941. end if
  942. #ifdef USE_UCS4
  943. ! reopen stdout and stderr with utf-8 encoding
  944. open(output_unit,encoding='utf-8')
  945. open(error_unit, encoding='utf-8')
  946. #endif
  947. !various optional inputs:
  948. if (present(spaces_per_tab)) &
  949. me%spaces_per_tab = spaces_per_tab
  950. if (present(stop_on_error)) &
  951. me%stop_on_error = stop_on_error
  952. if (present(verbose)) &
  953. me%is_verbose = verbose
  954. if (present(strict_type_checking)) &
  955. me%strict_type_checking = strict_type_checking
  956. if (present(trailing_spaces_significant)) &
  957. me%trailing_spaces_significant = trailing_spaces_significant
  958. if (present(case_sensitive_keys)) &
  959. me%case_sensitive_keys = case_sensitive_keys
  960. if (present(no_whitespace)) &
  961. me%no_whitespace = no_whitespace
  962. if (present(unescape_strings)) &
  963. me%unescaped_strings = unescape_strings
  964. if (present(path_mode)) then
  965. if (path_mode==1_IK .or. path_mode==2_IK .or. path_mode==3_IK) then
  966. me%path_mode = path_mode
  967. else
  968. me%path_mode = 1_IK ! just to have a valid value
  969. call me%throw_exception('Invalid path_mode.')
  970. end if
  971. end if
  972. ! if we are allowing comments in the file:
  973. ! [an empty string disables comments]
  974. if (present(comment_char)) then
  975. me%allow_comments = comment_char/=CK_''
  976. me%comment_char = trim(adjustl(comment_char))
  977. end if
  978. ! path separator:
  979. if (present(path_separator)) then
  980. me%path_separator = path_separator
  981. end if
  982. ! printing vectors in compressed form:
  983. if (present(compress_vectors)) then
  984. me%compress_vectors = compress_vectors
  985. end if
  986. ! checking for duplicate keys:
  987. if (present(allow_duplicate_keys)) then
  988. me%allow_duplicate_keys = allow_duplicate_keys
  989. end if
  990. ! if escaping the forward slash:
  991. if (present(escape_solidus)) then
  992. me%escape_solidus = escape_solidus
  993. end if
  994. ! how to handle null to read conversions:
  995. if (present(null_to_real_mode)) then
  996. select case (null_to_real_mode)
  997. case(1_IK:3_IK)
  998. me%null_to_real_mode = null_to_real_mode
  999. case default
  1000. me%null_to_real_mode = 2_IK ! just to have a valid value
  1001. call integer_to_string(null_to_real_mode,int_fmt,istr)
  1002. call me%throw_exception('Invalid null_to_real_mode: '//istr)
  1003. end select
  1004. end if
  1005. ! how to handle NaN and Infinities:
  1006. if (present(non_normal_mode)) then
  1007. select case (non_normal_mode)
  1008. case(1_IK) ! use strings
  1009. me%non_normals_to_null = .false.
  1010. case(2_IK) ! use null
  1011. me%non_normals_to_null = .true.
  1012. case default
  1013. call integer_to_string(non_normal_mode,int_fmt,istr)
  1014. call me%throw_exception('Invalid non_normal_mode: '//istr)
  1015. end select
  1016. end if
  1017. if (present(use_quiet_nan)) then
  1018. me%use_quiet_nan = use_quiet_nan
  1019. end if
  1020. if (present(strict_integer_type_checking)) then
  1021. me%strict_integer_type_checking = strict_integer_type_checking
  1022. end if
  1023. !Set the format for real numbers:
  1024. ! [if not changing it, then it remains the same]
  1025. if ( (.not. allocated(me%real_fmt)) .or. & ! if this hasn't been done yet
  1026. present(compact_reals) .or. &
  1027. present(print_signs) .or. &
  1028. present(real_format) ) then
  1029. !allow the special case where real format is '*':
  1030. ! [this overrides the other options]
  1031. if (present(real_format)) then
  1032. if (real_format==star) then
  1033. if (present(compact_reals)) then
  1034. ! we will also allow for compact reals with
  1035. ! '*' format, if both arguments are present.
  1036. me%compact_real = compact_reals
  1037. else
  1038. me%compact_real = .false.
  1039. end if
  1040. me%real_fmt = star
  1041. return
  1042. end if
  1043. end if
  1044. if (present(compact_reals)) me%compact_real = compact_reals
  1045. !set defaults
  1046. sgn_prnt = .false.
  1047. if ( present( print_signs) ) sgn_prnt = print_signs
  1048. if ( sgn_prnt ) then
  1049. sgn = 'sp'
  1050. else
  1051. sgn = 'ss'
  1052. end if
  1053. rl_edit_desc = 'E'
  1054. if ( present( real_format ) ) then
  1055. select case ( real_format )
  1056. case ('g','G','e','E','en','EN','es','ES')
  1057. rl_edit_desc = real_format
  1058. case default
  1059. call me%throw_exception('Invalid real format, "' // &
  1060. trim(real_format) // '", passed to json_initialize.'// &
  1061. new_line('a') // 'Acceptable formats are: "G", "E", "EN", and "ES".' )
  1062. end select
  1063. end if
  1064. ! set the default output/input format for reals:
  1065. write(w,'(ss,I0)',iostat=istat) max_numeric_str_len
  1066. if (istat==0) write(d,'(ss,I0)',iostat=istat) real_precision
  1067. if (istat==0) write(e,'(ss,I0)',iostat=istat) real_exponent_digits
  1068. if (istat==0) then
  1069. me%real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) //&
  1070. trim(w) // '.' // trim(d) // 'E' // trim(e) // ')'
  1071. else
  1072. me%real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) // &
  1073. '27.17E4)' !just use this one (should never happen)
  1074. end if
  1075. end if
  1076. end subroutine json_initialize
  1077. !*****************************************************************************************
  1078. !*****************************************************************************************
  1079. !> author: Jacob Williams
  1080. !
  1081. ! Returns true if `name` is equal to `p%name`, using the specified
  1082. ! settings for case sensitivity and trailing whitespace.
  1083. !
  1084. !### History
  1085. ! * 4/30/2016 : original version
  1086. ! * 8/25/2017 : now just a wrapper for [[name_strings_equal]]
  1087. function name_equal(json,p,name) result(is_equal)
  1088. implicit none
  1089. class(json_core),intent(inout) :: json
  1090. type(json_value),intent(in) :: p !! the json object
  1091. character(kind=CK,len=*),intent(in) :: name !! the name to check for
  1092. logical(LK) :: is_equal !! true if the string are
  1093. !! lexically equal
  1094. if (allocated(p%name)) then
  1095. ! call the low-level routines for the name strings:
  1096. is_equal = json%name_strings_equal(p%name,name)
  1097. else
  1098. is_equal = name == CK_'' ! check a blank name
  1099. end if
  1100. end function name_equal
  1101. !*****************************************************************************************
  1102. !*****************************************************************************************
  1103. !> author: Jacob Williams
  1104. ! date: 8/25/2017
  1105. !
  1106. ! Returns true if the name strings `name1` is equal to `name2`, using
  1107. ! the specified settings for case sensitivity and trailing whitespace.
  1108. function name_strings_equal(json,name1,name2) result(is_equal)
  1109. implicit none
  1110. class(json_core),intent(inout) :: json
  1111. character(kind=CK,len=*),intent(in) :: name1 !! the name to check
  1112. character(kind=CK,len=*),intent(in) :: name2 !! the name to check
  1113. logical(LK) :: is_equal !! true if the string are
  1114. !! lexically equal
  1115. !must be the same length if we are treating
  1116. !trailing spaces as significant, so do a
  1117. !quick test of this first:
  1118. if (json%trailing_spaces_significant) then
  1119. is_equal = len(name1) == len(name2)
  1120. if (.not. is_equal) return
  1121. end if
  1122. if (json%case_sensitive_keys) then
  1123. is_equal = name1 == name2
  1124. else
  1125. is_equal = lowercase_string(name1) == lowercase_string(name2)
  1126. end if
  1127. end function name_strings_equal
  1128. !*****************************************************************************************
  1129. !*****************************************************************************************
  1130. !> author: Jacob Williams
  1131. ! date: 10/31/2015
  1132. !
  1133. ! Create a deep copy of a [[json_value]] linked-list structure.
  1134. !
  1135. !### Notes
  1136. !
  1137. ! * If `from` has children, then they are also cloned.
  1138. ! * The parent of `from` is not linked to `to`.
  1139. ! * If `from` is an element of an array, then the previous and
  1140. ! next entries are not cloned (only that element and it's children, if any).
  1141. !
  1142. !### Example
  1143. !
  1144. !````fortran
  1145. ! program test
  1146. ! use json_module
  1147. ! implicit none
  1148. ! type(json_core) :: json
  1149. ! type(json_value),pointer :: j1, j2
  1150. ! call json%load('../files/inputs/test1.json',j1)
  1151. ! call json%clone(j1,j2) !now have two independent copies
  1152. ! call json%destroy(j1) !destroys j1, but j2 remains
  1153. ! call json%print(j2,'j2.json')
  1154. ! call json%destroy(j2)
  1155. ! end program test
  1156. !````
  1157. subroutine json_clone(json,from,to)
  1158. implicit none
  1159. class(json_core),intent(inout) :: json
  1160. type(json_value),pointer :: from !! this is the structure to clone
  1161. type(json_value),pointer :: to !! the clone is put here
  1162. !! (it must not already be associated)
  1163. !call the main function:
  1164. call json%json_value_clone_func(from,to)
  1165. end subroutine json_clone
  1166. !*****************************************************************************************
  1167. !*****************************************************************************************
  1168. !> author: Jacob Williams
  1169. ! date: 10/31/2015
  1170. !
  1171. ! Recursive deep copy function called by [[json_clone]].
  1172. !
  1173. !@note If new data is added to the [[json_value]] type,
  1174. ! then this would need to be updated.
  1175. recursive subroutine json_value_clone_func(from,to,parent,previous,tail)
  1176. implicit none
  1177. type(json_value),pointer :: from !! this is the structure to clone
  1178. type(json_value),pointer :: to !! the clone is put here (it
  1179. !! must not already be associated)
  1180. type(json_value),pointer,optional :: parent !! to%parent
  1181. type(json_value),pointer,optional :: previous !! to%previous
  1182. logical,optional :: tail !! if "to" is the tail of
  1183. !! its parent's children
  1184. nullify(to)
  1185. if (associated(from)) then
  1186. allocate(to)
  1187. !copy over the data variables:
  1188. ! [note: the allocate() statements don't work here for the
  1189. ! deferred-length characters in gfortran-4.9]
  1190. if (allocated(from%name)) to%name = from%name
  1191. if (allocated(from%dbl_value)) allocate(to%dbl_value,source=from%dbl_value)
  1192. if (allocated(from%log_value)) allocate(to%log_value,source=from%log_value)
  1193. if (allocated(from%str_value)) to%str_value = from%str_value
  1194. if (allocated(from%int_value)) allocate(to%int_value,source=from%int_value)
  1195. to%var_type = from%var_type
  1196. to%n_children = from%n_children
  1197. ! allocate and associate the pointers as necessary:
  1198. if (present(parent)) to%parent => parent
  1199. if (present(previous)) to%previous => previous
  1200. if (present(tail)) then
  1201. if (tail .and. associated(to%parent)) to%parent%tail => to
  1202. end if
  1203. if (associated(from%next) .and. associated(to%parent)) then
  1204. ! we only clone the next entry in an array
  1205. ! if the parent has also been cloned
  1206. call json_value_clone_func(from = from%next,&
  1207. to = to%next,&
  1208. previous = to,&
  1209. parent = to%parent,&
  1210. tail = (.not. associated(from%next%next)))
  1211. end if
  1212. if (associated(from%children)) then
  1213. call json_value_clone_func(from = from%children,&
  1214. to = to%children,&
  1215. parent = to,&
  1216. tail = (.not. associated(from%children%next)))
  1217. end if
  1218. end if
  1219. end subroutine json_value_clone_func
  1220. !*****************************************************************************************
  1221. !*****************************************************************************************
  1222. !> author: Jacob Williams
  1223. !
  1224. ! Destroy the data within a [[json_value]], and reset type to `json_unknown`.
  1225. pure subroutine destroy_json_data(d)
  1226. implicit none
  1227. type(json_value),intent(inout) :: d
  1228. d%var_type = json_unknown
  1229. if (allocated(d%log_value)) deallocate(d%log_value)
  1230. if (allocated(d%int_value)) deallocate(d%int_value)
  1231. if (allocated(d%dbl_value)) deallocate(d%dbl_value)
  1232. if (allocated(d%str_value)) deallocate(d%str_value)
  1233. end subroutine destroy_json_data
  1234. !*****************************************************************************************
  1235. !*****************************************************************************************
  1236. !> author: Jacob Williams
  1237. ! date: 2/13/2014
  1238. !
  1239. ! Returns information about a [[json_value]].
  1240. subroutine json_info(json,p,var_type,n_children,name)
  1241. implicit none
  1242. class(json_core),intent(inout) :: json
  1243. type(json_value),pointer :: p
  1244. integer(IK),intent(out),optional :: var_type !! variable type
  1245. integer(IK),intent(out),optional :: n_children !! number of children
  1246. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1247. if (.not. json%exception_thrown .and. associated(p)) then
  1248. if (present(var_type)) var_type = p%var_type
  1249. if (present(n_children)) n_children = json%count(p)
  1250. if (present(name)) then
  1251. if (allocated(p%name)) then
  1252. name = p%name
  1253. else
  1254. name = CK_''
  1255. end if
  1256. end if
  1257. else ! error
  1258. if (.not. json%exception_thrown) then
  1259. call json%throw_exception('Error in json_info: '//&
  1260. 'pointer is not associated.' )
  1261. end if
  1262. if (present(var_type)) var_type = json_unknown
  1263. if (present(n_children)) n_children = 0
  1264. if (present(name)) name = CK_''
  1265. end if
  1266. end subroutine json_info
  1267. !*****************************************************************************************
  1268. !*****************************************************************************************
  1269. !> author: Jacob Williams
  1270. ! date: 12/18/2016
  1271. !
  1272. ! Returns information about character strings returned from a [[json_value]].
  1273. subroutine json_string_info(json,p,ilen,max_str_len,found)
  1274. implicit none
  1275. class(json_core),intent(inout) :: json
  1276. type(json_value),pointer :: p
  1277. integer(IK),dimension(:),allocatable,intent(out),optional :: ilen !! if `p` is an array, this
  1278. !! is the actual length
  1279. !! of each character
  1280. !! string in the array.
  1281. !! if not an array, this
  1282. !! is returned unallocated.
  1283. integer(IK),intent(out),optional :: max_str_len !! The maximum length required to
  1284. !! hold the string representation returned
  1285. !! by a call to a `get` routine. If a scalar,
  1286. !! this is just the length of the scalar. If
  1287. !! a vector, this is the maximum length of
  1288. !! any element.
  1289. logical(LK),intent(out),optional :: found !! true if there were no errors.
  1290. !! if not present, an error will
  1291. !! throw an exception
  1292. character(kind=CK,len=:),allocatable :: cval !! for getting values as strings.
  1293. logical(LK) :: initialized !! if the output array has been sized
  1294. logical(LK) :: get_max_len !! if we are returning the `max_str_len`
  1295. logical(LK) :: get_ilen !! if we are returning the `ilen` array
  1296. integer(IK) :: var_type !! variable type
  1297. get_max_len = present(max_str_len)
  1298. get_ilen = present(ilen)
  1299. if (.not. json%exception_thrown) then
  1300. if (present(found)) found = .true.
  1301. initialized = .false.
  1302. if (get_max_len) max_str_len = 0
  1303. select case (p%var_type)
  1304. case (json_array) ! it's an array
  1305. ! call routine for each element
  1306. call json%get(p, array_callback=get_string_lengths)
  1307. case default ! not an array
  1308. if (json%strict_type_checking) then
  1309. ! only allowing strings to be returned
  1310. ! as strings, so we can check size directly
  1311. call json%info(p,var_type=var_type)
  1312. if (var_type==json_string) then
  1313. if (allocated(p%str_value) .and. get_max_len) &
  1314. max_str_len = len(p%str_value)
  1315. else
  1316. ! it isn't a string, so there is no length
  1317. call json%throw_exception('Error in json_string_info: '//&
  1318. 'When strict_type_checking is true '//&
  1319. 'the variable must be a character string.',&
  1320. found)
  1321. end if
  1322. else
  1323. ! in this case, we have to get the value
  1324. ! as a string to know what size it is.
  1325. call json%get(p, value=cval)
  1326. if (.not. json%exception_thrown) then
  1327. if (allocated(cval) .and. get_max_len) &
  1328. max_str_len = len(cval)
  1329. end if
  1330. end if
  1331. end select
  1332. end if
  1333. if (json%exception_thrown) then
  1334. if (present(found)) then
  1335. call json%clear_exceptions()
  1336. found = .false.
  1337. end if
  1338. if (get_max_len) max_str_len = 0
  1339. if (get_ilen) then
  1340. if (allocated(ilen)) deallocate(ilen)
  1341. end if
  1342. end if
  1343. contains
  1344. subroutine get_string_lengths(json, element, i, count)
  1345. !! callback function to call for each element in the array.
  1346. implicit none
  1347. class(json_core),intent(inout) :: json
  1348. type(json_value),pointer,intent(in) :: element
  1349. integer(IK),intent(in) :: i !! index
  1350. integer(IK),intent(in) :: count !! size of array
  1351. character(kind=CK,len=:),allocatable :: cval
  1352. integer(IK) :: var_type
  1353. if (json%exception_thrown) return
  1354. if (.not. initialized) then
  1355. if (get_ilen) allocate(ilen(count))
  1356. initialized = .true.
  1357. end if
  1358. if (json%strict_type_checking) then
  1359. ! only allowing strings to be returned
  1360. ! as strings, so we can check size directly
  1361. call json%info(element,var_type=var_type)
  1362. if (var_type==json_string) then
  1363. if (allocated(element%str_value)) then
  1364. if (get_max_len) then
  1365. if (len(element%str_value)>max_str_len) &
  1366. max_str_len = len(element%str_value)
  1367. end if
  1368. if (get_ilen) ilen(i) = len(element%str_value)
  1369. else
  1370. if (get_ilen) ilen(i) = 0
  1371. end if
  1372. else
  1373. ! it isn't a string, so there is no length
  1374. call json%throw_exception('Error in json_string_info: '//&
  1375. 'When strict_type_checking is true '//&
  1376. 'the array must contain only '//&
  1377. 'character strings.',found)
  1378. end if
  1379. else
  1380. ! in this case, we have to get the value
  1381. ! as a string to know what size it is.
  1382. call json%get(element, value=cval)
  1383. if (json%exception_thrown) return
  1384. if (allocated(cval)) then
  1385. if (get_max_len) then
  1386. if (len(cval)>max_str_len) max_str_len = len(cval)
  1387. end if
  1388. if (get_ilen) ilen(i) = len(cval)
  1389. else
  1390. if (get_ilen) ilen(i) = 0
  1391. end if
  1392. end if
  1393. end subroutine get_string_lengths
  1394. end subroutine json_string_info
  1395. !*****************************************************************************************
  1396. !*****************************************************************************************
  1397. !
  1398. ! Returns information about a [[json_value]], given the path.
  1399. !
  1400. !### See also
  1401. ! * [[json_info]]
  1402. !
  1403. !@note If `found` is present, no exceptions will be thrown if an
  1404. ! error occurs. Otherwise, an exception will be thrown if the
  1405. ! variable is not found.
  1406. subroutine json_info_by_path(json,p,path,found,var_type,n_children,name)
  1407. implicit none
  1408. class(json_core),intent(inout) :: json
  1409. type(json_value),pointer,intent(in) :: p !! a JSON linked list
  1410. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  1411. logical(LK),intent(out),optional :: found !! true if it was found
  1412. integer(IK),intent(out),optional :: var_type !! variable type
  1413. integer(IK),intent(out),optional :: n_children !! number of children
  1414. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1415. type(json_value),pointer :: p_var !! temporary pointer
  1416. logical(LK) :: ok !! if the variable was found
  1417. #if defined __GFORTRAN__
  1418. character(kind=CK,len=:),allocatable :: p_name !! temporary variable for getting name
  1419. #endif
  1420. call json%get(p,path,p_var,found)
  1421. !check if it was found:
  1422. if (present(found)) then
  1423. ok = found
  1424. else
  1425. ok = .not. json%exception_thrown
  1426. end if
  1427. if (.not. ok) then
  1428. if (present(var_type)) var_type = json_unknown
  1429. if (present(n_children)) n_children = 0
  1430. if (present(name)) name = CK_''
  1431. else
  1432. !get info:
  1433. #if defined __GFORTRAN__
  1434. call json%info(p_var,var_type,n_children)
  1435. if (present(name)) then !workaround for gfortran bug
  1436. if (allocated(p_var%name)) then
  1437. p_name = p_var%name
  1438. name = p_name
  1439. else
  1440. name = CK_''
  1441. end if
  1442. end if
  1443. #else
  1444. call json%info(p_var,var_type,n_children,name)
  1445. #endif
  1446. end if
  1447. end subroutine json_info_by_path
  1448. !*****************************************************************************************
  1449. !*****************************************************************************************
  1450. !>
  1451. ! Alternate version of [[json_info_by_path]] where "path" is kind=CDK.
  1452. subroutine wrap_json_info_by_path(json,p,path,found,var_type,n_children,name)
  1453. implicit none
  1454. class(json_core),intent(inout) :: json
  1455. type(json_value),pointer,intent(in) :: p !! a JSON linked list
  1456. character(kind=CDK,len=*),intent(in) :: path !! path to the variable
  1457. logical(LK),intent(out),optional :: found !! true if it was found
  1458. integer(IK),intent(out),optional :: var_type !! variable type
  1459. integer(IK),intent(out),optional :: n_children !! number of children
  1460. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1461. call json%info(p,to_unicode(path),found,var_type,n_children,name)
  1462. end subroutine wrap_json_info_by_path
  1463. !*****************************************************************************************
  1464. !*****************************************************************************************
  1465. !> author: Jacob Williams
  1466. ! date: 10/16/2015
  1467. !
  1468. ! Alternate version of [[json_info]] that returns matrix
  1469. ! information about a [[json_value]].
  1470. !
  1471. ! A [[json_value]] is a valid rank 2 matrix if all of the following are true:
  1472. !
  1473. ! * The var_type is *json_array*
  1474. ! * Each child is also a *json_array*, each of which has the same number of elements
  1475. ! * Each individual element has the same variable type (integer, logical, etc.)
  1476. !
  1477. ! The idea here is that if it is a valid matrix, it can be interoperable with
  1478. ! a Fortran rank 2 array of the same type.
  1479. !
  1480. !### Example
  1481. !
  1482. ! The following example is an array with `var_type=json_integer`,
  1483. ! `n_sets=3`, and `set_size=4`
  1484. !
  1485. !```json
  1486. ! {
  1487. ! "matrix": [
  1488. ! [1,2,3,4],
  1489. ! [5,6,7,8],
  1490. ! [9,10,11,12]
  1491. ! ]
  1492. ! }
  1493. !```
  1494. subroutine json_matrix_info(json,p,is_matrix,var_type,n_sets,set_size,name)
  1495. implicit none
  1496. class(json_core),intent(inout) :: json
  1497. type(json_value),pointer :: p !! a JSON linked list
  1498. logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
  1499. integer(IK),intent(out),optional :: var_type !! variable type of data in the matrix
  1500. !! (if all elements have the same type)
  1501. integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
  1502. !! rows if using row-major order)
  1503. integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
  1504. !! cols if using row-major order)
  1505. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1506. type(json_value),pointer :: p_row !! for getting a set
  1507. type(json_value),pointer :: p_element !! for getting an element in a set
  1508. integer(IK) :: vartype !! json variable type of `p`
  1509. integer(IK) :: row_vartype !! json variable type of a row
  1510. integer(IK) :: element_vartype !! json variable type of an element in a row
  1511. integer(IK) :: nr !! number of children of `p`
  1512. integer(IK) :: nc !! number of elements in first child of `p`
  1513. integer(IK) :: icount !! number of elements in a set
  1514. integer(IK) :: i !! counter
  1515. integer(IK) :: j !! counter
  1516. #if defined __GFORTRAN__
  1517. character(kind=CK,len=:),allocatable :: p_name !! temporary variable for getting name
  1518. #endif
  1519. !get info about the variable:
  1520. #if defined __GFORTRAN__
  1521. call json%info(p,vartype,nr)
  1522. if (present(name)) then !workaround for gfortran bug
  1523. if (allocated(p%name)) then
  1524. p_name = p%name
  1525. name = p_name
  1526. else
  1527. name = CK_''
  1528. end if
  1529. end if
  1530. #else
  1531. call json%info(p,vartype,nr,name)
  1532. #endif
  1533. is_matrix = (vartype==json_array)
  1534. if (is_matrix) then
  1535. main : do i=1,nr
  1536. nullify(p_row)
  1537. call json%get_child(p,i,p_row)
  1538. if (.not. associated(p_row)) then
  1539. is_matrix = .false.
  1540. call json%throw_exception('Error in json_matrix_info: '//&
  1541. 'Malformed JSON linked list')
  1542. exit main
  1543. end if
  1544. call json%info(p_row,var_type=row_vartype,n_children=icount)
  1545. if (row_vartype==json_array) then
  1546. if (i==1) nc = icount !number of columns in first row
  1547. if (icount==nc) then !make sure each row has the same number of columns
  1548. !see if all the variables in this row are the same type:
  1549. do j=1,icount
  1550. nullify(p_element)
  1551. call json%get_child(p_row,j,p_element)
  1552. if (.not. associated(p_element)) then
  1553. is_matrix = .false.
  1554. call json%throw_exception('Error in json_matrix_info: '//&
  1555. 'Malformed JSON linked list')
  1556. exit main
  1557. end if
  1558. call json%info(p_element,var_type=element_vartype)
  1559. if (i==1 .and. j==1) vartype = element_vartype !type of first element
  1560. !in the row
  1561. if (vartype/=element_vartype) then
  1562. !not all variables are the same time
  1563. is_matrix = .false.
  1564. exit main
  1565. end if
  1566. end do
  1567. else
  1568. is_matrix = .false.
  1569. exit main
  1570. end if
  1571. else
  1572. is_matrix = .false.
  1573. exit main
  1574. end if
  1575. end do main
  1576. end if
  1577. if (is_matrix) then
  1578. if (present(var_type)) var_type = vartype
  1579. if (present(n_sets)) n_sets = nr
  1580. if (present(set_size)) set_size = nc
  1581. else
  1582. if (present(var_type)) var_type = json_unknown
  1583. if (present(n_sets)) n_sets = 0
  1584. if (present(set_size)) set_size = 0
  1585. end if
  1586. end subroutine json_matrix_info
  1587. !*****************************************************************************************
  1588. !*****************************************************************************************
  1589. !>
  1590. ! Returns matrix information about a [[json_value]], given the path.
  1591. !
  1592. !### See also
  1593. ! * [[json_matrix_info]]
  1594. !
  1595. !@note If `found` is present, no exceptions will be thrown if an
  1596. ! error occurs. Otherwise, an exception will be thrown if the
  1597. ! variable is not found.
  1598. subroutine json_matrix_info_by_path(json,p,path,is_matrix,found,&
  1599. var_type,n_sets,set_size,name)
  1600. implicit none
  1601. class(json_core),intent(inout) :: json
  1602. type(json_value),pointer :: p !! a JSON linked list
  1603. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  1604. logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
  1605. logical(LK),intent(out),optional :: found !! true if it was found
  1606. integer(IK),intent(out),optional :: var_type !! variable type of data in
  1607. !! the matrix (if all elements have
  1608. !! the same type)
  1609. integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
  1610. !! rows if using row-major order)
  1611. integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
  1612. !! cols if using row-major order)
  1613. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1614. type(json_value),pointer :: p_var
  1615. logical(LK) :: ok
  1616. #if defined __GFORTRAN__
  1617. character(kind=CK,len=:),allocatable :: p_name !! temporary variable for getting name
  1618. #endif
  1619. call json%get(p,path,p_var,found)
  1620. !check if it was found:
  1621. if (present(found)) then
  1622. ok = found
  1623. else
  1624. ok = .not. json%exception_thrown
  1625. end if
  1626. if (.not. ok) then
  1627. if (present(var_type)) var_type = json_unknown
  1628. if (present(n_sets)) n_sets = 0
  1629. if (present(set_size)) set_size = 0
  1630. if (present(name)) name = CK_''
  1631. else
  1632. !get info about the variable:
  1633. #if defined __GFORTRAN__
  1634. call json%matrix_info(p_var,is_matrix,var_type,n_sets,set_size)
  1635. if (present(name)) then !workaround for gfortran bug
  1636. if (allocated(p_var%name)) then
  1637. p_name = p_var%name
  1638. name = p_name
  1639. else
  1640. name = CK_''
  1641. end if
  1642. end if
  1643. #else
  1644. call json%matrix_info(p_var,is_matrix,var_type,n_sets,set_size,name)
  1645. #endif
  1646. if (json%exception_thrown .and. present(found)) then
  1647. found = .false.
  1648. call json%clear_exceptions()
  1649. end if
  1650. end if
  1651. end subroutine json_matrix_info_by_path
  1652. !*****************************************************************************************
  1653. !*****************************************************************************************
  1654. !>
  1655. ! Alternate version of [[json_matrix_info_by_path]] where "path" is kind=CDK.
  1656. subroutine wrap_json_matrix_info_by_path(json,p,path,is_matrix,found,&
  1657. var_type,n_sets,set_size,name)
  1658. implicit none
  1659. class(json_core),intent(inout) :: json
  1660. type(json_value),pointer :: p !! a JSON linked list
  1661. character(kind=CDK,len=*),intent(in) :: path !! path to the variable
  1662. logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
  1663. logical(LK),intent(out),optional :: found !! true if it was found
  1664. integer(IK),intent(out),optional :: var_type !! variable type of data in
  1665. !! the matrix (if all elements have
  1666. !! the same type)
  1667. integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
  1668. !! rows if using row-major order)
  1669. integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
  1670. !! cols if using row-major order)
  1671. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
  1672. call json%matrix_info(p,to_unicode(path),is_matrix,found,var_type,n_sets,set_size,name)
  1673. end subroutine wrap_json_matrix_info_by_path
  1674. !*****************************************************************************************
  1675. !*****************************************************************************************
  1676. !> author: Jacob Williams
  1677. ! date: 4/29/2016
  1678. !
  1679. ! Rename a [[json_value]].
  1680. subroutine json_value_rename(json,p,name)
  1681. implicit none
  1682. class(json_core),intent(inout) :: json
  1683. type(json_value),pointer,intent(in) :: p
  1684. character(kind=CK,len=*),intent(in) :: name !! new variable name
  1685. if (json%trailing_spaces_significant) then
  1686. p%name = name
  1687. else
  1688. p%name = trim(name)
  1689. end if
  1690. end subroutine json_value_rename
  1691. !*****************************************************************************************
  1692. !*****************************************************************************************
  1693. !> author: Jacob Williams
  1694. ! date: 4/29/2016
  1695. !
  1696. ! Alternate version of [[json_value_rename]], where `name` is kind=CDK.
  1697. subroutine wrap_json_value_rename(json,p,name)
  1698. implicit none
  1699. class(json_core),intent(inout) :: json
  1700. type(json_value),pointer,intent(in) :: p
  1701. character(kind=CDK,len=*),intent(in) :: name !! new variable name
  1702. call json%rename(p,to_unicode(name))
  1703. end subroutine wrap_json_value_rename
  1704. !*****************************************************************************************
  1705. !*****************************************************************************************
  1706. !> author: Jacob Williams
  1707. ! date: 12/4/2013
  1708. !
  1709. ! Clear exceptions in the [[json_core(type)]].
  1710. pure subroutine json_clear_exceptions(json)
  1711. implicit none
  1712. class(json_core),intent(inout) :: json
  1713. !clear the flag and message:
  1714. json%exception_thrown = .false.
  1715. if (allocated(json%err_message)) deallocate(json%err_message)
  1716. end subroutine json_clear_exceptions
  1717. !*****************************************************************************************
  1718. !*****************************************************************************************
  1719. !> author: Jacob Williams
  1720. ! date: 12/4/2013
  1721. !
  1722. ! Throw an exception in the [[json_core(type)]].
  1723. ! This routine sets the error flag, and prevents any subsequent routine
  1724. ! from doing anything, until [[json_clear_exceptions]] is called.
  1725. !
  1726. !@note If `is_verbose` is true, this will also print a
  1727. ! traceback if the Intel compiler is used.
  1728. !
  1729. !@note If `stop_on_error` is true, then the program is stopped.
  1730. subroutine json_throw_exception(json,msg,found)
  1731. #ifdef __INTEL_COMPILER
  1732. use ifcore, only: tracebackqq
  1733. #endif
  1734. implicit none
  1735. class(json_core),intent(inout) :: json
  1736. character(kind=CK,len=*),intent(in) :: msg !! the error message
  1737. logical(LK),intent(inout),optional :: found !! if the caller is handling the
  1738. !! exception with an optimal return
  1739. !! argument. If so, `json%stop_on_error`
  1740. !! is ignored.
  1741. logical(LK) :: stop_on_error
  1742. json%exception_thrown = .true.
  1743. json%err_message = trim(msg)
  1744. stop_on_error = json%stop_on_error .and. .not. present(found)
  1745. if (stop_on_error) then
  1746. #ifdef __INTEL_COMPILER
  1747. ! for Intel, we raise a traceback and quit
  1748. call tracebackqq(string=trim(msg), user_exit_code=0)
  1749. #else
  1750. write(error_unit,'(A)') 'JSON-Fortran Exception: '//trim(msg)
  1751. error stop 1
  1752. #endif
  1753. elseif (json%is_verbose) then
  1754. write(output_unit,'(A)') '***********************'
  1755. write(output_unit,'(A)') 'JSON-Fortran Exception: '//trim(msg)
  1756. !#if defined __GFORTRAN__
  1757. ! call backtrace() ! (have to compile with -fbacktrace -fall-intrinsics flags)
  1758. !#endif
  1759. #ifdef __INTEL_COMPILER
  1760. call tracebackqq(user_exit_code=-1) ! print a traceback and return
  1761. #endif
  1762. write(output_unit,'(A)') '***********************'
  1763. end if
  1764. end subroutine json_throw_exception
  1765. !*****************************************************************************************
  1766. !*****************************************************************************************
  1767. !>
  1768. ! Alternate version of [[json_throw_exception]], where `msg` is kind=CDK.
  1769. subroutine wrap_json_throw_exception(json,msg,found)
  1770. implicit none
  1771. class(json_core),intent(inout) :: json
  1772. character(kind=CDK,len=*),intent(in) :: msg !! the error message
  1773. logical(LK),intent(inout),optional :: found !! if the caller is handling the
  1774. !! exception with an optimal return
  1775. !! argument. If so, `json%stop_on_error`
  1776. !! is ignored.
  1777. call json%throw_exception(to_unicode(msg),found)
  1778. end subroutine wrap_json_throw_exception
  1779. !*****************************************************************************************
  1780. !*****************************************************************************************
  1781. !> author: Jacob Williams
  1782. ! date: 12/4/2013
  1783. !
  1784. ! Retrieve error code from the [[json_core(type)]].
  1785. ! This should be called after `parse` to check for errors.
  1786. ! If an error is thrown, before using the class again, [[json_initialize]]
  1787. ! should be called to clean up before it is used again.
  1788. !
  1789. !### Example
  1790. !
  1791. !````fortran
  1792. ! type(json_file) :: json
  1793. ! logical :: status_ok
  1794. ! character(kind=CK,len=:),allocatable :: error_msg
  1795. ! call json%load(filename='myfile.json')
  1796. ! call json%check_for_errors(status_ok, error_msg)
  1797. ! if (.not. status_ok) then
  1798. ! write(*,*) 'Error: '//error_msg
  1799. ! call json%clear_exceptions()
  1800. ! call json%destroy()
  1801. ! end if
  1802. !````
  1803. !
  1804. !### See also
  1805. ! * [[json_failed]]
  1806. ! * [[json_throw_exception]]
  1807. subroutine json_check_for_errors(json,status_ok,error_msg)
  1808. implicit none
  1809. class(json_core),intent(in) :: json
  1810. logical(LK),intent(out),optional :: status_ok !! true if there were no errors
  1811. character(kind=CK,len=:),allocatable,intent(out),optional :: error_msg !! the error message.
  1812. !! (not allocated if
  1813. !! there were no errors)
  1814. #if defined __GFORTRAN__
  1815. character(kind=CK,len=:),allocatable :: tmp !! workaround for gfortran bugs
  1816. #endif
  1817. if (present(status_ok)) status_ok = .not. json%exception_thrown
  1818. if (present(error_msg)) then
  1819. if (json%exception_thrown) then
  1820. ! if an exception has been thrown,
  1821. ! then this will always be allocated
  1822. ! [see json_throw_exception]
  1823. #if defined __GFORTRAN__
  1824. tmp = json%err_message
  1825. error_msg = tmp
  1826. #else
  1827. error_msg = json%err_message
  1828. #endif
  1829. end if
  1830. end if
  1831. end subroutine json_check_for_errors
  1832. !*****************************************************************************************
  1833. !*****************************************************************************************
  1834. !> author: Jacob Williams
  1835. ! date: 12/5/2013
  1836. !
  1837. ! Logical function to indicate if an exception has been thrown in a [[json_core(type)]].
  1838. !
  1839. !### Example
  1840. !
  1841. !````fortran
  1842. ! type(json_core) :: json
  1843. ! type(json_value),pointer :: p
  1844. ! logical :: status_ok
  1845. ! character(len=:),allocatable :: error_msg
  1846. ! call json%load(filename='myfile.json',p)
  1847. ! if (json%failed()) then
  1848. ! call json%check_for_errors(status_ok, error_msg)
  1849. ! write(*,*) 'Error: '//error_msg
  1850. ! call json%clear_exceptions()
  1851. ! call json%destroy(p)
  1852. ! end if
  1853. !````
  1854. !
  1855. ! Note that [[json_file]] contains a wrapper for this routine, which is used like:
  1856. !````fortran
  1857. ! type(json_file) :: f
  1858. ! logical :: status_ok
  1859. ! character(len=:),allocatable :: error_msg
  1860. ! call f%load(filename='myfile.json')
  1861. ! if (f%failed()) then
  1862. ! call f%check_for_errors(status_ok, error_msg)
  1863. ! write(*,*) 'Error: '//error_msg
  1864. ! call f%clear_exceptions()
  1865. ! call f%destroy()
  1866. ! end if
  1867. !````
  1868. !
  1869. !### See also
  1870. ! * [[json_check_for_errors]]
  1871. pure function json_failed(json) result(failed)
  1872. implicit none
  1873. class(json_core),intent(in) :: json
  1874. logical(LK) :: failed !! will be true if an exception
  1875. !! has been thrown.
  1876. failed = json%exception_thrown
  1877. end function json_failed
  1878. !*****************************************************************************************
  1879. !*****************************************************************************************
  1880. !>
  1881. ! Allocate a [[json_value]] pointer variable.
  1882. ! This should be called before adding data to it.
  1883. !
  1884. !### Example
  1885. !
  1886. !````fortran
  1887. ! type(json_value),pointer :: var
  1888. ! call json_value_create(var)
  1889. ! call json%to_real(var,1.0_RK)
  1890. !````
  1891. !
  1892. !### Notes
  1893. ! 1. This routine does not check for exceptions.
  1894. ! 2. The pointer should not already be allocated, or a memory leak will occur.
  1895. subroutine json_value_create(p)
  1896. implicit none
  1897. type(json_value),pointer :: p
  1898. nullify(p)
  1899. allocate(p)
  1900. end subroutine json_value_create
  1901. !*****************************************************************************************
  1902. !*****************************************************************************************
  1903. !> author: Jacob Williams
  1904. ! date: 1/22/2014
  1905. !
  1906. ! Destroy a [[json_value]] linked-list structure.
  1907. !
  1908. !@note The original FSON version of this
  1909. ! routine was not properly freeing the memory.
  1910. ! It was rewritten.
  1911. !
  1912. !@note This routine destroys this variable, it's children, and
  1913. ! (if `destroy_next` is true) the subsequent elements in
  1914. ! an object or array. It does not destroy the parent or
  1915. ! previous elements.
  1916. !
  1917. !@Note There is some protection here to enable destruction of
  1918. ! improperly-created linked lists. However, likely there
  1919. ! are cases not handled. Use the [[json_value_validate]]
  1920. ! method to validate a JSON structure that was manually
  1921. ! created using [[json_value]] pointers.
  1922. pure recursive subroutine json_value_destroy(json,p,destroy_next)
  1923. implicit none
  1924. class(json_core),intent(inout) :: json
  1925. type(json_value),pointer :: p !! variable to destroy
  1926. logical(LK),intent(in),optional :: destroy_next !! if true, then `p%next`
  1927. !! is also destroyed (default is true)
  1928. logical(LK) :: des_next !! local copy of `destroy_next`
  1929. !! optional argument
  1930. type(json_value),pointer :: child !! for getting child elements
  1931. logical :: circular !! to check to malformed linked lists
  1932. if (associated(p)) then
  1933. if (present(destroy_next)) then
  1934. des_next = destroy_next
  1935. else
  1936. des_next = .true.
  1937. end if
  1938. if (allocated(p%name)) deallocate(p%name)
  1939. call destroy_json_data(p)
  1940. if (associated(p%next)) then
  1941. ! check for circular references:
  1942. if (associated(p, p%next)) nullify(p%next)
  1943. end if
  1944. if (associated(p%children)) then
  1945. do while (p%n_children > 0)
  1946. child => p%children
  1947. if (associated(child)) then
  1948. p%children => p%children%next
  1949. p%n_children = p%n_children - 1
  1950. ! check children for circular references:
  1951. circular = (associated(p%children) .and. &
  1952. associated(p%children,child))
  1953. call json%destroy(child,destroy_next=.false.)
  1954. if (circular) exit
  1955. else
  1956. ! it is a malformed JSON object. But, we will
  1957. ! press ahead with the destroy process, since
  1958. ! otherwise, there would be no way to destroy it.
  1959. exit
  1960. end if
  1961. end do
  1962. nullify(p%children)
  1963. nullify(child)
  1964. end if
  1965. if (associated(p%next) .and. des_next) call json%destroy(p%next)
  1966. nullify(p%previous)
  1967. nullify(p%parent)
  1968. nullify(p%tail)
  1969. if (associated(p)) deallocate(p)
  1970. nullify(p)
  1971. end if
  1972. end subroutine json_value_destroy
  1973. !*****************************************************************************************
  1974. !*****************************************************************************************
  1975. !> author: Jacob Williams
  1976. ! date: 9/9/2014
  1977. !
  1978. ! Remove a [[json_value]] (and all its children)
  1979. ! from a linked-list structure, preserving the rest of the structure.
  1980. !
  1981. !### Examples
  1982. !
  1983. ! To extract an object from one JSON structure, and add it to another:
  1984. !````fortran
  1985. ! type(json_core) :: json
  1986. ! type(json_value),pointer :: json1,json2,p
  1987. ! logical :: found
  1988. ! !create and populate json1 and json2
  1989. ! call json%get(json1,'name',p,found) ! get pointer to name element of json1
  1990. ! call json%remove(p,destroy=.false.) ! remove it from json1 (don't destroy)
  1991. ! call json%add(json2,p) ! add it to json2
  1992. !````
  1993. !
  1994. ! To remove an object from a JSON structure (and destroy it):
  1995. !````fortran
  1996. ! type(json_core) :: json
  1997. ! type(json_value),pointer :: json1,p
  1998. ! logical :: found
  1999. ! !create and populate json1
  2000. ! call json%get(json1,'name',p,found) ! get pointer to name element of json1
  2001. ! call json%remove(p) ! remove and destroy it
  2002. !````
  2003. !
  2004. !### History
  2005. ! * Jacob Williams : 12/28/2014 : added destroy optional argument.
  2006. ! * Jacob Williams : 12/04/2020 : bug fix.
  2007. subroutine json_value_remove(json,p,destroy)
  2008. implicit none
  2009. class(json_core),intent(inout) :: json
  2010. type(json_value),pointer :: p
  2011. logical(LK),intent(in),optional :: destroy !! Option to destroy `p` after it is removed:
  2012. !!
  2013. !! * If `destroy` is not present, it is also destroyed.
  2014. !! * If `destroy` is present and true, it is destroyed.
  2015. !! * If `destroy` is present and false, it is not destroyed.
  2016. type(json_value),pointer :: parent !! pointer to parent
  2017. type(json_value),pointer :: previous !! pointer to previous
  2018. type(json_value),pointer :: next !! pointer to next
  2019. logical(LK) :: destroy_it !! if `p` should be destroyed
  2020. if (associated(p)) then
  2021. !optional input argument:
  2022. if (present(destroy)) then
  2023. destroy_it = destroy
  2024. else
  2025. destroy_it = .true.
  2026. end if
  2027. if (associated(p%parent)) then
  2028. parent => p%parent
  2029. if (associated(p%next)) then
  2030. !there are later items in the list:
  2031. next => p%next
  2032. if (associated(p%previous)) then
  2033. !there are earlier items in the list
  2034. previous => p%previous
  2035. previous%next => next
  2036. next%previous => previous
  2037. else
  2038. !this is the first item in the list
  2039. parent%children => next
  2040. nullify(next%previous)
  2041. end if
  2042. else
  2043. if (associated(p%previous)) then
  2044. !there are earlier items in the list:
  2045. previous => p%previous
  2046. nullify(previous%next)
  2047. parent%tail => previous
  2048. else
  2049. !this is the only item in the list:
  2050. nullify(parent%children)
  2051. nullify(parent%tail)
  2052. end if
  2053. end if
  2054. ! nullify all pointers to original structure:
  2055. nullify(p%next)
  2056. nullify(p%previous)
  2057. nullify(p%parent)
  2058. parent%n_children = parent%n_children - 1
  2059. end if
  2060. if (destroy_it) call json%destroy(p)
  2061. end if
  2062. end subroutine json_value_remove
  2063. !*****************************************************************************************
  2064. !*****************************************************************************************
  2065. !>
  2066. ! Replace `p1` with `p2` in a JSON structure.
  2067. !
  2068. !@note The replacement is done using an insert and remove
  2069. ! See [[json_value_insert_after]] and [[json_value_remove]]
  2070. ! for details.
  2071. subroutine json_value_replace(json,p1,p2,destroy)
  2072. implicit none
  2073. class(json_core),intent(inout) :: json
  2074. type(json_value),pointer :: p1 !! the item to replace
  2075. type(json_value),pointer :: p2 !! item to take the place of `p1`
  2076. logical(LK),intent(in),optional :: destroy !! Should `p1` also be destroyed
  2077. !! (default is True). Normally,
  2078. !! this should be true to avoid
  2079. !! a memory leak.
  2080. logical(LK) :: destroy_p1 !! if `p1` is to be destroyed
  2081. if (present(destroy)) then
  2082. destroy_p1 = destroy
  2083. else
  2084. destroy_p1 = .true. ! default
  2085. end if
  2086. call json%insert_after(p1,p2)
  2087. call json%remove(p1,destroy_p1)
  2088. end subroutine json_value_replace
  2089. !*****************************************************************************************
  2090. !*****************************************************************************************
  2091. !> author: Jacob Williams
  2092. ! date: 4/11/2017
  2093. !
  2094. ! Reverse the order of the children of an array or object.
  2095. subroutine json_value_reverse(json,p)
  2096. implicit none
  2097. class(json_core),intent(inout) :: json
  2098. type(json_value),pointer :: p
  2099. type(json_value),pointer :: tmp !! temp variable for traversing the list
  2100. type(json_value),pointer :: current !! temp variable for traversing the list
  2101. integer(IK) :: var_type !! for getting the variable type
  2102. if (associated(p)) then
  2103. call json%info(p,var_type=var_type)
  2104. ! can only reverse objects or arrays
  2105. if (var_type==json_object .or. var_type==json_array) then
  2106. nullify(tmp)
  2107. current => p%children
  2108. p%tail => current
  2109. ! Swap next and previous for all nodes:
  2110. do
  2111. if (.not. associated(current)) exit
  2112. tmp => current%previous
  2113. current%previous => current%next
  2114. current%next => tmp
  2115. current => current%previous
  2116. end do
  2117. if (associated(tmp)) then
  2118. p%children => tmp%previous
  2119. end if
  2120. end if
  2121. end if
  2122. end subroutine json_value_reverse
  2123. !*****************************************************************************************
  2124. !*****************************************************************************************
  2125. !> author: Jacob Williams
  2126. ! date: 4/26/2016
  2127. !
  2128. ! Swap two elements in a JSON structure.
  2129. ! All of the children are carried along as well.
  2130. !
  2131. !@note If both are not associated, then an error is thrown.
  2132. !
  2133. !@note The assumption here is that both variables are part of a valid
  2134. ! [[json_value]] linked list (so the normal `parent`, `previous`,
  2135. ! `next`, etc. pointers are properly associated if necessary).
  2136. !
  2137. !@warning This cannot be used to swap a parent/child pair, since that
  2138. ! could lead to a circular linkage. An exception is thrown if
  2139. ! this is tried.
  2140. !
  2141. !@warning There are also other situations where using this routine may
  2142. ! produce a malformed JSON structure, such as moving an array
  2143. ! element outside of an array. This is not checked for.
  2144. !
  2145. !@note If `p1` and `p2` have a common parent, it is always safe to swap them.
  2146. subroutine json_value_swap(json,p1,p2)
  2147. implicit none
  2148. class(json_core),intent(inout) :: json
  2149. type(json_value),pointer :: p1 !! swap with `p2`
  2150. type(json_value),pointer :: p2 !! swap with `p1`
  2151. logical :: same_parent !! if `p1` and `p2` have the same parent
  2152. logical :: first_last !! if `p1` and `p2` are the first,last or
  2153. !! last,first children of a common parent
  2154. logical :: adjacent !! if `p1` and `p2` are adjacent
  2155. !! elements in an array
  2156. type(json_value),pointer :: a !! temporary variable
  2157. type(json_value),pointer :: b !! temporary variable
  2158. if (json%exception_thrown) return
  2159. !both have to be associated:
  2160. if (associated(p1) .and. associated(p2)) then
  2161. !simple check to make sure that they both
  2162. !aren't pointing to the same thing:
  2163. if (.not. associated(p1,p2)) then
  2164. !we will not allow swapping an item with one of its descendants:
  2165. if (json%is_child_of(p1,p2) .or. json%is_child_of(p2,p1)) then
  2166. call json%throw_exception('Error in json_value_swap: '//&
  2167. 'cannot swap an item with one of its descendants')
  2168. else
  2169. same_parent = ( associated(p1%parent) .and. &
  2170. associated(p2%parent) .and. &
  2171. associated(p1%parent,p2%parent) )
  2172. if (same_parent) then
  2173. first_last = (associated(p1%parent%children,p1) .and. &
  2174. associated(p2%parent%tail,p2)) .or. &
  2175. (associated(p1%parent%tail,p1) .and. &
  2176. associated(p2%parent%children,p2))
  2177. else
  2178. first_last = .false.
  2179. end if
  2180. !first, we fix children,tail pointers:
  2181. if (same_parent .and. first_last) then
  2182. !this is all we have to do for the parent in this case:
  2183. call swap_pointers(p1%parent%children,p2%parent%tail)
  2184. else if (same_parent .and. .not. first_last) then
  2185. if (associated(p1%parent%children,p1)) then
  2186. p1%parent%children => p2 ! p1 is the first child of the parent
  2187. else if (associated(p1%parent%children,p2)) then
  2188. p1%parent%children => p1 ! p2 is the first child of the parent
  2189. end if
  2190. if (associated(p1%parent%tail,p1)) then
  2191. p1%parent%tail => p2 ! p1 is the last child of the parent
  2192. else if (associated(p1%parent%tail,p2)) then
  2193. p1%parent%tail => p1 ! p2 is the last child of the parent
  2194. end if
  2195. else ! general case: different parents
  2196. if (associated(p1%parent)) then
  2197. if (associated(p1%parent%children,p1)) p1%parent%children => p2
  2198. if (associated(p1%parent%tail,p1)) p1%parent%tail => p2
  2199. end if
  2200. if (associated(p2%parent)) then
  2201. if (associated(p2%parent%children,p2)) p2%parent%children => p1
  2202. if (associated(p2%parent%tail,p2)) p2%parent%tail => p1
  2203. end if
  2204. call swap_pointers(p1%parent, p2%parent)
  2205. end if
  2206. !now, have to fix previous,next pointers:
  2207. !first, see if they are adjacent:
  2208. adjacent = associated(p1%next,p2) .or. &
  2209. associated(p2%next,p1)
  2210. if (associated(p2%next,p1)) then !p2,p1
  2211. a => p2
  2212. b => p1
  2213. else !p1,p2 (or not adjacent)
  2214. a => p1
  2215. b => p2
  2216. end if
  2217. if (associated(a%previous)) a%previous%next => b
  2218. if (associated(b%next)) b%next%previous => a
  2219. if (adjacent) then
  2220. !a comes before b in the original list
  2221. b%previous => a%previous
  2222. a%next => b%next
  2223. a%previous => b
  2224. b%next => a
  2225. else
  2226. if (associated(a%next)) a%next%previous => b
  2227. if (associated(b%previous)) b%previous%next => a
  2228. call swap_pointers(a%previous,b%previous)
  2229. call swap_pointers(a%next, b%next)
  2230. end if
  2231. end if
  2232. else
  2233. call json%throw_exception('Error in json_value_swap: '//&
  2234. 'both pointers must be associated')
  2235. end if
  2236. end if
  2237. contains
  2238. pure subroutine swap_pointers(s1,s2)
  2239. implicit none
  2240. type(json_value),pointer,intent(inout) :: s1
  2241. type(json_value),pointer,intent(inout) :: s2
  2242. type(json_value),pointer :: tmp !! temporary pointer
  2243. if (.not. associated(s1,s2)) then
  2244. tmp => s1
  2245. s1 => s2
  2246. s2 => tmp
  2247. end if
  2248. end subroutine swap_pointers
  2249. end subroutine json_value_swap
  2250. !*****************************************************************************************
  2251. !*****************************************************************************************
  2252. !> author: Jacob Williams
  2253. ! date: 4/28/2016
  2254. !
  2255. ! Returns True if `p2` is a descendant of `p1`
  2256. ! (i.e, a child, or a child of child, etc.)
  2257. function json_value_is_child_of(json,p1,p2) result(is_child_of)
  2258. implicit none
  2259. class(json_core),intent(inout) :: json
  2260. type(json_value),pointer :: p1
  2261. type(json_value),pointer :: p2
  2262. logical(LK) :: is_child_of
  2263. is_child_of = .false.
  2264. if (json%exception_thrown) return
  2265. if (associated(p1) .and. associated(p2)) then
  2266. if (associated(p1%children)) then
  2267. call json%traverse(p1%children,is_child_of_callback)
  2268. end if
  2269. end if
  2270. contains
  2271. subroutine is_child_of_callback(json,p,finished)
  2272. !! Traverse until `p` is `p2`.
  2273. implicit none
  2274. class(json_core),intent(inout) :: json
  2275. type(json_value),pointer,intent(in) :: p
  2276. logical(LK),intent(out) :: finished
  2277. is_child_of = associated(p,p2)
  2278. finished = is_child_of ! stop searching if found
  2279. end subroutine is_child_of_callback
  2280. end function json_value_is_child_of
  2281. !*****************************************************************************************
  2282. !*****************************************************************************************
  2283. !> author: Jacob Williams
  2284. ! date: 5/2/2016
  2285. !
  2286. ! Validate a [[json_value]] linked list by checking to make sure
  2287. ! all the pointers are properly associated, arrays and objects
  2288. ! have the correct number of children, and the correct data is
  2289. ! allocated for the variable types.
  2290. !
  2291. ! It recursively traverses the entire structure and checks every element.
  2292. !
  2293. !### History
  2294. ! * Jacob Williams, 8/26/2017 : added duplicate key check.
  2295. !
  2296. !@note It will return on the first error it encounters.
  2297. !
  2298. !@note This routine does not check or throw any exceptions.
  2299. ! If `json` is currently in a state of exception, it will
  2300. ! remain so after calling this routine.
  2301. subroutine json_value_validate(json,p,is_valid,error_msg)
  2302. implicit none
  2303. class(json_core),intent(inout) :: json
  2304. type(json_value),pointer,intent(in) :: p
  2305. logical(LK),intent(out) :: is_valid !! True if the structure is valid.
  2306. character(kind=CK,len=:),allocatable,intent(out) :: error_msg !! if not valid, this will contain
  2307. !! a description of the problem
  2308. logical(LK) :: has_duplicate !! to check for duplicate keys
  2309. character(kind=CK,len=:),allocatable :: path !! path to duplicate key
  2310. logical(LK) :: status_ok !! to check for existing exception
  2311. character(kind=CK,len=:),allocatable :: exception_msg !! error message for an existing exception
  2312. character(kind=CK,len=:),allocatable :: exception_msg2 !! error message for a new exception
  2313. if (associated(p)) then
  2314. is_valid = .true.
  2315. call check_if_valid(p,require_parent=associated(p%parent))
  2316. if (is_valid .and. .not. json%allow_duplicate_keys) then
  2317. ! if no errors so far, also check the
  2318. ! entire structure for duplicate keys:
  2319. ! note: check_for_duplicate_keys does call routines
  2320. ! that check and throw exceptions, so let's clear any
  2321. ! first. (save message for later)
  2322. call json%check_for_errors(status_ok, exception_msg)
  2323. call json%clear_exceptions()
  2324. call json%check_for_duplicate_keys(p,has_duplicate,path=path)
  2325. if (json%failed()) then
  2326. ! if an exception was thrown during this call,
  2327. ! then clear it but make that the error message
  2328. ! returned by this routine. Normally this should
  2329. ! never actually occur since we have already
  2330. ! validated the structure.
  2331. call json%check_for_errors(is_valid, exception_msg2)
  2332. error_msg = exception_msg2
  2333. call json%clear_exceptions()
  2334. is_valid = .false.
  2335. else
  2336. if (has_duplicate) then
  2337. error_msg = 'duplicate key found: '//path
  2338. is_valid = .false.
  2339. end if
  2340. end if
  2341. if (.not. status_ok) then
  2342. ! restore any existing exception if necessary
  2343. call json%throw_exception(exception_msg)
  2344. end if
  2345. ! cleanup:
  2346. if (allocated(path)) deallocate(path)
  2347. if (allocated(exception_msg)) deallocate(exception_msg)
  2348. if (allocated(exception_msg2)) deallocate(exception_msg2)
  2349. end if
  2350. else
  2351. error_msg = 'The pointer is not associated'
  2352. is_valid = .false.
  2353. end if
  2354. contains
  2355. recursive subroutine check_if_valid(p,require_parent)
  2356. implicit none
  2357. type(json_value),pointer,intent(in) :: p
  2358. logical,intent(in) :: require_parent !! the first one may be a root (so no parent),
  2359. !! but all descendants must have a parent.
  2360. integer(IK) :: i !! counter
  2361. type(json_value),pointer :: element
  2362. type(json_value),pointer :: previous
  2363. if (is_valid .and. associated(p)) then
  2364. ! data type:
  2365. select case (p%var_type)
  2366. case(json_null,json_object,json_array)
  2367. if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
  2368. allocated(p%dbl_value) .or. allocated(p%str_value)) then
  2369. error_msg = 'incorrect data allocated for '//&
  2370. 'json_null, json_object, or json_array variable type'
  2371. is_valid = .false.
  2372. return
  2373. end if
  2374. case(json_logical)
  2375. if (.not. allocated(p%log_value)) then
  2376. error_msg = 'log_value should be allocated for json_logical variable type'
  2377. is_valid = .false.
  2378. return
  2379. else if (allocated(p%int_value) .or. &
  2380. allocated(p%dbl_value) .or. allocated(p%str_value)) then
  2381. error_msg = 'incorrect data allocated for json_logical variable type'
  2382. is_valid = .false.
  2383. return
  2384. end if
  2385. case(json_integer)
  2386. if (.not. allocated(p%int_value)) then
  2387. error_msg = 'int_value should be allocated for json_integer variable type'
  2388. is_valid = .false.
  2389. return
  2390. else if (allocated(p%log_value) .or. &
  2391. allocated(p%dbl_value) .or. allocated(p%str_value)) then
  2392. error_msg = 'incorrect data allocated for json_integer variable type'
  2393. is_valid = .false.
  2394. return
  2395. end if
  2396. case(json_real)
  2397. if (.not. allocated(p%dbl_value)) then
  2398. error_msg = 'dbl_value should be allocated for json_real variable type'
  2399. is_valid = .false.
  2400. return
  2401. else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
  2402. allocated(p%str_value)) then
  2403. error_msg = 'incorrect data allocated for json_real variable type'
  2404. is_valid = .false.
  2405. return
  2406. end if
  2407. case(json_string)
  2408. if (.not. allocated(p%str_value)) then
  2409. error_msg = 'str_value should be allocated for json_string variable type'
  2410. is_valid = .false.
  2411. return
  2412. else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
  2413. allocated(p%dbl_value)) then
  2414. error_msg = 'incorrect data allocated for json_string variable type'
  2415. is_valid = .false.
  2416. return
  2417. end if
  2418. case default
  2419. error_msg = 'invalid JSON variable type'
  2420. is_valid = .false.
  2421. return
  2422. end select
  2423. if (require_parent .and. .not. associated(p%parent)) then
  2424. error_msg = 'parent pointer is not associated'
  2425. is_valid = .false.
  2426. return
  2427. end if
  2428. if (.not. allocated(p%name)) then
  2429. if (associated(p%parent)) then
  2430. if (p%parent%var_type/=json_array) then
  2431. error_msg = 'JSON variable must have a name if not an '//&
  2432. 'array element or the root'
  2433. is_valid = .false.
  2434. return
  2435. end if
  2436. end if
  2437. end if
  2438. if (associated(p%children) .neqv. associated(p%tail)) then
  2439. error_msg = 'both children and tail pointers must be associated'
  2440. is_valid = .false.
  2441. return
  2442. end if
  2443. ! now, check next one:
  2444. if (associated(p%next)) then
  2445. if (associated(p,p%next)) then
  2446. error_msg = 'circular linked list'
  2447. is_valid = .false.
  2448. return
  2449. else
  2450. ! if it's an element in an
  2451. ! array, then require a parent:
  2452. call check_if_valid(p%next,require_parent=.true.)
  2453. end if
  2454. end if
  2455. if (associated(p%children)) then
  2456. if (p%var_type/=json_array .and. p%var_type/=json_object) then
  2457. error_msg = 'only arrays and objects can have children'
  2458. is_valid = .false.
  2459. return
  2460. end if
  2461. ! first validate children pointers:
  2462. previous => null()
  2463. element => p%children
  2464. do i = 1_IK, p%n_children
  2465. if (.not. associated(element%parent,p)) then
  2466. error_msg = 'child''s parent pointer not properly associated'
  2467. is_valid = .false.
  2468. return
  2469. end if
  2470. if (i==1 .and. associated(element%previous)) then
  2471. error_msg = 'first child shouldn''t have a previous'
  2472. is_valid = .false.
  2473. return
  2474. end if
  2475. if (i<p%n_children .and. .not. associated(element%next)) then
  2476. error_msg = 'not enough children'
  2477. is_valid = .false.
  2478. return
  2479. end if
  2480. if (i==p%n_children .and. associated(element%next)) then
  2481. error_msg = 'too many children'
  2482. is_valid = .false.
  2483. return
  2484. end if
  2485. if (i>1) then
  2486. if (.not. associated(previous,element%previous)) then
  2487. error_msg = 'previous pointer not properly associated'
  2488. is_valid = .false.
  2489. return
  2490. end if
  2491. end if
  2492. if (i==p%n_children .and. &
  2493. .not. associated(element%parent%tail,element)) then
  2494. error_msg = 'parent''s tail pointer not properly associated'
  2495. is_valid = .false.
  2496. return
  2497. end if
  2498. if (i<p%n_children) then
  2499. !setup next case:
  2500. previous => element
  2501. element => element%next
  2502. end if
  2503. end do
  2504. !now check all the children:
  2505. call check_if_valid(p%children,require_parent=.true.)
  2506. end if
  2507. end if
  2508. end subroutine check_if_valid
  2509. end subroutine json_value_validate
  2510. !*****************************************************************************************
  2511. !*****************************************************************************************
  2512. !> author: Jacob Williams
  2513. ! date: 12/6/2014
  2514. !
  2515. ! Given the path string, remove the variable
  2516. ! from [[json_value]], if it exists.
  2517. subroutine json_value_remove_if_present(json,p,path)
  2518. implicit none
  2519. class(json_core),intent(inout) :: json
  2520. type(json_value),pointer :: p
  2521. character(kind=CK,len=*),intent(in) :: path !! the path to the variable to remove
  2522. type(json_value),pointer :: p_var
  2523. logical(LK) :: found
  2524. call json%get(p,path,p_var,found)
  2525. if (found) call json%remove(p_var)
  2526. end subroutine json_value_remove_if_present
  2527. !*****************************************************************************************
  2528. !*****************************************************************************************
  2529. !>
  2530. ! Alternate version of [[json_value_remove_if_present]], where `path` is kind=CDK.
  2531. subroutine wrap_json_value_remove_if_present(json,p,path)
  2532. implicit none
  2533. class(json_core),intent(inout) :: json
  2534. type(json_value),pointer :: p
  2535. character(kind=CDK,len=*),intent(in) :: path
  2536. call json%remove_if_present(p,to_unicode(path))
  2537. end subroutine wrap_json_value_remove_if_present
  2538. !*****************************************************************************************
  2539. !*****************************************************************************************
  2540. !> author: Jacob Williams
  2541. ! date: 12/6/2014
  2542. !
  2543. ! Given the path string, if the variable is present,
  2544. ! and is a scalar, then update its value.
  2545. ! If it is not present, then create it and set its value.
  2546. !
  2547. !@note If the variable is not a scalar, an exception will be thrown.
  2548. subroutine json_update_logical(json,p,path,val,found)
  2549. implicit none
  2550. class(json_core),intent(inout) :: json
  2551. type(json_value),pointer :: p
  2552. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2553. logical(LK),intent(in) :: val !! the new value
  2554. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2555. type(json_value),pointer :: p_var
  2556. integer(IK) :: var_type
  2557. call json%get(p,path,p_var,found)
  2558. if (found) then
  2559. call json%info(p_var,var_type)
  2560. select case (var_type)
  2561. case (json_null,json_logical,json_integer,json_real,json_string)
  2562. call json%to_logical(p_var,val) !update the value
  2563. case default
  2564. found = .false.
  2565. call json%throw_exception('Error in json_update_logical: '//&
  2566. 'the variable is not a scalar value',found)
  2567. end select
  2568. else
  2569. call json%add_by_path(p,path,val) !add the new element
  2570. end if
  2571. end subroutine json_update_logical
  2572. !*****************************************************************************************
  2573. !*****************************************************************************************
  2574. !>
  2575. ! Alternate version of [[json_update_logical]], where `path` is kind=CDK.
  2576. subroutine wrap_json_update_logical(json,p,path,val,found)
  2577. implicit none
  2578. class(json_core),intent(inout) :: json
  2579. type(json_value),pointer :: p
  2580. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2581. logical(LK),intent(in) :: val !! the new value
  2582. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2583. call json%update(p,to_unicode(path),val,found)
  2584. end subroutine wrap_json_update_logical
  2585. !*****************************************************************************************
  2586. !*****************************************************************************************
  2587. !> author: Jacob Williams
  2588. ! date: 12/6/2014
  2589. !
  2590. ! Given the path string, if the variable is present,
  2591. ! and is a scalar, then update its value.
  2592. ! If it is not present, then create it and set its value.
  2593. !
  2594. !@note If the variable is not a scalar, an exception will be thrown.
  2595. subroutine json_update_real(json,p,path,val,found)
  2596. implicit none
  2597. class(json_core),intent(inout) :: json
  2598. type(json_value),pointer :: p
  2599. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2600. real(RK),intent(in) :: val !! the new value
  2601. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2602. type(json_value),pointer :: p_var
  2603. integer(IK) :: var_type
  2604. call json%get(p,path,p_var,found)
  2605. if (found) then
  2606. call json%info(p_var,var_type)
  2607. select case (var_type)
  2608. case (json_null,json_logical,json_integer,json_real,json_string)
  2609. call json%to_real(p_var,val) !update the value
  2610. case default
  2611. found = .false.
  2612. call json%throw_exception('Error in json_update_real: '//&
  2613. 'the variable is not a scalar value',found)
  2614. end select
  2615. else
  2616. call json%add_by_path(p,path,val) !add the new element
  2617. end if
  2618. end subroutine json_update_real
  2619. !*****************************************************************************************
  2620. !*****************************************************************************************
  2621. !>
  2622. ! Alternate version of [[json_update_real]], where `path` is kind=CDK.
  2623. subroutine wrap_json_update_real(json,p,path,val,found)
  2624. implicit none
  2625. class(json_core),intent(inout) :: json
  2626. type(json_value),pointer :: p
  2627. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2628. real(RK),intent(in) :: val !! the new value
  2629. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2630. call json%update(p,to_unicode(path),val,found)
  2631. end subroutine wrap_json_update_real
  2632. !*****************************************************************************************
  2633. #ifndef REAL32
  2634. !*****************************************************************************************
  2635. !>
  2636. ! Alternate version of [[json_update_real]], where `val` is `real32`.
  2637. subroutine json_update_real32(json,p,path,val,found)
  2638. implicit none
  2639. class(json_core),intent(inout) :: json
  2640. type(json_value),pointer :: p
  2641. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2642. real(real32),intent(in) :: val !! the new value
  2643. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2644. call json%update(p,path,real(val,RK),found)
  2645. end subroutine json_update_real32
  2646. !*****************************************************************************************
  2647. !*****************************************************************************************
  2648. !>
  2649. ! Alternate version of [[json_update_real32]], where `path` is kind=CDK.
  2650. subroutine wrap_json_update_real32(json,p,path,val,found)
  2651. implicit none
  2652. class(json_core),intent(inout) :: json
  2653. type(json_value),pointer :: p
  2654. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2655. real(real32),intent(in) :: val !! the new value
  2656. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2657. call json%update(p,to_unicode(path),real(val,RK),found)
  2658. end subroutine wrap_json_update_real32
  2659. !*****************************************************************************************
  2660. #endif
  2661. #ifdef REAL128
  2662. !*****************************************************************************************
  2663. !>
  2664. ! Alternate version of [[json_update_real]], where `val` is `real64`.
  2665. subroutine json_update_real64(json,p,path,val,found)
  2666. implicit none
  2667. class(json_core),intent(inout) :: json
  2668. type(json_value),pointer :: p
  2669. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2670. real(real64),intent(in) :: val !! the new value
  2671. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2672. call json%update(p,path,real(val,RK),found)
  2673. end subroutine json_update_real64
  2674. !*****************************************************************************************
  2675. !*****************************************************************************************
  2676. !>
  2677. ! Alternate version of [[json_update_real64]], where `path` is kind=CDK.
  2678. subroutine wrap_json_update_real64(json,p,path,val,found)
  2679. implicit none
  2680. class(json_core),intent(inout) :: json
  2681. type(json_value),pointer :: p
  2682. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2683. real(real64),intent(in) :: val !! the new value
  2684. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2685. call json%update(p,to_unicode(path),real(val,RK),found)
  2686. end subroutine wrap_json_update_real64
  2687. !*****************************************************************************************
  2688. #endif
  2689. !*****************************************************************************************
  2690. !> author: Jacob Williams
  2691. ! date: 12/6/2014
  2692. !
  2693. ! Given the path string, if the variable is present,
  2694. ! and is a scalar, then update its value.
  2695. ! If it is not present, then create it and set its value.
  2696. !
  2697. !@note If the variable is not a scalar, an exception will be thrown.
  2698. subroutine json_update_integer(json,p,path,val,found)
  2699. implicit none
  2700. class(json_core),intent(inout) :: json
  2701. type(json_value),pointer :: p
  2702. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2703. integer(IK),intent(in) :: val !! the new value
  2704. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2705. type(json_value),pointer :: p_var
  2706. integer(IK) :: var_type
  2707. call json%get(p,path,p_var,found)
  2708. if (found) then
  2709. call json%info(p_var,var_type)
  2710. select case (var_type)
  2711. case (json_null,json_logical,json_integer,json_real,json_string)
  2712. call json%to_integer(p_var,val) !update the value
  2713. case default
  2714. found = .false.
  2715. call json%throw_exception('Error in json_update_integer: '//&
  2716. 'the variable is not a scalar value',found)
  2717. end select
  2718. else
  2719. call json%add_by_path(p,path,val) !add the new element
  2720. end if
  2721. end subroutine json_update_integer
  2722. !*****************************************************************************************
  2723. !*****************************************************************************************
  2724. !>
  2725. ! Alternate version of [[json_update_integer]], where `path` is kind=CDK.
  2726. subroutine wrap_json_update_integer(json,p,path,val,found)
  2727. implicit none
  2728. class(json_core),intent(inout) :: json
  2729. type(json_value),pointer :: p
  2730. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2731. integer(IK),intent(in) :: val !! the new value
  2732. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2733. call json%update(p,to_unicode(path),val,found)
  2734. end subroutine wrap_json_update_integer
  2735. !*****************************************************************************************
  2736. !*****************************************************************************************
  2737. !> author: Jacob Williams
  2738. ! date: 12/6/2014
  2739. !
  2740. ! Given the path string, if the variable is present,
  2741. ! and is a scalar, then update its value.
  2742. ! If it is not present, then create it and set its value.
  2743. !
  2744. !@note If the variable is not a scalar, an exception will be thrown.
  2745. subroutine json_update_string(json,p,path,val,found,trim_str,adjustl_str)
  2746. implicit none
  2747. class(json_core),intent(inout) :: json
  2748. type(json_value),pointer :: p
  2749. character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
  2750. character(kind=CK,len=*),intent(in) :: val !! the new value
  2751. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2752. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  2753. !! (only used if `val` is present)
  2754. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  2755. !! (only used if `val` is present)
  2756. !! (note that ADJUSTL is done before TRIM)
  2757. type(json_value),pointer :: p_var
  2758. integer(IK) :: var_type
  2759. call json%get(p,path,p_var,found)
  2760. if (found) then
  2761. call json%info(p_var,var_type)
  2762. select case (var_type)
  2763. case (json_null,json_logical,json_integer,json_real,json_string)
  2764. call json%to_string(p_var,val,trim_str=trim_str,adjustl_str=adjustl_str) ! update the value
  2765. case default
  2766. found = .false.
  2767. call json%throw_exception('Error in json_update_string: '//&
  2768. 'the variable is not a scalar value',found)
  2769. end select
  2770. else
  2771. call json%add_by_path(p,path,val) !add the new element
  2772. end if
  2773. end subroutine json_update_string
  2774. !*****************************************************************************************
  2775. !*****************************************************************************************
  2776. !>
  2777. ! Alternate version of [[json_update_string]], where `path` and `value` are kind=CDK.
  2778. subroutine wrap_json_update_string(json,p,path,val,found,trim_str,adjustl_str)
  2779. implicit none
  2780. class(json_core),intent(inout) :: json
  2781. type(json_value),pointer :: p
  2782. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2783. character(kind=CDK,len=*),intent(in) :: val !! the new value
  2784. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2785. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  2786. !! (only used if `val` is present)
  2787. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  2788. !! (only used if `val` is present)
  2789. !! (note that ADJUSTL is done before TRIM)
  2790. call json%update(p,to_unicode(path),to_unicode(val),found,trim_str,adjustl_str)
  2791. end subroutine wrap_json_update_string
  2792. !*****************************************************************************************
  2793. !*****************************************************************************************
  2794. !>
  2795. ! Alternate version of [[json_update_string]], where `path` is kind=CDK.
  2796. subroutine json_update_string_name_ascii(json,p,path,val,found,trim_str,adjustl_str)
  2797. implicit none
  2798. class(json_core),intent(inout) :: json
  2799. type(json_value),pointer :: p
  2800. character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
  2801. character(kind=CK, len=*),intent(in) :: val !! the new value
  2802. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2803. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  2804. !! (only used if `val` is present)
  2805. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  2806. !! (only used if `val` is present)
  2807. !! (note that ADJUSTL is done before TRIM)
  2808. call json%update(p,to_unicode(path),val,found,trim_str,adjustl_str)
  2809. end subroutine json_update_string_name_ascii
  2810. !*****************************************************************************************
  2811. !*****************************************************************************************
  2812. !>
  2813. ! Alternate version of [[json_update_string]], where `val` is kind=CDK.
  2814. subroutine json_update_string_val_ascii(json,p,path,val,found,trim_str,adjustl_str)
  2815. implicit none
  2816. class(json_core),intent(inout) :: json
  2817. type(json_value),pointer :: p
  2818. character(kind=CK, len=*),intent(in) :: path !! path to the variable in the structure
  2819. character(kind=CDK,len=*),intent(in) :: val !! the new value
  2820. logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
  2821. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  2822. !! (only used if `val` is present)
  2823. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  2824. !! (only used if `val` is present)
  2825. !! (note that ADJUSTL is done before TRIM)
  2826. call json%update(p,path,to_unicode(val),found,trim_str,adjustl_str)
  2827. end subroutine json_update_string_val_ascii
  2828. !*****************************************************************************************
  2829. !*****************************************************************************************
  2830. !>
  2831. ! Adds `member` as a child of `p`.
  2832. subroutine json_value_add_member(json,p,member)
  2833. implicit none
  2834. class(json_core),intent(inout) :: json
  2835. type(json_value),pointer :: p !! `p` must be a `json_object`
  2836. !! or a `json_array`
  2837. type(json_value),pointer :: member !! the child member
  2838. !! to add to `p`
  2839. integer(IK) :: var_type !! variable type of `p`
  2840. if (.not. json%exception_thrown) then
  2841. if (associated(p)) then
  2842. call json%info(p,var_type=var_type)
  2843. select case (var_type)
  2844. case(json_object, json_array)
  2845. ! associate the parent
  2846. member%parent => p
  2847. ! add to linked list
  2848. if (associated(p%children)) then
  2849. p%tail%next => member
  2850. member%previous => p%tail
  2851. else
  2852. p%children => member
  2853. member%previous => null() !first in the list
  2854. end if
  2855. ! new member is now the last one in the list
  2856. p%tail => member
  2857. p%n_children = p%n_children + 1
  2858. case default
  2859. call json%throw_exception('Error in json_value_add_member: '//&
  2860. 'can only add child to object or array')
  2861. end select
  2862. else
  2863. call json%throw_exception('Error in json_value_add_member: '//&
  2864. 'the pointer is not associated')
  2865. end if
  2866. end if
  2867. end subroutine json_value_add_member
  2868. !*****************************************************************************************
  2869. !*****************************************************************************************
  2870. !>
  2871. ! Inserts `element` after `p`, and updates the JSON structure accordingly.
  2872. !
  2873. !### Example
  2874. !
  2875. !````fortran
  2876. ! program test
  2877. ! use json_module
  2878. ! implicit none
  2879. ! logical(json_LK) :: found
  2880. ! type(json_core) :: json
  2881. ! type(json_value),pointer :: p,new,element
  2882. ! call json%load(file='myfile.json', p=p)
  2883. ! call json%get(p,'x(3)',element,found) ! get pointer to an array element in the file
  2884. ! call json%create_integer(new,1,'') ! create a new element
  2885. ! call json%insert_after(element,new) ! insert new element after x(3)
  2886. ! call json%print(p,'myfile2.json') ! write it to a file
  2887. ! call json%destroy(p) ! cleanup
  2888. ! end program test
  2889. !````
  2890. !
  2891. !### Details
  2892. !
  2893. ! * This routine can be used to insert a new element (or set of elements)
  2894. ! into an array or object at a specific index.
  2895. ! See [[json_value_insert_after_child_by_index]]
  2896. ! * Children and subsequent elements of `element` are carried along.
  2897. ! * If the inserted elements are part of an existing list, then
  2898. ! they are removed from that list.
  2899. !
  2900. !````
  2901. ! p
  2902. ! [1] - [2] - [3] - [4]
  2903. ! |
  2904. ! [5] - [6] - [7] n=3 elements inserted
  2905. ! element last
  2906. !
  2907. ! Result is:
  2908. !
  2909. ! [1] - [2] - [5] - [6] - [7] - [3] - [4]
  2910. !
  2911. !````
  2912. subroutine json_value_insert_after(json,p,element)
  2913. implicit none
  2914. class(json_core),intent(inout) :: json
  2915. type(json_value),pointer :: p !! a value from a JSON structure
  2916. !! (presumably, this is a child of
  2917. !! an object or array).
  2918. type(json_value),pointer :: element !! the element to insert after `p`
  2919. type(json_value),pointer :: parent !! the parent of `p`
  2920. type(json_value),pointer :: next !! temp pointer for traversing structure
  2921. type(json_value),pointer :: last !! the last of the items being inserted
  2922. integer :: n !! number of items being inserted
  2923. if (.not. json%exception_thrown) then
  2924. parent => p%parent
  2925. ! set first parent of inserted list:
  2926. element%parent => parent
  2927. ! Count the number of inserted elements.
  2928. ! and set their parents.
  2929. n = 1 ! initialize counter
  2930. next => element%next
  2931. last => element
  2932. do
  2933. if (.not. associated(next)) exit
  2934. n = n + 1
  2935. next%parent => parent
  2936. last => next
  2937. next => next%next
  2938. end do
  2939. if (associated(parent)) then
  2940. ! update parent's child counter:
  2941. parent%n_children = parent%n_children + n
  2942. ! if p is last of parents children then
  2943. ! also have to update parent tail pointer:
  2944. if (associated(parent%tail,p)) then
  2945. parent%tail => last
  2946. end if
  2947. end if
  2948. if (associated(element%previous)) then
  2949. ! element is apparently part of an existing list,
  2950. ! so have to update that as well.
  2951. if (associated(element%previous%parent)) then
  2952. element%previous%parent%n_children = &
  2953. element%previous%parent%n_children - n
  2954. element%previous%parent%tail => &
  2955. element%previous ! now the last one in the list
  2956. else
  2957. ! this would be a memory leak if the previous entries
  2958. ! are not otherwise being pointed too
  2959. ! [throw an error in this case???]
  2960. end if
  2961. !remove element from the other list:
  2962. element%previous%next => null()
  2963. end if
  2964. element%previous => p
  2965. if (associated(p%next)) then
  2966. ! if there are any in the list after p:
  2967. last%next => p%next
  2968. last%next%previous => element
  2969. else
  2970. last%next => null()
  2971. end if
  2972. p%next => element
  2973. end if
  2974. end subroutine json_value_insert_after
  2975. !*****************************************************************************************
  2976. !*****************************************************************************************
  2977. !>
  2978. ! Inserts `element` after the `idx`-th child of `p`,
  2979. ! and updates the JSON structure accordingly. This is just
  2980. ! a wrapper for [[json_value_insert_after]].
  2981. subroutine json_value_insert_after_child_by_index(json,p,idx,element)
  2982. implicit none
  2983. class(json_core),intent(inout) :: json
  2984. type(json_value),pointer :: p !! a JSON object or array.
  2985. integer(IK),intent(in) :: idx !! the index of the child of `p` to
  2986. !! insert the new element after
  2987. !! (this is a 1-based Fortran
  2988. !! style array index)
  2989. type(json_value),pointer :: element !! the element to insert
  2990. type(json_value),pointer :: tmp !! for getting the `idx`-th child of `p`
  2991. if (.not. json%exception_thrown) then
  2992. ! get the idx-th child of p:
  2993. call json%get_child(p,idx,tmp)
  2994. ! call json_value_insert_after:
  2995. if (.not. json%exception_thrown) call json%insert_after(tmp,element)
  2996. end if
  2997. end subroutine json_value_insert_after_child_by_index
  2998. !*****************************************************************************************
  2999. !*****************************************************************************************
  3000. !>
  3001. ! Add a new member (`json_value` pointer) to a JSON structure, given the path.
  3002. !
  3003. !@warning If the path points to an existing variable in the structure,
  3004. ! then this routine will destroy it and replace it with the
  3005. ! new value.
  3006. subroutine json_add_member_by_path(json,me,path,p,found,was_created)
  3007. implicit none
  3008. class(json_core),intent(inout) :: json
  3009. type(json_value),pointer :: me !! the JSON structure
  3010. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3011. type(json_value),pointer,intent(in) :: p !! the value to add
  3012. logical(LK),intent(out),optional :: found !! if the variable was found
  3013. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3014. type(json_value),pointer :: tmp
  3015. character(kind=CK,len=:),allocatable :: name !! name of the variable
  3016. if ( .not. json%exception_thrown ) then
  3017. if (.not. associated(p)) then
  3018. call json%throw_exception('Error in json_add_member_by_path:'//&
  3019. ' Input pointer p is not associated.',found)
  3020. if (present(found)) then
  3021. found = .false.
  3022. call json%clear_exceptions()
  3023. end if
  3024. if ( present(was_created) ) was_created = .false.
  3025. else
  3026. ! return a pointer to the path (possibly creating it)
  3027. call json%create(me,path,tmp,found,was_created)
  3028. if (.not. associated(tmp)) then
  3029. call json%throw_exception('Error in json_add_member_by_path:'//&
  3030. ' Unable to resolve path: '//trim(path),found)
  3031. if (present(found)) then
  3032. found = .false.
  3033. call json%clear_exceptions()
  3034. end if
  3035. else
  3036. call json%info(tmp,name=name)
  3037. ! replace it with the new one:
  3038. call json%replace(tmp,p,destroy=.true.)
  3039. call json%rename(p,name)
  3040. end if
  3041. end if
  3042. else
  3043. if ( present(found) ) found = .false.
  3044. if ( present(was_created) ) was_created = .false.
  3045. end if
  3046. end subroutine json_add_member_by_path
  3047. !*****************************************************************************************
  3048. !*****************************************************************************************
  3049. !>
  3050. ! Wrapper to [[json_add_member_by_path]] where "path" is kind=CDK.
  3051. subroutine wrap_json_add_member_by_path(json,me,path,p,found,was_created)
  3052. implicit none
  3053. class(json_core),intent(inout) :: json
  3054. type(json_value),pointer :: me !! the JSON structure
  3055. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3056. type(json_value),pointer,intent(in) :: p !! the value to add
  3057. logical(LK),intent(out),optional :: found !! if the variable was found
  3058. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3059. call json%json_add_member_by_path(me,to_unicode(path),p,found,was_created)
  3060. end subroutine wrap_json_add_member_by_path
  3061. !*****************************************************************************************
  3062. !*****************************************************************************************
  3063. !>
  3064. ! Add an integer value to a [[json_value]], given the path.
  3065. !
  3066. !@warning If the path points to an existing variable in the structure,
  3067. ! then this routine will destroy it and replace it with the
  3068. ! new value.
  3069. subroutine json_add_integer_by_path(json,me,path,value,found,was_created)
  3070. implicit none
  3071. class(json_core),intent(inout) :: json
  3072. type(json_value),pointer :: me !! the JSON structure
  3073. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3074. integer(IK),intent(in) :: value !! the value to add
  3075. logical(LK),intent(out),optional :: found !! if the variable was found
  3076. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3077. type(json_value),pointer :: p
  3078. type(json_value),pointer :: tmp
  3079. character(kind=CK,len=:),allocatable :: name !! variable name
  3080. if ( .not. json%exception_thrown ) then
  3081. nullify(p)
  3082. ! return a pointer to the path (possibly creating it)
  3083. ! If the variable had to be created, then
  3084. ! it will be a json_null variable.
  3085. call json%create(me,path,p,found,was_created)
  3086. if (.not. associated(p)) then
  3087. call json%throw_exception('Error in json_add_integer_by_path:'//&
  3088. ' Unable to resolve path: '//trim(path),found)
  3089. if (present(found)) then
  3090. found = .false.
  3091. call json%clear_exceptions()
  3092. end if
  3093. else
  3094. !NOTE: a new object is created, and the old one
  3095. ! is replaced and destroyed. This is to
  3096. ! prevent memory leaks if the type is
  3097. ! being changed (for example, if an array
  3098. ! is being replaced with a scalar).
  3099. if (p%var_type==json_integer) then
  3100. p%int_value = value
  3101. else
  3102. call json%info(p,name=name)
  3103. call json%create_integer(tmp,value,name)
  3104. call json%replace(p,tmp,destroy=.true.)
  3105. end if
  3106. end if
  3107. else
  3108. if ( present(found) ) found = .false.
  3109. if ( present(was_created) ) was_created = .false.
  3110. end if
  3111. end subroutine json_add_integer_by_path
  3112. !*****************************************************************************************
  3113. !*****************************************************************************************
  3114. !>
  3115. ! Wrapper to [[json_add_integer_by_path]] where "path" is kind=CDK.
  3116. subroutine wrap_json_add_integer_by_path(json,me,path,value,found,was_created)
  3117. implicit none
  3118. class(json_core),intent(inout) :: json
  3119. type(json_value),pointer :: me !! the JSON structure
  3120. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3121. integer(IK),intent(in) :: value !! the value to add
  3122. logical(LK),intent(out),optional :: found !! if the variable was found
  3123. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3124. call json%json_add_integer_by_path(me,to_unicode(path),value,found,was_created)
  3125. end subroutine wrap_json_add_integer_by_path
  3126. !*****************************************************************************************
  3127. !*****************************************************************************************
  3128. !>
  3129. ! Add an real value to a [[json_value]], given the path.
  3130. !
  3131. !@warning If the path points to an existing variable in the structure,
  3132. ! then this routine will destroy it and replace it with the
  3133. ! new value.
  3134. subroutine json_add_real_by_path(json,me,path,value,found,was_created)
  3135. implicit none
  3136. class(json_core),intent(inout) :: json
  3137. type(json_value),pointer :: me !! the JSON structure
  3138. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3139. real(RK),intent(in) :: value !! the value to add
  3140. logical(LK),intent(out),optional :: found !! if the variable was found
  3141. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3142. type(json_value),pointer :: p
  3143. type(json_value),pointer :: tmp
  3144. character(kind=CK,len=:),allocatable :: name !! variable name
  3145. if ( .not. json%exception_thrown ) then
  3146. nullify(p)
  3147. ! return a pointer to the path (possibly creating it)
  3148. ! If the variable had to be created, then
  3149. ! it will be a json_null variable.
  3150. call json%create(me,path,p,found,was_created)
  3151. if (.not. associated(p)) then
  3152. call json%throw_exception('Error in json_add_real_by_path:'//&
  3153. ' Unable to resolve path: '//trim(path),found)
  3154. if (present(found)) then
  3155. found = .false.
  3156. call json%clear_exceptions()
  3157. end if
  3158. else
  3159. !NOTE: a new object is created, and the old one
  3160. ! is replaced and destroyed. This is to
  3161. ! prevent memory leaks if the type is
  3162. ! being changed (for example, if an array
  3163. ! is being replaced with a scalar).
  3164. if (p%var_type==json_real) then
  3165. p%dbl_value = value
  3166. else
  3167. call json%info(p,name=name)
  3168. call json%create_real(tmp,value,name)
  3169. call json%replace(p,tmp,destroy=.true.)
  3170. end if
  3171. end if
  3172. else
  3173. if ( present(found) ) found = .false.
  3174. if ( present(was_created) ) was_created = .false.
  3175. end if
  3176. end subroutine json_add_real_by_path
  3177. !*****************************************************************************************
  3178. !*****************************************************************************************
  3179. !>
  3180. ! Wrapper to [[json_add_real_by_path]] where "path" is kind=CDK.
  3181. subroutine wrap_json_add_real_by_path(json,me,path,value,found,was_created)
  3182. implicit none
  3183. class(json_core),intent(inout) :: json
  3184. type(json_value),pointer :: me !! the JSON structure
  3185. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3186. real(RK),intent(in) :: value !! the value to add
  3187. logical(LK),intent(out),optional :: found !! if the variable was found
  3188. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3189. call json%json_add_real_by_path(me,to_unicode(path),value,found,was_created)
  3190. end subroutine wrap_json_add_real_by_path
  3191. !*****************************************************************************************
  3192. #ifndef REAL32
  3193. !*****************************************************************************************
  3194. !>
  3195. ! Alternate version of [[json_add_real_by_path]] where value=real32.
  3196. subroutine json_add_real32_by_path(json,me,path,value,found,was_created)
  3197. implicit none
  3198. class(json_core),intent(inout) :: json
  3199. type(json_value),pointer :: me !! the JSON structure
  3200. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3201. real(real32),intent(in) :: value !! the value to add
  3202. logical(LK),intent(out),optional :: found !! if the variable was found
  3203. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3204. call json%add_by_path(me,path,real(value,RK),found,was_created)
  3205. end subroutine json_add_real32_by_path
  3206. !*****************************************************************************************
  3207. !*****************************************************************************************
  3208. !>
  3209. ! Wrapper to [[json_add_real32_by_path]] where "path" is kind=CDK.
  3210. subroutine wrap_json_add_real32_by_path(json,me,path,value,found,was_created)
  3211. implicit none
  3212. class(json_core),intent(inout) :: json
  3213. type(json_value),pointer :: me !! the JSON structure
  3214. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3215. real(real32),intent(in) :: value !! the value to add
  3216. logical(LK),intent(out),optional :: found !! if the variable was found
  3217. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3218. call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created)
  3219. end subroutine wrap_json_add_real32_by_path
  3220. !*****************************************************************************************
  3221. #endif
  3222. #ifdef REAL128
  3223. !*****************************************************************************************
  3224. !>
  3225. ! Alternate version of [[json_add_real_by_path]] where value=real32.
  3226. subroutine json_add_real64_by_path(json,me,path,value,found,was_created)
  3227. implicit none
  3228. class(json_core),intent(inout) :: json
  3229. type(json_value),pointer :: me !! the JSON structure
  3230. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3231. real(real64),intent(in) :: value !! the value to add
  3232. logical(LK),intent(out),optional :: found !! if the variable was found
  3233. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3234. call json%add_by_path(me,path,real(value,RK),found,was_created)
  3235. end subroutine json_add_real64_by_path
  3236. !*****************************************************************************************
  3237. !*****************************************************************************************
  3238. !>
  3239. ! Wrapper to [[json_add_real64_by_path]] where "path" is kind=CDK.
  3240. subroutine wrap_json_add_real64_by_path(json,me,path,value,found,was_created)
  3241. implicit none
  3242. class(json_core),intent(inout) :: json
  3243. type(json_value),pointer :: me !! the JSON structure
  3244. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3245. real(real64),intent(in) :: value !! the value to add
  3246. logical(LK),intent(out),optional :: found !! if the variable was found
  3247. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3248. call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created)
  3249. end subroutine wrap_json_add_real64_by_path
  3250. !*****************************************************************************************
  3251. #endif
  3252. !*****************************************************************************************
  3253. !>
  3254. ! Add a logical value to a [[json_value]], given the path.
  3255. !
  3256. !@warning If the path points to an existing variable in the structure,
  3257. ! then this routine will destroy it and replace it with the
  3258. ! new value.
  3259. subroutine json_add_logical_by_path(json,me,path,value,found,was_created)
  3260. implicit none
  3261. class(json_core),intent(inout) :: json
  3262. type(json_value),pointer :: me !! the JSON structure
  3263. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3264. logical(LK),intent(in) :: value !! the value to add
  3265. logical(LK),intent(out),optional :: found !! if the variable was found
  3266. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3267. type(json_value),pointer :: p
  3268. type(json_value),pointer :: tmp
  3269. character(kind=CK,len=:),allocatable :: name !! variable name
  3270. if ( .not. json%exception_thrown ) then
  3271. nullify(p)
  3272. ! return a pointer to the path (possibly creating it)
  3273. ! If the variable had to be created, then
  3274. ! it will be a json_null variable.
  3275. call json%create(me,path,p,found,was_created)
  3276. if (.not. associated(p)) then
  3277. call json%throw_exception('Error in json_add_logical_by_path:'//&
  3278. ' Unable to resolve path: '//trim(path),found)
  3279. if (present(found)) then
  3280. found = .false.
  3281. call json%clear_exceptions()
  3282. end if
  3283. else
  3284. !NOTE: a new object is created, and the old one
  3285. ! is replaced and destroyed. This is to
  3286. ! prevent memory leaks if the type is
  3287. ! being changed (for example, if an array
  3288. ! is being replaced with a scalar).
  3289. if (p%var_type==json_logical) then
  3290. p%log_value = value
  3291. else
  3292. call json%info(p,name=name)
  3293. call json%create_logical(tmp,value,name)
  3294. call json%replace(p,tmp,destroy=.true.)
  3295. end if
  3296. end if
  3297. else
  3298. if ( present(found) ) found = .false.
  3299. if ( present(was_created) ) was_created = .false.
  3300. end if
  3301. end subroutine json_add_logical_by_path
  3302. !*****************************************************************************************
  3303. !*****************************************************************************************
  3304. !>
  3305. ! Wrapper to [[json_add_logical_by_path]] where "path" is kind=CDK.
  3306. subroutine wrap_json_add_logical_by_path(json,me,path,value,found,was_created)
  3307. implicit none
  3308. class(json_core),intent(inout) :: json
  3309. type(json_value),pointer :: me !! the JSON structure
  3310. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3311. logical(LK),intent(in) :: value !! the value to add
  3312. logical(LK),intent(out),optional :: found !! if the variable was found
  3313. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3314. call json%json_add_logical_by_path(me,to_unicode(path),value,found,was_created)
  3315. end subroutine wrap_json_add_logical_by_path
  3316. !*****************************************************************************************
  3317. !*****************************************************************************************
  3318. !>
  3319. ! Add a string value to a [[json_value]], given the path.
  3320. !
  3321. !@warning If the path points to an existing variable in the structure,
  3322. ! then this routine will destroy it and replace it with the
  3323. ! new value.
  3324. subroutine json_add_string_by_path(json,me,path,value,found,&
  3325. was_created,trim_str,adjustl_str)
  3326. implicit none
  3327. class(json_core),intent(inout) :: json
  3328. type(json_value),pointer :: me !! the JSON structure
  3329. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3330. character(kind=CK,len=*),intent(in) :: value !! the value to add
  3331. logical(LK),intent(out),optional :: found !! if the variable was found
  3332. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3333. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3334. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3335. type(json_value),pointer :: p
  3336. type(json_value),pointer :: tmp
  3337. character(kind=CK,len=:),allocatable :: name !! variable name
  3338. if ( .not. json%exception_thrown ) then
  3339. nullify(p)
  3340. ! return a pointer to the path (possibly creating it)
  3341. ! If the variable had to be created, then
  3342. ! it will be a json_null variable.
  3343. call json%create(me,path,p,found,was_created)
  3344. if (.not. associated(p)) then
  3345. call json%throw_exception('Error in json_add_string_by_path:'//&
  3346. ' Unable to resolve path: '//trim(path),found)
  3347. if (present(found)) then
  3348. found = .false.
  3349. call json%clear_exceptions()
  3350. end if
  3351. else
  3352. !NOTE: a new object is created, and the old one
  3353. ! is replaced and destroyed. This is to
  3354. ! prevent memory leaks if the type is
  3355. ! being changed (for example, if an array
  3356. ! is being replaced with a scalar).
  3357. if (p%var_type==json_string) then
  3358. p%str_value = value
  3359. else
  3360. call json%info(p,name=name)
  3361. call json%create_string(tmp,value,name,trim_str,adjustl_str)
  3362. call json%replace(p,tmp,destroy=.true.)
  3363. end if
  3364. end if
  3365. else
  3366. if ( present(found) ) found = .false.
  3367. if ( present(was_created) ) was_created = .false.
  3368. end if
  3369. end subroutine json_add_string_by_path
  3370. !*****************************************************************************************
  3371. !*****************************************************************************************
  3372. !>
  3373. ! Wrapper to [[json_add_string_by_path]] where "path" is kind=CDK.
  3374. subroutine wrap_json_add_string_by_path(json,me,path,value,found,&
  3375. was_created,trim_str,adjustl_str)
  3376. implicit none
  3377. class(json_core),intent(inout) :: json
  3378. type(json_value),pointer :: me !! the JSON structure
  3379. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3380. character(kind=CDK,len=*),intent(in) :: value !! the value to add
  3381. logical(LK),intent(out),optional :: found !! if the variable was found
  3382. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3383. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3384. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3385. call json%json_add_string_by_path(me,to_unicode(path),to_unicode(value),&
  3386. found,was_created,trim_str,adjustl_str)
  3387. end subroutine wrap_json_add_string_by_path
  3388. !*****************************************************************************************
  3389. !*****************************************************************************************
  3390. !>
  3391. ! Wrapper for [[json_add_string_by_path]] where "path" is kind=CDK.
  3392. subroutine json_add_string_by_path_path_ascii(json,me,path,value,found,&
  3393. was_created,trim_str,adjustl_str)
  3394. implicit none
  3395. class(json_core),intent(inout) :: json
  3396. type(json_value),pointer :: me !! the JSON structure
  3397. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3398. character(kind=CK,len=*),intent(in) :: value !! the value to add
  3399. logical(LK),intent(out),optional :: found !! if the variable was found
  3400. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3401. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3402. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3403. call json%json_add_string_by_path(me,to_unicode(path),value,found,was_created,trim_str,adjustl_str)
  3404. end subroutine json_add_string_by_path_path_ascii
  3405. !*****************************************************************************************
  3406. !*****************************************************************************************
  3407. !>
  3408. ! Wrapper for [[json_add_string_by_path]] where "value" is kind=CDK.
  3409. subroutine json_add_string_by_path_value_ascii(json,me,path,value,found,&
  3410. was_created,trim_str,adjustl_str)
  3411. implicit none
  3412. class(json_core),intent(inout) :: json
  3413. type(json_value),pointer :: me !! the JSON structure
  3414. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3415. character(kind=CDK,len=*),intent(in) :: value !! the value to add
  3416. logical(LK),intent(out),optional :: found !! if the variable was found
  3417. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3418. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3419. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3420. call json%json_add_string_by_path(me,path,to_unicode(value),found,was_created,trim_str,adjustl_str)
  3421. end subroutine json_add_string_by_path_value_ascii
  3422. !*****************************************************************************************
  3423. !*****************************************************************************************
  3424. !>
  3425. ! Wrapper to [[json_add_integer_by_path]] for adding an integer vector by path.
  3426. subroutine json_add_integer_vec_by_path(json,me,path,value,found,was_created)
  3427. implicit none
  3428. class(json_core),intent(inout) :: json
  3429. type(json_value),pointer :: me !! the JSON structure
  3430. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3431. integer(IK),dimension(:),intent(in) :: value !! the vector to add
  3432. logical(LK),intent(out),optional :: found !! if the variable was found
  3433. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3434. type(json_value),pointer :: p !! pointer to path (which may exist)
  3435. type(json_value),pointer :: var !! new variable that is created
  3436. integer(IK) :: i !! counter
  3437. character(kind=CK,len=:),allocatable :: name !! the variable name
  3438. logical(LK) :: p_found !! if the path was successfully found (or created)
  3439. if ( .not. json%exception_thrown ) then
  3440. !get a pointer to the variable
  3441. !(creating it if necessary)
  3442. call json%create(me,path,p,found=p_found)
  3443. if (p_found) then
  3444. call json%info(p,name=name) ! want to keep the existing name
  3445. call json%create_array(var,name) ! create a new array variable
  3446. call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
  3447. !populate each element of the array:
  3448. do i=1,size(value)
  3449. call json%add(var, CK_'', value(i))
  3450. end do
  3451. end if
  3452. else
  3453. if ( present(found) ) found = .false.
  3454. if ( present(was_created) ) was_created = .false.
  3455. end if
  3456. end subroutine json_add_integer_vec_by_path
  3457. !*****************************************************************************************
  3458. !*****************************************************************************************
  3459. !>
  3460. ! Wrapper for [[json_add_integer_vec_by_path]] where "path" is kind=CDK).
  3461. subroutine wrap_json_add_integer_vec_by_path(json,me,path,value,found,was_created)
  3462. implicit none
  3463. class(json_core),intent(inout) :: json
  3464. type(json_value),pointer :: me !! the JSON structure
  3465. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3466. integer(IK),dimension(:),intent(in) :: value !! the vector to add
  3467. logical(LK),intent(out),optional :: found !! if the variable was found
  3468. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3469. call json%json_add_integer_vec_by_path(me,to_unicode(path),value,found,was_created)
  3470. end subroutine wrap_json_add_integer_vec_by_path
  3471. !*****************************************************************************************
  3472. !*****************************************************************************************
  3473. !>
  3474. ! Wrapper to [[json_add_logical_by_path]] for adding a logical vector by path.
  3475. subroutine json_add_logical_vec_by_path(json,me,path,value,found,was_created)
  3476. implicit none
  3477. class(json_core),intent(inout) :: json
  3478. type(json_value),pointer :: me !! the JSON structure
  3479. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3480. logical(LK),dimension(:),intent(in) :: value !! the vector to add
  3481. logical(LK),intent(out),optional :: found !! if the variable was found
  3482. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3483. type(json_value),pointer :: p !! pointer to path (which may exist)
  3484. type(json_value),pointer :: var !! new variable that is created
  3485. integer(IK) :: i !! counter
  3486. character(kind=CK,len=:),allocatable :: name !! the variable name
  3487. logical(LK) :: p_found !! if the path was successfully found (or created)
  3488. if ( .not. json%exception_thrown ) then
  3489. !get a pointer to the variable
  3490. !(creating it if necessary)
  3491. call json%create(me,path,p,found=p_found)
  3492. if (p_found) then
  3493. call json%info(p,name=name) ! want to keep the existing name
  3494. call json%create_array(var,name) ! create a new array variable
  3495. call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
  3496. !populate each element of the array:
  3497. do i=1,size(value)
  3498. call json%add(var, CK_'', value(i))
  3499. end do
  3500. end if
  3501. else
  3502. if ( present(found) ) found = .false.
  3503. if ( present(was_created) ) was_created = .false.
  3504. end if
  3505. end subroutine json_add_logical_vec_by_path
  3506. !*****************************************************************************************
  3507. !*****************************************************************************************
  3508. !>
  3509. ! Wrapper for [[json_add_logical_vec_by_path]] where "path" is kind=CDK).
  3510. subroutine wrap_json_add_logical_vec_by_path(json,me,path,value,found,was_created)
  3511. implicit none
  3512. class(json_core),intent(inout) :: json
  3513. type(json_value),pointer :: me !! the JSON structure
  3514. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3515. logical(LK),dimension(:),intent(in) :: value !! the vector to add
  3516. logical(LK),intent(out),optional :: found !! if the variable was found
  3517. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3518. call json%json_add_logical_vec_by_path(me,to_unicode(path),value,found,was_created)
  3519. end subroutine wrap_json_add_logical_vec_by_path
  3520. !*****************************************************************************************
  3521. !*****************************************************************************************
  3522. !>
  3523. ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path.
  3524. subroutine json_add_real_vec_by_path(json,me,path,value,found,was_created)
  3525. implicit none
  3526. class(json_core),intent(inout) :: json
  3527. type(json_value),pointer :: me !! the JSON structure
  3528. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3529. real(RK),dimension(:),intent(in) :: value !! the vector to add
  3530. logical(LK),intent(out),optional :: found !! if the variable was found
  3531. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3532. type(json_value),pointer :: p !! pointer to path (which may exist)
  3533. type(json_value),pointer :: var !! new variable that is created
  3534. integer(IK) :: i !! counter
  3535. character(kind=CK,len=:),allocatable :: name !! the variable name
  3536. logical(LK) :: p_found !! if the path was successfully found (or created)
  3537. if ( .not. json%exception_thrown ) then
  3538. !get a pointer to the variable
  3539. !(creating it if necessary)
  3540. call json%create(me,path,p,found=p_found)
  3541. if (p_found) then
  3542. call json%info(p,name=name) ! want to keep the existing name
  3543. call json%create_array(var,name) ! create a new array variable
  3544. call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
  3545. !populate each element of the array:
  3546. do i=1,size(value)
  3547. call json%add(var, CK_'', value(i))
  3548. end do
  3549. end if
  3550. else
  3551. if ( present(found) ) found = .false.
  3552. if ( present(was_created) ) was_created = .false.
  3553. end if
  3554. end subroutine json_add_real_vec_by_path
  3555. !*****************************************************************************************
  3556. !*****************************************************************************************
  3557. !>
  3558. ! Wrapper for [[json_add_real_vec_by_path]] where "path" is kind=CDK).
  3559. subroutine wrap_json_add_real_vec_by_path(json,me,path,value,found,was_created)
  3560. implicit none
  3561. class(json_core),intent(inout) :: json
  3562. type(json_value),pointer :: me !! the JSON structure
  3563. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3564. real(RK),dimension(:),intent(in) :: value !! the vector to add
  3565. logical(LK),intent(out),optional :: found !! if the variable was found
  3566. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3567. call json%json_add_real_vec_by_path(me,to_unicode(path),value,found,was_created)
  3568. end subroutine wrap_json_add_real_vec_by_path
  3569. !*****************************************************************************************
  3570. #ifndef REAL32
  3571. !*****************************************************************************************
  3572. !>
  3573. ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path.
  3574. subroutine json_add_real32_vec_by_path(json,me,path,value,found,was_created)
  3575. implicit none
  3576. class(json_core),intent(inout) :: json
  3577. type(json_value),pointer :: me !! the JSON structure
  3578. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3579. real(real32),dimension(:),intent(in) :: value !! the vector to add
  3580. logical(LK),intent(out),optional :: found !! if the variable was found
  3581. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3582. call json%add_by_path(me,path,real(value,RK),found,was_created)
  3583. end subroutine json_add_real32_vec_by_path
  3584. !*****************************************************************************************
  3585. !*****************************************************************************************
  3586. !>
  3587. ! Wrapper for [[json_add_real32_vec_by_path]] where "path" is kind=CDK).
  3588. subroutine wrap_json_add_real32_vec_by_path(json,me,path,value,found,was_created)
  3589. implicit none
  3590. class(json_core),intent(inout) :: json
  3591. type(json_value),pointer :: me !! the JSON structure
  3592. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3593. real(real32),dimension(:),intent(in) :: value !! the vector to add
  3594. logical(LK),intent(out),optional :: found !! if the variable was found
  3595. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3596. call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created)
  3597. end subroutine wrap_json_add_real32_vec_by_path
  3598. !*****************************************************************************************
  3599. #endif
  3600. #ifdef REAL128
  3601. !*****************************************************************************************
  3602. !>
  3603. ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path.
  3604. subroutine json_add_real64_vec_by_path(json,me,path,value,found,was_created)
  3605. implicit none
  3606. class(json_core),intent(inout) :: json
  3607. type(json_value),pointer :: me !! the JSON structure
  3608. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3609. real(real64),dimension(:),intent(in) :: value !! the vector to add
  3610. logical(LK),intent(out),optional :: found !! if the variable was found
  3611. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3612. call json%add_by_path(me,path,real(value,RK),found,was_created)
  3613. end subroutine json_add_real64_vec_by_path
  3614. !*****************************************************************************************
  3615. !*****************************************************************************************
  3616. !>
  3617. ! Wrapper for [[json_add_real64_vec_by_path]] where "path" is kind=CDK).
  3618. subroutine wrap_json_add_real64_vec_by_path(json,me,path,value,found,was_created)
  3619. implicit none
  3620. class(json_core),intent(inout) :: json
  3621. type(json_value),pointer :: me !! the JSON structure
  3622. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3623. real(real64),dimension(:),intent(in) :: value !! the vector to add
  3624. logical(LK),intent(out),optional :: found !! if the variable was found
  3625. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3626. call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created)
  3627. end subroutine wrap_json_add_real64_vec_by_path
  3628. !*****************************************************************************************
  3629. #endif
  3630. !*****************************************************************************************
  3631. !>
  3632. ! Wrapper to [[json_add_string_by_path]] for adding a string vector by path.
  3633. !
  3634. !@note The `ilen` input can be used to specify the actual lengths of the
  3635. ! the strings in the array. They must all be `<= len(value)`.
  3636. subroutine json_add_string_vec_by_path(json,me,path,value,found,was_created,ilen,trim_str,adjustl_str)
  3637. implicit none
  3638. class(json_core),intent(inout) :: json
  3639. type(json_value),pointer :: me !! the JSON structure
  3640. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3641. character(kind=CK,len=*),dimension(:),intent(in) :: value !! the vector to add
  3642. logical(LK),intent(out),optional :: found !! if the variable was found
  3643. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3644. integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
  3645. !! element in `value`. If not present,
  3646. !! the full `len(value)` string is added
  3647. !! for each element.
  3648. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3649. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3650. type(json_value),pointer :: p !! pointer to path (which may exist)
  3651. type(json_value),pointer :: var !! new variable that is created
  3652. integer(IK) :: i !! counter
  3653. character(kind=CK,len=:),allocatable :: name !! the variable name
  3654. logical(LK) :: p_found !! if the path was successfully found (or created)
  3655. if ( .not. json%exception_thrown ) then
  3656. ! validate ilen array if present:
  3657. if (present(ilen)) then
  3658. if (size(ilen)/=size(value)) then
  3659. call json%throw_exception('Error in json_add_string_vec_by_path: '//&
  3660. 'Invalid size of ilen input vector.',found)
  3661. if (present(found)) then
  3662. found = .false.
  3663. call json%clear_exceptions()
  3664. end if
  3665. if (present(was_created)) was_created = .false.
  3666. return
  3667. else
  3668. ! also have to validate the specified lengths.
  3669. ! (must not be greater than input string length)
  3670. do i = 1, size(value)
  3671. if (ilen(i)>len(value)) then
  3672. call json%throw_exception('Error in json_add_string_vec_by_path: '//&
  3673. 'Invalid ilen element.',found)
  3674. if (present(found)) then
  3675. found = .false.
  3676. call json%clear_exceptions()
  3677. end if
  3678. if (present(was_created)) was_created = .false.
  3679. return
  3680. end if
  3681. end do
  3682. end if
  3683. end if
  3684. !get a pointer to the variable
  3685. !(creating it if necessary)
  3686. call json%create(me,path,p,found=p_found)
  3687. if (p_found) then
  3688. call json%info(p,name=name) ! want to keep the existing name
  3689. call json%create_array(var,name) ! create a new array variable
  3690. call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
  3691. !populate each element of the array:
  3692. do i=1,size(value)
  3693. if (present(ilen)) then
  3694. call json%add(var, CK_'', value(i)(1:ilen(i)), &
  3695. trim_str=trim_str, adjustl_str=adjustl_str)
  3696. else
  3697. call json%add(var, CK_'', value(i), &
  3698. trim_str=trim_str, adjustl_str=adjustl_str)
  3699. end if
  3700. end do
  3701. end if
  3702. else
  3703. if ( present(found) ) found = .false.
  3704. if ( present(was_created) ) was_created = .false.
  3705. end if
  3706. end subroutine json_add_string_vec_by_path
  3707. !*****************************************************************************************
  3708. !*****************************************************************************************
  3709. !>
  3710. ! Wrapper for [[json_add_string_vec_by_path]] where "path" and "value" are kind=CDK).
  3711. subroutine wrap_json_add_string_vec_by_path(json,me,path,value,&
  3712. found,was_created,ilen,&
  3713. trim_str,adjustl_str)
  3714. implicit none
  3715. class(json_core),intent(inout) :: json
  3716. type(json_value),pointer :: me !! the JSON structure
  3717. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3718. character(kind=CDK,len=*),dimension(:),intent(in):: value !! the vector to add
  3719. logical(LK),intent(out),optional :: found !! if the variable was found
  3720. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3721. integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
  3722. !! element in `value`. If not present,
  3723. !! the full `len(value)` string is added
  3724. !! for each element.
  3725. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3726. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3727. call json%json_add_string_vec_by_path(me,to_unicode(path),to_unicode(value),&
  3728. found,was_created,ilen,trim_str,adjustl_str)
  3729. end subroutine wrap_json_add_string_vec_by_path
  3730. !*****************************************************************************************
  3731. !*****************************************************************************************
  3732. !>
  3733. ! Wrapper for [[json_add_string_vec_by_path]] where "value" is kind=CDK).
  3734. subroutine json_add_string_vec_by_path_value_ascii(json,me,path,value,&
  3735. found,was_created,ilen,&
  3736. trim_str,adjustl_str)
  3737. implicit none
  3738. class(json_core),intent(inout) :: json
  3739. type(json_value),pointer :: me !! the JSON structure
  3740. character(kind=CK,len=*),intent(in) :: path !! the path to the variable
  3741. character(kind=CDK,len=*),dimension(:),intent(in):: value !! the vector to add
  3742. logical(LK),intent(out),optional :: found !! if the variable was found
  3743. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3744. integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
  3745. !! element in `value`. If not present,
  3746. !! the full `len(value)` string is added
  3747. !! for each element.
  3748. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3749. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3750. call json%json_add_string_vec_by_path(me,path,to_unicode(value),&
  3751. found,was_created,ilen,trim_str,adjustl_str)
  3752. end subroutine json_add_string_vec_by_path_value_ascii
  3753. !*****************************************************************************************
  3754. !*****************************************************************************************
  3755. !>
  3756. ! Wrapper for [[json_add_string_vec_by_path]] where "path" is kind=CDK).
  3757. subroutine json_add_string_vec_by_path_path_ascii(json,me,path,value,&
  3758. found,was_created,ilen,&
  3759. trim_str,adjustl_str)
  3760. implicit none
  3761. class(json_core),intent(inout) :: json
  3762. type(json_value),pointer :: me !! the JSON structure
  3763. character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
  3764. character(kind=CK,len=*),dimension(:),intent(in) :: value !! the vector to add
  3765. logical(LK),intent(out),optional :: found !! if the variable was found
  3766. logical(LK),intent(out),optional :: was_created !! if the variable had to be created
  3767. integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
  3768. !! element in `value`. If not present,
  3769. !! the full `len(value)` string is added
  3770. !! for each element.
  3771. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  3772. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  3773. call json%json_add_string_vec_by_path(me,to_unicode(path),value,&
  3774. found,was_created,ilen,trim_str,adjustl_str)
  3775. end subroutine json_add_string_vec_by_path_path_ascii
  3776. !*****************************************************************************************
  3777. !*****************************************************************************************
  3778. !> author: Jacob Williams
  3779. ! date: 1/19/2014
  3780. !
  3781. ! Add a real value child to the [[json_value]] variable.
  3782. !
  3783. !@note This routine is part of the public API that can be
  3784. ! used to build a JSON structure using [[json_value]] pointers.
  3785. subroutine json_value_add_real(json,p,name,val)
  3786. implicit none
  3787. class(json_core),intent(inout) :: json
  3788. type(json_value),pointer :: p
  3789. character(kind=CK,len=*),intent(in) :: name !! variable name
  3790. real(RK),intent(in) :: val !! real value
  3791. type(json_value),pointer :: var
  3792. !create the variable:
  3793. call json%create_real(var,val,name)
  3794. !add it:
  3795. call json%add(p, var)
  3796. end subroutine json_value_add_real
  3797. !*****************************************************************************************
  3798. !*****************************************************************************************
  3799. !>
  3800. ! Alternate version of [[json_value_add_real]] where `name` is kind=CDK.
  3801. subroutine wrap_json_value_add_real(json,p,name,val)
  3802. implicit none
  3803. class(json_core),intent(inout) :: json
  3804. type(json_value),pointer :: p
  3805. character(kind=CDK,len=*),intent(in) :: name !! variable name
  3806. real(RK),intent(in) :: val !! real value
  3807. call json%add(p, to_unicode(name), val)
  3808. end subroutine wrap_json_value_add_real
  3809. !*****************************************************************************************
  3810. !*****************************************************************************************
  3811. !> author: Jacob Williams
  3812. ! date: 1/20/2014
  3813. !
  3814. ! Add a real vector child to the [[json_value]] variable.
  3815. !
  3816. !@note This routine is part of the public API that can be
  3817. ! used to build a JSON structure using [[json_value]] pointers.
  3818. subroutine json_value_add_real_vec(json, p, name, val)
  3819. implicit none
  3820. class(json_core),intent(inout) :: json
  3821. type(json_value),pointer :: p
  3822. character(kind=CK,len=*),intent(in) :: name
  3823. real(RK),dimension(:),intent(in) :: val
  3824. type(json_value),pointer :: var
  3825. integer(IK) :: i !! counter
  3826. !create the variable as an array:
  3827. call json%create_array(var,name)
  3828. !populate the array:
  3829. do i=1,size(val)
  3830. call json%add(var, CK_'', val(i))
  3831. end do
  3832. !add it:
  3833. call json%add(p, var)
  3834. end subroutine json_value_add_real_vec
  3835. !*****************************************************************************************
  3836. !*****************************************************************************************
  3837. !>
  3838. ! Alternate version of [[json_value_add_real_vec]] where `name` is kind=CDK.
  3839. subroutine wrap_json_value_add_real_vec(json, p, name, val)
  3840. implicit none
  3841. class(json_core),intent(inout) :: json
  3842. type(json_value),pointer :: p
  3843. character(kind=CDK,len=*),intent(in) :: name
  3844. real(RK),dimension(:),intent(in) :: val
  3845. call json%add(p, to_unicode(name), val)
  3846. end subroutine wrap_json_value_add_real_vec
  3847. !*****************************************************************************************
  3848. #ifndef REAL32
  3849. !*****************************************************************************************
  3850. !>
  3851. ! Alternate version of [[json_value_add_real]] where `val` is `real32`.
  3852. subroutine json_value_add_real32(json,p,name,val)
  3853. implicit none
  3854. class(json_core),intent(inout) :: json
  3855. type(json_value),pointer :: p
  3856. character(kind=CK,len=*),intent(in) :: name !! variable name
  3857. real(real32),intent(in) :: val !! real value
  3858. call json%add(p,name,real(val,RK))
  3859. end subroutine json_value_add_real32
  3860. !*****************************************************************************************
  3861. !*****************************************************************************************
  3862. !>
  3863. ! Alternate version of [[json_value_add_real32]] where `name` is kind=CDK.
  3864. subroutine wrap_json_value_add_real32(json,p,name,val)
  3865. implicit none
  3866. class(json_core),intent(inout) :: json
  3867. type(json_value),pointer :: p
  3868. character(kind=CDK,len=*),intent(in) :: name !! variable name
  3869. real(real32),intent(in) :: val !! real value
  3870. call json%add(p, to_unicode(name), val)
  3871. end subroutine wrap_json_value_add_real32
  3872. !*****************************************************************************************
  3873. !*****************************************************************************************
  3874. !>
  3875. ! Alternate version of [[json_value_add_real_vec]] where `val` is `real32`.
  3876. subroutine json_value_add_real32_vec(json, p, name, val)
  3877. implicit none
  3878. class(json_core),intent(inout) :: json
  3879. type(json_value),pointer :: p
  3880. character(kind=CK,len=*),intent(in) :: name
  3881. real(real32),dimension(:),intent(in) :: val
  3882. call json%add(p,name,real(val,RK))
  3883. end subroutine json_value_add_real32_vec
  3884. !*****************************************************************************************
  3885. !*****************************************************************************************
  3886. !>
  3887. ! Alternate version of [[json_value_add_real32_vec]] where `name` is kind=CDK.
  3888. subroutine wrap_json_value_add_real32_vec(json, p, name, val)
  3889. implicit none
  3890. class(json_core),intent(inout) :: json
  3891. type(json_value),pointer :: p
  3892. character(kind=CDK,len=*),intent(in) :: name
  3893. real(real32),dimension(:),intent(in) :: val
  3894. call json%add(p, to_unicode(name), val)
  3895. end subroutine wrap_json_value_add_real32_vec
  3896. !*****************************************************************************************
  3897. #endif
  3898. #ifdef REAL128
  3899. !*****************************************************************************************
  3900. !>
  3901. ! Alternate version of [[json_value_add_real]] where `val` is `real64`.
  3902. subroutine json_value_add_real64(json,p,name,val)
  3903. implicit none
  3904. class(json_core),intent(inout) :: json
  3905. type(json_value),pointer :: p
  3906. character(kind=CK,len=*),intent(in) :: name !! variable name
  3907. real(real64),intent(in) :: val !! real value
  3908. call json%add(p,name,real(val,RK))
  3909. end subroutine json_value_add_real64
  3910. !*****************************************************************************************
  3911. !*****************************************************************************************
  3912. !>
  3913. ! Alternate version of [[json_value_add_real64]] where `name` is kind=CDK.
  3914. subroutine wrap_json_value_add_real64(json,p,name,val)
  3915. implicit none
  3916. class(json_core),intent(inout) :: json
  3917. type(json_value),pointer :: p
  3918. character(kind=CDK,len=*),intent(in) :: name !! variable name
  3919. real(real64),intent(in) :: val !! real value
  3920. call json%add(p, to_unicode(name), val)
  3921. end subroutine wrap_json_value_add_real64
  3922. !*****************************************************************************************
  3923. !*****************************************************************************************
  3924. !>
  3925. ! Alternate version of [[json_value_add_real_vec]] where `val` is `real64`.
  3926. subroutine json_value_add_real64_vec(json, p, name, val)
  3927. implicit none
  3928. class(json_core),intent(inout) :: json
  3929. type(json_value),pointer :: p
  3930. character(kind=CK,len=*),intent(in) :: name
  3931. real(real64),dimension(:),intent(in) :: val
  3932. call json%add(p, name, real(val,RK))
  3933. end subroutine json_value_add_real64_vec
  3934. !*****************************************************************************************
  3935. !*****************************************************************************************
  3936. !>
  3937. ! Alternate version of [[json_value_add_real64_vec]] where `name` is kind=CDK.
  3938. subroutine wrap_json_value_add_real64_vec(json, p, name, val)
  3939. implicit none
  3940. class(json_core),intent(inout) :: json
  3941. type(json_value),pointer :: p
  3942. character(kind=CDK,len=*),intent(in) :: name
  3943. real(real64),dimension(:),intent(in) :: val
  3944. call json%add(p, to_unicode(name), val)
  3945. end subroutine wrap_json_value_add_real64_vec
  3946. !*****************************************************************************************
  3947. #endif
  3948. !*****************************************************************************************
  3949. !>
  3950. ! Add a NULL value child to the [[json_value]] variable.
  3951. !
  3952. !@note This routine is part of the public API that can be
  3953. ! used to build a JSON structure using [[json_value]] pointers.
  3954. subroutine json_value_add_null(json, p, name)
  3955. implicit none
  3956. class(json_core),intent(inout) :: json
  3957. type(json_value),pointer :: p
  3958. character(kind=CK,len=*),intent(in) :: name
  3959. type(json_value),pointer :: var
  3960. !create the variable:
  3961. call json%create_null(var,name)
  3962. !add it:
  3963. call json%add(p, var)
  3964. end subroutine json_value_add_null
  3965. !*****************************************************************************************
  3966. !*****************************************************************************************
  3967. !>
  3968. ! Alternate version of [[json_value_add_null]] where `name` is kind=CDK.
  3969. subroutine wrap_json_value_add_null(json, p, name)
  3970. implicit none
  3971. class(json_core),intent(inout) :: json
  3972. type(json_value),pointer :: p
  3973. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  3974. call json%add(p, to_unicode(name))
  3975. end subroutine wrap_json_value_add_null
  3976. !*****************************************************************************************
  3977. !*****************************************************************************************
  3978. !> author: Jacob Williams
  3979. ! date: 1/20/2014
  3980. !
  3981. ! Add an integer value child to the [[json_value]] variable.
  3982. !
  3983. !@note This routine is part of the public API that can be
  3984. ! used to build a JSON structure using [[json_value]] pointers.
  3985. subroutine json_value_add_integer(json, p, name, val)
  3986. implicit none
  3987. class(json_core),intent(inout) :: json
  3988. type(json_value),pointer :: p
  3989. character(kind=CK,len=*),intent(in) :: name
  3990. integer(IK),intent(in) :: val
  3991. type(json_value),pointer :: var
  3992. !create the variable:
  3993. call json%create_integer(var,val,name)
  3994. !add it:
  3995. call json%add(p, var)
  3996. end subroutine json_value_add_integer
  3997. !*****************************************************************************************
  3998. !*****************************************************************************************
  3999. !>
  4000. ! Alternate version of [[json_value_add_integer]] where `name` is kind=CDK.
  4001. subroutine wrap_json_value_add_integer(json, p, name, val)
  4002. implicit none
  4003. class(json_core),intent(inout) :: json
  4004. type(json_value),pointer :: p
  4005. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4006. integer(IK),intent(in) :: val !! value
  4007. call json%add(p, to_unicode(name), val)
  4008. end subroutine wrap_json_value_add_integer
  4009. !*****************************************************************************************
  4010. !*****************************************************************************************
  4011. !> author: Jacob Williams
  4012. ! date: 1/20/2014
  4013. !
  4014. ! Add a integer vector child to the [[json_value]] variable.
  4015. !
  4016. !@note This routine is part of the public API that can be
  4017. ! used to build a JSON structure using [[json_value]] pointers.
  4018. subroutine json_value_add_integer_vec(json, p, name, val)
  4019. implicit none
  4020. class(json_core),intent(inout) :: json
  4021. type(json_value),pointer :: p
  4022. character(kind=CK,len=*),intent(in) :: name !! name of the variable
  4023. integer(IK),dimension(:),intent(in) :: val !! value
  4024. type(json_value),pointer :: var
  4025. integer(IK) :: i !! counter
  4026. !create a variable as an array:
  4027. call json%create_array(var,name)
  4028. !populate the array:
  4029. do i=1,size(val)
  4030. call json%add(var, CK_'', val(i))
  4031. end do
  4032. !add it:
  4033. call json%add(p, var)
  4034. end subroutine json_value_add_integer_vec
  4035. !*****************************************************************************************
  4036. !*****************************************************************************************
  4037. !>
  4038. ! Alternate version of [[json_value_add_integer_vec]] where `name` is kind=CDK.
  4039. subroutine wrap_json_value_add_integer_vec(json, p, name, val)
  4040. implicit none
  4041. class(json_core),intent(inout) :: json
  4042. type(json_value),pointer :: p
  4043. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4044. integer(IK),dimension(:),intent(in) :: val !! value
  4045. call json%add(p, to_unicode(name), val)
  4046. end subroutine wrap_json_value_add_integer_vec
  4047. !*****************************************************************************************
  4048. !*****************************************************************************************
  4049. !> author: Jacob Williams
  4050. ! date: 1/20/2014
  4051. !
  4052. ! Add a logical value child to the [[json_value]] variable.
  4053. !
  4054. !@note This routine is part of the public API that can be
  4055. ! used to build a JSON structure using [[json_value]] pointers.
  4056. subroutine json_value_add_logical(json, p, name, val)
  4057. implicit none
  4058. class(json_core),intent(inout) :: json
  4059. type(json_value),pointer :: p
  4060. character(kind=CK,len=*),intent(in) :: name !! name of the variable
  4061. logical(LK),intent(in) :: val !! value
  4062. type(json_value),pointer :: var
  4063. !create the variable:
  4064. call json%create_logical(var,val,name)
  4065. !add it:
  4066. call json%add(p, var)
  4067. end subroutine json_value_add_logical
  4068. !*****************************************************************************************
  4069. !*****************************************************************************************
  4070. !>
  4071. ! Alternate version of [[json_value_add_logical]] where `name` is kind=CDK.
  4072. subroutine wrap_json_value_add_logical(json, p, name, val)
  4073. implicit none
  4074. class(json_core),intent(inout) :: json
  4075. type(json_value),pointer :: p
  4076. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4077. logical(LK),intent(in) :: val !! value
  4078. call json%add(p, to_unicode(name), val)
  4079. end subroutine wrap_json_value_add_logical
  4080. !*****************************************************************************************
  4081. !*****************************************************************************************
  4082. !> author: Jacob Williams
  4083. ! date: 1/20/2014
  4084. !
  4085. ! Add a logical vector child to the [[json_value]] variable.
  4086. !
  4087. !@note This routine is part of the public API that can be
  4088. ! used to build a JSON structure using [[json_value]] pointers.
  4089. subroutine json_value_add_logical_vec(json, p, name, val)
  4090. implicit none
  4091. class(json_core),intent(inout) :: json
  4092. type(json_value),pointer :: p
  4093. character(kind=CK,len=*),intent(in) :: name !! name of the vector
  4094. logical(LK),dimension(:),intent(in) :: val !! value
  4095. type(json_value),pointer :: var
  4096. integer(IK) :: i !! counter
  4097. !create the variable as an array:
  4098. call json%create_array(var,name)
  4099. !populate the array:
  4100. do i=1,size(val)
  4101. call json%add(var, CK_'', val(i))
  4102. end do
  4103. !add it:
  4104. call json%add(p, var)
  4105. end subroutine json_value_add_logical_vec
  4106. !*****************************************************************************************
  4107. !*****************************************************************************************
  4108. !>
  4109. ! Alternate version of [[json_value_add_logical_vec]] where `name` is kind=CDK.
  4110. subroutine wrap_json_value_add_logical_vec(json, p, name, val)
  4111. implicit none
  4112. class(json_core),intent(inout) :: json
  4113. type(json_value),pointer :: p
  4114. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4115. logical(LK),dimension(:),intent(in) :: val !! value
  4116. call json%add(p, to_unicode(name), val)
  4117. end subroutine wrap_json_value_add_logical_vec
  4118. !*****************************************************************************************
  4119. !*****************************************************************************************
  4120. !> author: Jacob Williams
  4121. ! date: 1/19/2014
  4122. !
  4123. ! Add a character string child to the [[json_value]] variable.
  4124. !
  4125. !@note This routine is part of the public API that can be
  4126. ! used to build a JSON structure using [[json_value]] pointers.
  4127. subroutine json_value_add_string(json, p, name, val, trim_str, adjustl_str)
  4128. implicit none
  4129. class(json_core),intent(inout) :: json
  4130. type(json_value),pointer :: p
  4131. character(kind=CK,len=*),intent(in) :: name !! name of the variable
  4132. character(kind=CK,len=*),intent(in) :: val !! value
  4133. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  4134. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  4135. type(json_value),pointer :: var
  4136. !create the variable:
  4137. call json%create_string(var,val,name,trim_str,adjustl_str)
  4138. !add it:
  4139. call json%add(p, var)
  4140. end subroutine json_value_add_string
  4141. !*****************************************************************************************
  4142. !*****************************************************************************************
  4143. !>
  4144. ! Alternate version of [[json_value_add_string]] where `name` and `val` are kind=CDK.
  4145. subroutine wrap_json_value_add_string(json, p, name, val, trim_str, adjustl_str)
  4146. implicit none
  4147. class(json_core),intent(inout) :: json
  4148. type(json_value),pointer :: p
  4149. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4150. character(kind=CDK,len=*),intent(in) :: val !! value
  4151. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  4152. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  4153. call json%add(p, to_unicode(name), to_unicode(val), trim_str, adjustl_str)
  4154. end subroutine wrap_json_value_add_string
  4155. !*****************************************************************************************
  4156. !*****************************************************************************************
  4157. !>
  4158. ! Alternate version of [[json_value_add_string]] where `name` is kind=CDK.
  4159. subroutine json_value_add_string_name_ascii(json, p, name, val, trim_str, adjustl_str)
  4160. implicit none
  4161. class(json_core),intent(inout) :: json
  4162. type(json_value),pointer :: p
  4163. character(kind=CDK,len=*),intent(in) :: name !! name of the variable
  4164. character(kind=CK, len=*),intent(in) :: val !! value
  4165. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  4166. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  4167. call json%add(p, to_unicode(name), val, trim_str, adjustl_str)
  4168. end subroutine json_value_add_string_name_ascii
  4169. !*****************************************************************************************
  4170. !*****************************************************************************************
  4171. !>
  4172. ! Alternate version of [[json_value_add_string]] where `val` is kind=CDK.
  4173. subroutine json_value_add_string_val_ascii(json, p, name, val, trim_str, adjustl_str)
  4174. implicit none
  4175. class(json_core),intent(inout) :: json
  4176. type(json_value),pointer :: p
  4177. character(kind=CK, len=*),intent(in) :: name !! name of the variable
  4178. character(kind=CDK,len=*),intent(in) :: val !! value
  4179. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  4180. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  4181. call json%add(p, name, to_unicode(val), trim_str, adjustl_str)
  4182. end subroutine json_value_add_string_val_ascii
  4183. !*****************************************************************************************
  4184. !*****************************************************************************************
  4185. !> author: Jacob Williams
  4186. ! date: 1/19/2014
  4187. !
  4188. ! Add a character string vector child to the [[json_value]] variable.
  4189. !
  4190. !@note This routine is part of the public API that can be
  4191. ! used to build a JSON structure using [[json_value]] pointers.
  4192. subroutine json_value_add_string_vec(json, p, name, val, trim_str, adjustl_str)
  4193. implicit none
  4194. class(json_core),intent(inout) :: json
  4195. type(json_value),pointer :: p
  4196. character(kind=CK,len=*),intent(in) :: name !! variable name
  4197. character(kind=CK,len=*),dimension(:),intent(in) :: val !! array of strings
  4198. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
  4199. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
  4200. type(json_value),pointer :: var
  4201. integer(IK) :: i !! counter
  4202. !create the variable as an array:
  4203. call json%create_array(var,name)
  4204. !populate the array:
  4205. do i=1,size(val)
  4206. call json%add(var, CK_'', val(i), trim_str, adjustl_str)
  4207. end do
  4208. !add it:
  4209. call json%add(p, var)
  4210. end subroutine json_value_add_string_vec
  4211. !*****************************************************************************************
  4212. !*****************************************************************************************
  4213. !>
  4214. ! Alternate version of [[json_value_add_string_vec]] where `name` and `val` are kind=CDK.
  4215. subroutine wrap_json_value_add_string_vec(json, p, name, val, trim_str, adjustl_str)
  4216. implicit none
  4217. class(json_core),intent(inout) :: json
  4218. type(json_value),pointer :: p
  4219. character(kind=CDK,len=*),intent(in) :: name
  4220. character(kind=CDK,len=*),dimension(:),intent(in) :: val
  4221. logical(LK),intent(in),optional :: trim_str
  4222. logical(LK),intent(in),optional :: adjustl_str
  4223. call json%add(p, to_unicode(name), to_unicode(val), trim_str, adjustl_str)
  4224. end subroutine wrap_json_value_add_string_vec
  4225. !*****************************************************************************************
  4226. !*****************************************************************************************
  4227. !>
  4228. ! Alternate version of [[json_value_add_string_vec]] where `name` is kind=CDK.
  4229. subroutine json_value_add_string_vec_name_ascii(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=CDK,len=*),intent(in) :: name
  4234. character(kind=CK, len=*),dimension(:),intent(in) :: val
  4235. logical(LK),intent(in),optional :: trim_str
  4236. logical(LK),intent(in),optional :: adjustl_str
  4237. call json%add(p, to_unicode(name), val, trim_str, adjustl_str)
  4238. end subroutine json_value_add_string_vec_name_ascii
  4239. !*****************************************************************************************
  4240. !*****************************************************************************************
  4241. !>
  4242. ! Alternate version of [[json_value_add_string_vec]] where `val` is kind=CDK.
  4243. subroutine json_value_add_string_vec_val_ascii(json, p, name, val, trim_str, adjustl_str)
  4244. implicit none
  4245. class(json_core),intent(inout) :: json
  4246. type(json_value),pointer :: p
  4247. character(kind=CK, len=*),intent(in) :: name
  4248. character(kind=CDK,len=*),dimension(:),intent(in) :: val
  4249. logical(LK),intent(in),optional :: trim_str
  4250. logical(LK),intent(in),optional :: adjustl_str
  4251. call json%add(p, name, to_unicode(val), trim_str, adjustl_str)
  4252. end subroutine json_value_add_string_vec_val_ascii
  4253. !*****************************************************************************************
  4254. !*****************************************************************************************
  4255. !>
  4256. ! Count the number of children in the object or array.
  4257. !
  4258. !### History
  4259. ! * JW : 1/4/2014 : Original routine removed.
  4260. ! Now using `n_children` variable.
  4261. ! Renamed from `json_value_count`.
  4262. function json_count(json,p) result(count)
  4263. implicit none
  4264. class(json_core),intent(inout) :: json
  4265. type(json_value),pointer,intent(in) :: p !! this should normally be a `json_object`
  4266. !! or a `json_array`. For any other
  4267. !! variable type this will return 0.
  4268. integer(IK) :: count !! number of children in `p`.
  4269. if (associated(p)) then
  4270. count = p%n_children
  4271. else
  4272. call json%throw_exception('Error in json_count: '//&
  4273. 'pointer is not associated.')
  4274. end if
  4275. end function json_count
  4276. !*****************************************************************************************
  4277. !*****************************************************************************************
  4278. !> author: Jacob Williams
  4279. ! date: 10/16/2015
  4280. !
  4281. ! Returns a pointer to the parent of a [[json_value]].
  4282. ! If there is no parent, then a `null()` pointer is returned.
  4283. subroutine json_get_parent(json,p,parent)
  4284. implicit none
  4285. class(json_core),intent(inout) :: json
  4286. type(json_value),pointer,intent(in) :: p !! JSON object
  4287. type(json_value),pointer,intent(out) :: parent !! pointer to `parent`
  4288. if (associated(p)) then
  4289. parent => p%parent
  4290. else
  4291. nullify(parent)
  4292. call json%throw_exception('Error in json_get_parent: '//&
  4293. 'pointer is not associated.')
  4294. end if
  4295. end subroutine json_get_parent
  4296. !*****************************************************************************************
  4297. !*****************************************************************************************
  4298. !> author: Jacob Williams
  4299. ! date: 10/31/2015
  4300. !
  4301. ! Returns a pointer to the next of a [[json_value]].
  4302. ! If there is no next, then a `null()` pointer is returned.
  4303. subroutine json_get_next(json,p,next)
  4304. implicit none
  4305. class(json_core),intent(inout) :: json
  4306. type(json_value),pointer,intent(in) :: p !! JSON object
  4307. type(json_value),pointer,intent(out) :: next !! pointer to `next`
  4308. if (associated(p)) then
  4309. next => p%next
  4310. else
  4311. nullify(next)
  4312. call json%throw_exception('Error in json_get_next: '//&
  4313. 'pointer is not associated.')
  4314. end if
  4315. end subroutine json_get_next
  4316. !*****************************************************************************************
  4317. !*****************************************************************************************
  4318. !> author: Jacob Williams
  4319. ! date: 10/31/2015
  4320. !
  4321. ! Returns a pointer to the previous of a [[json_value]].
  4322. ! If there is no previous, then a `null()` pointer is returned.
  4323. subroutine json_get_previous(json,p,previous)
  4324. implicit none
  4325. class(json_core),intent(inout) :: json
  4326. type(json_value),pointer,intent(in) :: p !! JSON object
  4327. type(json_value),pointer,intent(out) :: previous !! pointer to `previous`
  4328. if (associated(p)) then
  4329. previous => p%previous
  4330. else
  4331. nullify(previous)
  4332. call json%throw_exception('Error in json_get_previous: '//&
  4333. 'pointer is not associated.')
  4334. end if
  4335. end subroutine json_get_previous
  4336. !*****************************************************************************************
  4337. !*****************************************************************************************
  4338. !> author: Jacob Williams
  4339. ! date: 10/31/2015
  4340. !
  4341. ! Returns a pointer to the tail of a [[json_value]]
  4342. ! (the last child of an array of object).
  4343. ! If there is no tail, then a `null()` pointer is returned.
  4344. subroutine json_get_tail(json,p,tail)
  4345. implicit none
  4346. class(json_core),intent(inout) :: json
  4347. type(json_value),pointer,intent(in) :: p !! JSON object
  4348. type(json_value),pointer,intent(out) :: tail !! pointer to `tail`
  4349. if (associated(p)) then
  4350. tail => p%tail
  4351. else
  4352. nullify(tail)
  4353. call json%throw_exception('Error in json_get_tail: '//&
  4354. 'pointer is not associated.')
  4355. end if
  4356. end subroutine json_get_tail
  4357. !*****************************************************************************************
  4358. !*****************************************************************************************
  4359. !>
  4360. ! Returns a child in the object or array given the index.
  4361. subroutine json_value_get_child_by_index(json, p, idx, child, found)
  4362. implicit none
  4363. class(json_core),intent(inout) :: json
  4364. type(json_value),pointer,intent(in) :: p !! object or array JSON data
  4365. integer(IK),intent(in) :: idx !! index of the child
  4366. !! (this is a 1-based Fortran
  4367. !! style array index).
  4368. type(json_value),pointer :: child !! pointer to the child
  4369. logical(LK),intent(out),optional :: found !! true if the value was found
  4370. !! (if not present, an exception
  4371. !! will be thrown if it was not
  4372. !! found. If present and not
  4373. !! found, no exception will be
  4374. !! thrown).
  4375. integer(IK) :: i !! counter
  4376. nullify(child)
  4377. if (.not. json%exception_thrown) then
  4378. if (associated(p%children)) then
  4379. ! If getting first or last child, we can do this quickly.
  4380. ! Otherwise, traverse the list.
  4381. if (idx==1) then
  4382. child => p%children ! first one
  4383. elseif (idx==p%n_children) then
  4384. if (associated(p%tail)) then
  4385. child => p%tail ! last one
  4386. else
  4387. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4388. ' child%tail is not associated.',found)
  4389. end if
  4390. elseif (idx<1 .or. idx>p%n_children) then
  4391. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4392. ' idx is out of range.',found)
  4393. else
  4394. ! if idx is closer to the end, we traverse the list backward from tail,
  4395. ! otherwise we traverse it forward from children:
  4396. if (p%n_children-idx < idx) then ! traverse backward
  4397. child => p%tail
  4398. do i = 1, p%n_children - idx
  4399. if (associated(child%previous)) then
  4400. child => child%previous
  4401. else
  4402. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4403. ' child%previous is not associated.',found)
  4404. nullify(child)
  4405. exit
  4406. end if
  4407. end do
  4408. else ! traverse forward
  4409. child => p%children
  4410. do i = 1, idx - 1
  4411. if (associated(child%next)) then
  4412. child => child%next
  4413. else
  4414. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4415. ' child%next is not associated.',found)
  4416. nullify(child)
  4417. exit
  4418. end if
  4419. end do
  4420. end if
  4421. end if
  4422. else
  4423. call json%throw_exception('Error in json_value_get_child_by_index:'//&
  4424. ' p%children is not associated.',found)
  4425. end if
  4426. ! found output:
  4427. if (json%exception_thrown) then
  4428. if (present(found)) then
  4429. call json%clear_exceptions()
  4430. found = .false.
  4431. end if
  4432. else
  4433. if (present(found)) found = .true.
  4434. end if
  4435. else
  4436. if (present(found)) found = .false.
  4437. end if
  4438. end subroutine json_value_get_child_by_index
  4439. !*****************************************************************************************
  4440. !*****************************************************************************************
  4441. !>
  4442. ! Returns pointer to the first child of the object
  4443. ! (or `null()` if it is not associated).
  4444. subroutine json_value_get_child(json, p, child)
  4445. implicit none
  4446. class(json_core),intent(inout) :: json
  4447. type(json_value),pointer,intent(in) :: p !! object or array JSON data
  4448. type(json_value),pointer :: child !! pointer to the child
  4449. if (associated(p)) then
  4450. child => p%children
  4451. else
  4452. nullify(child)
  4453. call json%throw_exception('Error in json_value_get_child: '//&
  4454. 'pointer is not associated.')
  4455. end if
  4456. end subroutine json_value_get_child
  4457. !*****************************************************************************************
  4458. !*****************************************************************************************
  4459. !>
  4460. ! Returns a child in the object or array given the name string.
  4461. !
  4462. ! The name search can be case-sensitive or not, and can have significant trailing
  4463. ! whitespace or not, depending on the settings in the [[json_core(type)]] class.
  4464. !
  4465. !@note The `name` input is not a path, and is not parsed like it is in [[json_get_by_path]].
  4466. subroutine json_value_get_child_by_name(json, p, name, child, found)
  4467. implicit none
  4468. class(json_core),intent(inout) :: json
  4469. type(json_value),pointer,intent(in) :: p
  4470. character(kind=CK,len=*),intent(in) :: name !! the name of a child of `p`
  4471. type(json_value),pointer :: child !! pointer to the child
  4472. logical(LK),intent(out),optional :: found !! true if the value was found
  4473. !! (if not present, an exception
  4474. !! will be thrown if it was not
  4475. !! found. If present and not
  4476. !! found, no exception will be
  4477. !! thrown).
  4478. integer(IK) :: i,n_children
  4479. logical :: error
  4480. nullify(child)
  4481. if (.not. json%exception_thrown) then
  4482. if (associated(p)) then
  4483. error = .true. ! will be false if it is found
  4484. if (p%var_type==json_object) then
  4485. n_children = json%count(p)
  4486. child => p%children !start with first one
  4487. do i=1, n_children
  4488. if (.not. associated(child)) then
  4489. call json%throw_exception(&
  4490. 'Error in json_value_get_child_by_name: '//&
  4491. 'Malformed JSON linked list',found)
  4492. exit
  4493. end if
  4494. if (allocated(child%name)) then
  4495. !name string matching routine:
  4496. if (json%name_equal(child,name)) then
  4497. error = .false.
  4498. exit
  4499. end if
  4500. end if
  4501. child => child%next
  4502. end do
  4503. end if
  4504. if (error) then
  4505. !did not find anything:
  4506. call json%throw_exception(&
  4507. 'Error in json_value_get_child_by_name: '//&
  4508. 'child variable '//trim(name)//' was not found.',found)
  4509. nullify(child)
  4510. end if
  4511. else
  4512. call json%throw_exception(&
  4513. 'Error in json_value_get_child_by_name: '//&
  4514. 'pointer is not associated.',found)
  4515. end if
  4516. ! found output:
  4517. if (json%exception_thrown) then
  4518. if (present(found)) then
  4519. call json%clear_exceptions()
  4520. found = .false.
  4521. end if
  4522. else
  4523. if (present(found)) found = .true.
  4524. end if
  4525. else
  4526. if (present(found)) found = .false.
  4527. end if
  4528. end subroutine json_value_get_child_by_name
  4529. !*****************************************************************************************
  4530. !*****************************************************************************************
  4531. !> author: Jacob Williams
  4532. ! date: 8/25/2017
  4533. !
  4534. ! Checks a JSON object for duplicate child names.
  4535. !
  4536. ! It uses the specified settings for name matching (see [[name_strings_equal]]).
  4537. !
  4538. !@note This will only check for one duplicate,
  4539. ! it will return the first one that it finds.
  4540. subroutine json_check_children_for_duplicate_keys(json,p,has_duplicate,name,path)
  4541. implicit none
  4542. class(json_core),intent(inout) :: json
  4543. type(json_value),pointer,intent(in) :: p !! the object to search. If `p` is
  4544. !! not a `json_object`, then `has_duplicate`
  4545. !! will be false.
  4546. logical(LK),intent(out) :: has_duplicate !! true if there is at least
  4547. !! two children have duplicate
  4548. !! `name` values.
  4549. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! the duplicate name
  4550. !! (unallocated if no
  4551. !! duplicate was found)
  4552. character(kind=CK,len=:),allocatable,intent(out),optional :: path !! the full path to the
  4553. !! duplicate name
  4554. !! (unallocated if no
  4555. !! duplicate was found)
  4556. integer(IK) :: i !! counter
  4557. integer(IK) :: j !! counter
  4558. type(json_value),pointer :: child !! pointer to a child of `p`
  4559. integer(IK) :: n_children !! number of children of `p`
  4560. logical(LK) :: found !! flag for `get_child`
  4561. type :: alloc_str
  4562. !! so we can have an array of allocatable strings
  4563. character(kind=CK,len=:),allocatable :: str !! name string
  4564. end type alloc_str
  4565. type(alloc_str),dimension(:),allocatable :: names !! array of all the
  4566. !! child name strings
  4567. ! initialize:
  4568. has_duplicate =.false.
  4569. if (.not. json%exception_thrown) then
  4570. if (associated(p)) then
  4571. if (p%var_type==json_object) then
  4572. ! number of items to check:
  4573. n_children = json%count(p)
  4574. allocate(names(n_children))
  4575. ! first get a list of all the name keys:
  4576. do i=1, n_children
  4577. call json%get_child(p,i,child,found) ! get by index
  4578. if (.not. found) then
  4579. call json%throw_exception(&
  4580. 'Error in json_check_children_for_duplicate_keys: '//&
  4581. 'Malformed JSON linked list')
  4582. exit
  4583. end if
  4584. if (allocated(child%name)) then
  4585. names(i)%str = child%name
  4586. else
  4587. call json%throw_exception(&
  4588. 'Error in json_check_children_for_duplicate_keys: '//&
  4589. 'Object child name is not allocated')
  4590. exit
  4591. end if
  4592. end do
  4593. if (.not. json%exception_thrown) then
  4594. ! now check the list for duplicates:
  4595. main: do i=1,n_children
  4596. do j=1,i-1
  4597. if (json%name_strings_equal(names(i)%str,names(j)%str)) then
  4598. has_duplicate = .true.
  4599. if (present(name)) then
  4600. name = names(i)%str
  4601. end if
  4602. if (present(path)) then
  4603. call json%get_child(p,names(i)%str,child,found) ! get by name
  4604. if (found) then
  4605. call json%get_path(child,path,found)
  4606. if (.not. found) then
  4607. ! should never happen since we know it is there
  4608. call json%throw_exception(&
  4609. 'Error in json_check_children_for_duplicate_keys: '//&
  4610. 'Could not get path')
  4611. end if
  4612. else
  4613. ! should never happen since we know it is there
  4614. call json%throw_exception(&
  4615. 'Error in json_check_children_for_duplicate_keys: '//&
  4616. 'Could not get child: '//trim(names(i)%str))
  4617. end if
  4618. end if
  4619. exit main
  4620. end if
  4621. end do
  4622. end do main
  4623. end if
  4624. ! cleanup
  4625. do i=1,n_children
  4626. if (allocated(names(i)%str)) deallocate(names(i)%str)
  4627. end do
  4628. if (allocated(names)) deallocate(names)
  4629. end if
  4630. end if
  4631. end if
  4632. end subroutine json_check_children_for_duplicate_keys
  4633. !*****************************************************************************************
  4634. !*****************************************************************************************
  4635. !> author: Jacob Williams
  4636. ! date: 8/25/2017
  4637. !
  4638. ! Checks a JSON structure for duplicate child names.
  4639. ! This one recursively traverses the entire structure
  4640. ! (calling [[json_check_children_for_duplicate_keys]]
  4641. ! recursively for each element).
  4642. !
  4643. !@note This will only check for one duplicate,
  4644. ! it will return the first one that it finds.
  4645. subroutine json_check_all_for_duplicate_keys(json,p,has_duplicate,name,path)
  4646. implicit none
  4647. class(json_core),intent(inout) :: json
  4648. type(json_value),pointer,intent(in) :: p !! the object to search. If `p` is
  4649. !! not a `json_object`, then `has_duplicate`
  4650. !! will be false.
  4651. logical(LK),intent(out) :: has_duplicate !! true if there is at least
  4652. !! one duplicate `name` key anywhere
  4653. !! in the structure.
  4654. character(kind=CK,len=:),allocatable,intent(out),optional :: name !! the duplicate name
  4655. !! (unallocated if no
  4656. !! duplicates were found)
  4657. character(kind=CK,len=:),allocatable,intent(out),optional :: path !! the full path to the
  4658. !! duplicate name
  4659. !! (unallocated if no
  4660. !! duplicate was found)
  4661. has_duplicate = .false.
  4662. if (.not. json%exception_thrown) then
  4663. call json%traverse(p,duplicate_key_func)
  4664. end if
  4665. contains
  4666. subroutine duplicate_key_func(json,p,finished)
  4667. !! Callback function to check each element
  4668. !! for duplicate child names.
  4669. implicit none
  4670. class(json_core),intent(inout) :: json
  4671. type(json_value),pointer,intent(in) :: p
  4672. logical(LK),intent(out) :: finished
  4673. #if defined __GFORTRAN__
  4674. ! this is a workaround for a gfortran bug (6 and 7),
  4675. character(kind=CK,len=:),allocatable :: tmp_name !! temp variable for `name` string
  4676. character(kind=CK,len=:),allocatable :: tmp_path !! temp variable for `path` string
  4677. if (present(name) .and. present(path)) then
  4678. call json%check_children_for_duplicate_keys(p,has_duplicate,name=tmp_name,path=tmp_path)
  4679. else if (present(name) .and. .not. present(path)) then
  4680. call json%check_children_for_duplicate_keys(p,has_duplicate,name=tmp_name)
  4681. else if (.not. present(name) .and. present(path)) then
  4682. call json%check_children_for_duplicate_keys(p,has_duplicate,path=tmp_path)
  4683. else
  4684. call json%check_children_for_duplicate_keys(p,has_duplicate)
  4685. end if
  4686. if (has_duplicate) then
  4687. if (present(name)) name = tmp_name
  4688. if (present(path)) path = tmp_path
  4689. end if
  4690. #else
  4691. call json%check_children_for_duplicate_keys(p,has_duplicate,name,path)
  4692. #endif
  4693. finished = has_duplicate .or. json%exception_thrown
  4694. end subroutine duplicate_key_func
  4695. end subroutine json_check_all_for_duplicate_keys
  4696. !*****************************************************************************************
  4697. !*****************************************************************************************
  4698. !>
  4699. ! Alternate version of [[json_value_get_child_by_name]] where `name` is kind=CDK.
  4700. subroutine wrap_json_value_get_child_by_name(json, p, name, child, found)
  4701. implicit none
  4702. class(json_core),intent(inout) :: json
  4703. type(json_value),pointer,intent(in) :: p
  4704. character(kind=CDK,len=*),intent(in) :: name
  4705. type(json_value),pointer :: child
  4706. logical(LK),intent(out),optional :: found
  4707. call json%get(p,to_unicode(name),child,found)
  4708. end subroutine wrap_json_value_get_child_by_name
  4709. !*****************************************************************************************
  4710. !*****************************************************************************************
  4711. !> author: Jacob Williams
  4712. ! date: 2/12/2014
  4713. !
  4714. ! Print the [[json_value]] structure to an allocatable string.
  4715. subroutine json_value_to_string(json,p,str)
  4716. implicit none
  4717. class(json_core),intent(inout) :: json
  4718. type(json_value),pointer,intent(in) :: p
  4719. character(kind=CK,len=:),intent(out),allocatable :: str !! prints structure to this string
  4720. integer(IK) :: iloc !! used to keep track of size of str
  4721. !! since it is being allocated in chunks.
  4722. str = repeat(space, print_str_chunk_size)
  4723. iloc = 0_IK
  4724. call json%json_value_print(p, iunit=unit2str, str=str, iloc=iloc, indent=1_IK, colon=.true.)
  4725. ! trim the string if necessary:
  4726. if (len(str)>iloc) str = str(1:iloc)
  4727. end subroutine json_value_to_string
  4728. !*****************************************************************************************
  4729. !*****************************************************************************************
  4730. !>
  4731. ! Print the [[json_value]] structure to the console (`output_unit`).
  4732. !
  4733. !### Note
  4734. ! * Just a wrapper for [[json_print_to_unit]].
  4735. subroutine json_print_to_console(json,p)
  4736. implicit none
  4737. class(json_core),intent(inout) :: json
  4738. type(json_value),pointer,intent(in) :: p
  4739. call json%print(p,int(output_unit,IK))
  4740. end subroutine json_print_to_console
  4741. !*****************************************************************************************
  4742. !*****************************************************************************************
  4743. !> author: Jacob Williams
  4744. ! date: 6/20/2014
  4745. !
  4746. ! Print the [[json_value]] structure to a file.
  4747. subroutine json_print_to_unit(json,p,iunit)
  4748. implicit none
  4749. class(json_core),intent(inout) :: json
  4750. type(json_value),pointer,intent(in) :: p
  4751. integer(IK),intent(in) :: iunit !! the file unit (the file must
  4752. !! already have been opened, can't be -1).
  4753. character(kind=CK,len=:),allocatable :: dummy !! dummy for `str` argument
  4754. !! to [[json_value_print]]
  4755. integer(IK) :: idummy !! dummy for `iloc` argument
  4756. !! to [[json_value_print]]
  4757. if (iunit/=unit2str) then
  4758. idummy = 0_IK
  4759. call json%json_value_print(p,iunit,str=dummy,iloc=idummy,indent=1_IK,colon=.true.)
  4760. else
  4761. call json%throw_exception('Error in json_print_to_unit: iunit must not be -1.')
  4762. end if
  4763. end subroutine json_print_to_unit
  4764. !*****************************************************************************************
  4765. !*****************************************************************************************
  4766. !> author: Jacob Williams
  4767. ! date: 12/23/2014
  4768. !
  4769. ! Print the [[json_value]] structure to a file.
  4770. subroutine json_print_to_filename(json,p,filename)
  4771. implicit none
  4772. class(json_core),intent(inout) :: json
  4773. type(json_value),pointer,intent(in) :: p
  4774. character(kind=CDK,len=*),intent(in) :: filename !! the filename to print to
  4775. !! (should not already be open)
  4776. integer(IK) :: iunit !! file unit for `open` statement
  4777. integer(IK) :: istat !! `iostat` code for `open` statement
  4778. open(newunit=iunit,file=filename,status='REPLACE',iostat=istat FILE_ENCODING )
  4779. if (istat==0) then
  4780. call json%print(p,iunit)
  4781. close(iunit,iostat=istat)
  4782. else
  4783. call json%throw_exception('Error in json_print_to_filename: could not open file: '//&
  4784. trim(filename))
  4785. end if
  4786. end subroutine json_print_to_filename
  4787. !*****************************************************************************************
  4788. !*****************************************************************************************
  4789. !>
  4790. ! Print the JSON structure to a string or a file.
  4791. !
  4792. !### Notes
  4793. ! * This is an internal routine called by the various wrapper routines.
  4794. ! * The reason the `str` argument is non-optional is because of a
  4795. ! bug in v4.9 of the gfortran compiler.
  4796. recursive subroutine json_value_print(json,p,iunit,str,indent,&
  4797. need_comma,colon,is_array_element,&
  4798. is_compressed_vector,iloc)
  4799. implicit none
  4800. class(json_core),intent(inout) :: json
  4801. type(json_value),pointer,intent(in) :: p
  4802. integer(IK),intent(in) :: iunit !! file unit to write to (the
  4803. !! file is assumed to be open)
  4804. integer(IK),intent(in),optional :: indent !! indention level
  4805. logical(LK),intent(in),optional :: is_array_element !! if this is an array element
  4806. logical(LK),intent(in),optional :: need_comma !! if it needs a comma after it
  4807. logical(LK),intent(in),optional :: colon !! if the colon was just written
  4808. character(kind=CK,len=:),intent(inout),allocatable :: str
  4809. !! if `iunit==unit2str` (-1) then
  4810. !! the structure is printed to this
  4811. !! string rather than a file. This mode
  4812. !! is used by [[json_value_to_string]].
  4813. integer(IK),intent(inout) :: iloc !! current index in `str`. should be set to 0 initially.
  4814. !! [only used when `str` is used.]
  4815. logical(LK),intent(in),optional :: is_compressed_vector !! if True, this is an element
  4816. !! from an array being printed
  4817. !! on one line [default is False]
  4818. character(kind=CK,len=max_numeric_str_len) :: tmp !! for value to string conversions
  4819. character(kind=CK,len=:),allocatable :: s_indent !! the string of spaces for
  4820. !! indenting (see `tab` and `spaces`)
  4821. character(kind=CK,len=:),allocatable :: s !! the string appended to `str`
  4822. type(json_value),pointer :: element !! for getting children
  4823. integer(IK) :: tab !! number of `tabs` for indenting
  4824. integer(IK) :: spaces !! number of spaces for indenting
  4825. integer(IK) :: i !! counter
  4826. integer(IK) :: count !! number of children
  4827. logical(LK) :: print_comma !! if the comma will be printed after the value
  4828. logical(LK) :: write_file !! if we are writing to a file
  4829. logical(LK) :: write_string !! if we are writing to a string
  4830. logical(LK) :: is_array !! if this is an element in an array
  4831. logical(LK) :: is_vector !! if all elements of a vector
  4832. !! are scalars of the same type
  4833. character(kind=CK,len=:),allocatable :: str_escaped !! escaped version of
  4834. !! `name` or `str_value`
  4835. if (.not. json%exception_thrown) then
  4836. if (.not. associated(p)) then
  4837. ! note: a null() pointer will trigger this error.
  4838. ! However, if the pointer is undefined, then this will
  4839. ! crash (if this wasn't here it would crash below when
  4840. ! we try to access the contents)
  4841. call json%throw_exception('Error in json_value_print: '//&
  4842. 'the pointer is not associated')
  4843. return
  4844. end if
  4845. if (present(is_compressed_vector)) then
  4846. is_vector = is_compressed_vector
  4847. else
  4848. is_vector = .false.
  4849. end if
  4850. !whether to write a string or a file (one or the other):
  4851. write_string = (iunit==unit2str)
  4852. write_file = .not. write_string
  4853. !if the comma will be printed after the value
  4854. ! [comma not printed for the last elements]
  4855. if (present(need_comma)) then
  4856. print_comma = need_comma
  4857. else
  4858. print_comma = .false.
  4859. end if
  4860. !number of "tabs" to indent:
  4861. if (present(indent) .and. .not. json%no_whitespace) then
  4862. tab = indent
  4863. else
  4864. tab = 0
  4865. end if
  4866. !convert to number of spaces:
  4867. spaces = tab*json%spaces_per_tab
  4868. !if this is an element in an array:
  4869. if (present(is_array_element)) then
  4870. is_array = is_array_element
  4871. else
  4872. is_array = .false.
  4873. end if
  4874. !if the colon was the last thing written
  4875. if (present(colon)) then
  4876. s_indent = CK_''
  4877. else
  4878. s_indent = repeat(space, spaces)
  4879. end if
  4880. select case (p%var_type)
  4881. case (json_object)
  4882. count = json%count(p)
  4883. if (count==0) then !special case for empty object
  4884. s = s_indent//start_object//end_object
  4885. call write_it( comma=print_comma )
  4886. else
  4887. s = s_indent//start_object
  4888. call write_it()
  4889. !if an object is in an array, there is an extra tab:
  4890. if (is_array) then
  4891. if ( .not. json%no_whitespace) tab = tab+1
  4892. spaces = tab*json%spaces_per_tab
  4893. end if
  4894. nullify(element)
  4895. element => p%children
  4896. do i = 1, count
  4897. if (.not. associated(element)) then
  4898. call json%throw_exception('Error in json_value_print: '//&
  4899. 'Malformed JSON linked list')
  4900. return
  4901. end if
  4902. ! print the name
  4903. if (allocated(element%name)) then
  4904. call escape_string(element%name,str_escaped,json%escape_solidus)
  4905. if (json%no_whitespace) then
  4906. !compact printing - no extra space
  4907. s = repeat(space, spaces)//quotation_mark//&
  4908. str_escaped//quotation_mark//colon_char
  4909. call write_it(advance=.false.)
  4910. else
  4911. s = repeat(space, spaces)//quotation_mark//&
  4912. str_escaped//quotation_mark//colon_char//space
  4913. call write_it(advance=.false.)
  4914. end if
  4915. else
  4916. call json%throw_exception('Error in json_value_print:'//&
  4917. ' element%name not allocated')
  4918. nullify(element)
  4919. return
  4920. end if
  4921. ! recursive print of the element
  4922. call json%json_value_print(element, iunit=iunit, indent=tab + 1_IK, &
  4923. need_comma=i<count, colon=.true., str=str, iloc=iloc)
  4924. if (json%exception_thrown) return
  4925. ! get the next child the list:
  4926. element => element%next
  4927. end do
  4928. ! [one fewer tab if it isn't an array element]
  4929. if (.not. is_array) then
  4930. s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_object
  4931. else
  4932. s = s_indent//end_object
  4933. end if
  4934. call write_it( comma=print_comma )
  4935. nullify(element)
  4936. end if
  4937. case (json_array)
  4938. count = json%count(p)
  4939. if (count==0) then ! special case for empty array
  4940. s = s_indent//start_array//end_array
  4941. call write_it( comma=print_comma )
  4942. else
  4943. ! if every child is the same type & a scalar:
  4944. is_vector = json%is_vector(p)
  4945. if (json%failed()) return
  4946. s = s_indent//start_array
  4947. call write_it( advance=(.not. is_vector) )
  4948. !if an array is in an array, there is an extra tab:
  4949. if (is_array) then
  4950. if ( .not. json%no_whitespace) tab = tab+1
  4951. spaces = tab*json%spaces_per_tab
  4952. end if
  4953. nullify(element)
  4954. element => p%children
  4955. do i = 1, count
  4956. if (.not. associated(element)) then
  4957. call json%throw_exception('Error in json_value_print: '//&
  4958. 'Malformed JSON linked list')
  4959. return
  4960. end if
  4961. ! recursive print of the element
  4962. if (is_vector) then
  4963. call json%json_value_print(element, iunit=iunit, indent=0_IK,&
  4964. need_comma=i<count, is_array_element=.false., &
  4965. str=str, iloc=iloc,&
  4966. is_compressed_vector = .true.)
  4967. else
  4968. call json%json_value_print(element, iunit=iunit, indent=tab,&
  4969. need_comma=i<count, is_array_element=.true., &
  4970. str=str, iloc=iloc)
  4971. end if
  4972. if (json%exception_thrown) return
  4973. ! get the next child the list:
  4974. element => element%next
  4975. end do
  4976. !indent the closing array character:
  4977. if (is_vector) then
  4978. s = end_array
  4979. call write_it( comma=print_comma )
  4980. else
  4981. s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_array
  4982. call write_it( comma=print_comma )
  4983. end if
  4984. nullify(element)
  4985. end if
  4986. case (json_null)
  4987. s = s_indent//null_str
  4988. call write_it( comma=print_comma, &
  4989. advance=(.not. is_vector),&
  4990. space_after_comma=is_vector )
  4991. case (json_string)
  4992. if (allocated(p%str_value)) then
  4993. ! have to escape the string for printing:
  4994. call escape_string(p%str_value,str_escaped,json%escape_solidus)
  4995. s = s_indent//quotation_mark//str_escaped//quotation_mark
  4996. call write_it( comma=print_comma, &
  4997. advance=(.not. is_vector),&
  4998. space_after_comma=is_vector )
  4999. else
  5000. call json%throw_exception('Error in json_value_print:'//&
  5001. ' p%value_string not allocated')
  5002. return
  5003. end if
  5004. case (json_logical)
  5005. if (p%log_value) then
  5006. s = s_indent//true_str
  5007. call write_it( comma=print_comma, &
  5008. advance=(.not. is_vector),&
  5009. space_after_comma=is_vector )
  5010. else
  5011. s = s_indent//false_str
  5012. call write_it( comma=print_comma, &
  5013. advance=(.not. is_vector),&
  5014. space_after_comma=is_vector )
  5015. end if
  5016. case (json_integer)
  5017. call integer_to_string(p%int_value,int_fmt,tmp)
  5018. s = s_indent//trim(tmp)
  5019. call write_it( comma=print_comma, &
  5020. advance=(.not. is_vector),&
  5021. space_after_comma=is_vector )
  5022. case (json_real)
  5023. if (allocated(json%real_fmt)) then
  5024. call real_to_string(p%dbl_value,json%real_fmt,json%compact_real,json%non_normals_to_null,tmp)
  5025. else
  5026. !use the default format (user has not called initialize() or specified one):
  5027. call real_to_string(p%dbl_value,default_real_fmt,json%compact_real,json%non_normals_to_null,tmp)
  5028. end if
  5029. s = s_indent//trim(tmp)
  5030. call write_it( comma=print_comma, &
  5031. advance=(.not. is_vector),&
  5032. space_after_comma=is_vector )
  5033. case default
  5034. call integer_to_string(p%var_type,int_fmt,tmp)
  5035. call json%throw_exception('Error in json_value_print: '//&
  5036. 'unknown data type: '//trim(tmp))
  5037. end select
  5038. end if
  5039. contains
  5040. subroutine write_it(advance,comma,space_after_comma)
  5041. !! write the string `s` to the file (or the output string)
  5042. implicit none
  5043. logical(LK),intent(in),optional :: advance !! to add line break or not
  5044. logical(LK),intent(in),optional :: comma !! print comma after the string
  5045. logical(LK),intent(in),optional :: space_after_comma !! print a space after the comma
  5046. logical(LK) :: add_comma !! if a delimiter is to be added after string
  5047. logical(LK) :: add_line_break !! if a line break is to be added after string
  5048. logical(LK) :: add_space !! if a space is to be added after the comma
  5049. integer(IK) :: n !! length of actual string `s` appended to `str`
  5050. integer(IK) :: room_left !! number of characters left in `str`
  5051. integer(IK) :: n_chunks_to_add !! number of chunks to add to `str` for appending `s`
  5052. if (present(comma)) then
  5053. add_comma = comma
  5054. else
  5055. add_comma = .false. !default is not to add comma
  5056. end if
  5057. if (json%no_whitespace) then
  5058. add_space = .false.
  5059. else
  5060. if (present(space_after_comma)) then
  5061. add_space = space_after_comma
  5062. else
  5063. add_space = .false. !default is not to add space
  5064. end if
  5065. end if
  5066. if (present(advance)) then
  5067. if (json%no_whitespace) then
  5068. ! overrides input value:
  5069. add_line_break = .false.
  5070. else
  5071. add_line_break = advance
  5072. end if
  5073. else
  5074. add_line_break = .not. json%no_whitespace ! default is to advance if
  5075. ! we are printing whitespace
  5076. end if
  5077. ! string to print:
  5078. if (add_comma) then
  5079. if (add_space) then
  5080. s = s // delimiter // space
  5081. else
  5082. s = s // delimiter
  5083. end if
  5084. end if
  5085. if (write_file) then
  5086. if (add_line_break) then
  5087. write(iunit,fmt='(A)') s
  5088. else
  5089. write(iunit,fmt='(A)',advance='NO') s
  5090. end if
  5091. else !write string
  5092. if (add_line_break) s = s // newline
  5093. n = len(s)
  5094. room_left = len(str)-iloc
  5095. if (room_left < n) then
  5096. ! need to add another chunk to fit this string:
  5097. n_chunks_to_add = max(1_IK, ceiling( real(len(s)-room_left,RK) / real(chunk_size,RK), IK ) )
  5098. str = str // repeat(space, print_str_chunk_size*n_chunks_to_add)
  5099. end if
  5100. ! append s to str:
  5101. str(iloc+1:iloc+n) = s
  5102. iloc = iloc + n
  5103. end if
  5104. end subroutine write_it
  5105. end subroutine json_value_print
  5106. !*****************************************************************************************
  5107. !*****************************************************************************************
  5108. !>
  5109. ! Returns true if all the children are the same type (and a scalar).
  5110. ! Note that integers and reals are considered the same type for this purpose.
  5111. ! This routine is used for the `compress_vectors` option.
  5112. function json_is_vector(json, p) result(is_vector)
  5113. implicit none
  5114. class(json_core),intent(inout) :: json
  5115. type(json_value),pointer :: p
  5116. logical(LK) :: is_vector !! if all elements of a vector
  5117. !! are scalars of the same type
  5118. integer(IK) :: var_type_prev !! for getting the variable type of children
  5119. integer(IK) :: var_type !! for getting the variable type of children
  5120. type(json_value),pointer :: element !! for getting children
  5121. integer(IK) :: i !! counter
  5122. integer(IK) :: count !! number of children
  5123. integer(IK),parameter :: json_invalid = -1_IK !! to initialize the flag. an invalid value
  5124. integer(IK),parameter :: json_numeric = -2_IK !! indicates `json_integer` or `json_real`
  5125. if (json%compress_vectors) then
  5126. ! check to see if every child is the same type,
  5127. ! and a scalar:
  5128. is_vector = .true.
  5129. var_type_prev = json_invalid
  5130. count = json%count(p)
  5131. element => p%children
  5132. do i = 1_IK, count
  5133. if (.not. associated(element)) then
  5134. call json%throw_exception('Error in json_is_vector: '//&
  5135. 'Malformed JSON linked list')
  5136. return
  5137. end if
  5138. ! check variable type of all the children.
  5139. ! They must all be the same, and a scalar.
  5140. call json%info(element,var_type=var_type)
  5141. ! special check for numeric values:
  5142. if (var_type==json_integer .or. var_type==json_real) var_type = json_numeric
  5143. if (var_type==json_object .or. &
  5144. var_type==json_array .or. &
  5145. (i>1_IK .and. var_type/=var_type_prev)) then
  5146. is_vector = .false.
  5147. exit
  5148. end if
  5149. var_type_prev = var_type
  5150. ! get the next child the list:
  5151. element => element%next
  5152. end do
  5153. else
  5154. is_vector = .false.
  5155. end if
  5156. end function json_is_vector
  5157. !*****************************************************************************************
  5158. !*****************************************************************************************
  5159. !>
  5160. ! Returns true if the `path` is present in the `p` JSON structure.
  5161. !
  5162. !@note Just a wrapper for [[json_get_by_path]], so it uses the
  5163. ! specified `path_mode` and other settings.
  5164. function json_valid_path(json, p, path) result(found)
  5165. implicit none
  5166. class(json_core),intent(inout) :: json
  5167. type(json_value),pointer,intent(in) :: p !! a JSON linked list
  5168. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5169. logical(LK) :: found !! true if it was found
  5170. type(json_value),pointer :: tmp !! pointer to the variable specified by `path`
  5171. call json%get(p, path, tmp, found)
  5172. end function json_valid_path
  5173. !*****************************************************************************************
  5174. !*****************************************************************************************
  5175. !>
  5176. ! Alternate version of [[json_valid_path]] where "path" is kind=CDK.
  5177. function wrap_json_valid_path(json, p, path) result(found)
  5178. implicit none
  5179. class(json_core),intent(inout) :: json
  5180. type(json_value),pointer,intent(in) :: p !! a JSON linked list
  5181. character(kind=CDK,len=*),intent(in) :: path !! path to the variable
  5182. logical(LK) :: found !! true if it was found
  5183. found = json%valid_path(p, to_unicode(path))
  5184. end function wrap_json_valid_path
  5185. !*****************************************************************************************
  5186. !*****************************************************************************************
  5187. !>
  5188. ! Returns the [[json_value]] pointer given the path string.
  5189. !
  5190. ! It uses one of three methods:
  5191. !
  5192. ! * The original JSON-Fortran defaults
  5193. ! * [RFC 6901](https://tools.ietf.org/html/rfc6901)
  5194. ! * [JSONPath](http://goessner.net/articles/JsonPath/) "bracket-notation"
  5195. subroutine json_get_by_path(json, me, path, p, found)
  5196. implicit none
  5197. class(json_core),intent(inout) :: json
  5198. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5199. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5200. type(json_value),pointer,intent(out) :: p !! pointer to the variable
  5201. !! specified by `path`
  5202. logical(LK),intent(out),optional :: found !! true if it was found
  5203. character(kind=CK,len=max_integer_str_len),allocatable :: path_mode_str !! string version
  5204. !! of `json%path_mode`
  5205. nullify(p)
  5206. if (.not. json%exception_thrown) then
  5207. select case (json%path_mode)
  5208. case(1_IK)
  5209. call json%json_get_by_path_default(me, path, p, found)
  5210. case(2_IK)
  5211. call json%json_get_by_path_rfc6901(me, path, p, found)
  5212. case(3_IK)
  5213. call json%json_get_by_path_jsonpath_bracket(me, path, p, found)
  5214. case default
  5215. call integer_to_string(json%path_mode,int_fmt,path_mode_str)
  5216. call json%throw_exception('Error in json_get_by_path: Unsupported path_mode: '//&
  5217. trim(path_mode_str))
  5218. if (present(found)) found = .false.
  5219. end select
  5220. if (present(found)) then
  5221. if (.not. found) call json%clear_exceptions()
  5222. end if
  5223. else
  5224. if (present(found)) found = .false.
  5225. end if
  5226. end subroutine json_get_by_path
  5227. !*****************************************************************************************
  5228. !*****************************************************************************************
  5229. !>
  5230. ! Returns the [[json_value]] pointer given the path string,
  5231. ! If necessary, by creating the variables as needed.
  5232. !
  5233. ! By default, the leaf node and any empty array elements
  5234. ! are created as `json_null` values.
  5235. !
  5236. ! It only works for `path_mode=1` or `path_mode=3`.
  5237. ! An error will be thrown for `path_mode=2` (RFC 6901).
  5238. !
  5239. !### See also
  5240. ! * [[json_get_by_path]]
  5241. subroutine json_create_by_path(json,me,path,p,found,was_created)
  5242. implicit none
  5243. class(json_core),intent(inout) :: json
  5244. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5245. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5246. type(json_value),pointer,intent(out),optional :: p !! pointer to the variable
  5247. !! specify by `path`
  5248. logical(LK),intent(out),optional :: found !! true if there were no errors
  5249. !! (variable found or created)
  5250. logical(LK),intent(out),optional :: was_created !! true if it was actually created
  5251. !! (as opposed to already being there)
  5252. type(json_value),pointer :: tmp
  5253. character(kind=CK,len=max_integer_str_len) :: path_mode_str !! string version
  5254. !! of `json%path_mode`
  5255. if (present(p)) nullify(p)
  5256. if (.not. json%exception_thrown) then
  5257. select case (json%path_mode)
  5258. case(1_IK)
  5259. call json%json_get_by_path_default(me,path,tmp,found,&
  5260. create_it=.true.,&
  5261. was_created=was_created)
  5262. if (present(p)) p => tmp
  5263. case(3_IK)
  5264. call json%json_get_by_path_jsonpath_bracket(me,path,tmp,found,&
  5265. create_it=.true.,&
  5266. was_created=was_created)
  5267. if (present(p)) p => tmp
  5268. case default
  5269. if (json%path_mode==2_IK) then
  5270. ! the problem here is there isn't really a way to disambiguate
  5271. ! the array elements, so '/a/0' could be 'a(1)' or 'a.0'.
  5272. call json%throw_exception('Error in json_create_by_path: '//&
  5273. 'Create by path not supported in RFC 6901 path mode.')
  5274. else
  5275. call integer_to_string(json%path_mode,int_fmt,path_mode_str)
  5276. call json%throw_exception('Error in json_create_by_path: Unsupported path_mode: '//&
  5277. trim(path_mode_str))
  5278. end if
  5279. if (present(found)) then
  5280. call json%clear_exceptions()
  5281. found = .false.
  5282. end if
  5283. if (present(was_created)) was_created = .false.
  5284. end select
  5285. else
  5286. if (present(was_created)) was_created = .false.
  5287. if (present(found)) found = .false.
  5288. end if
  5289. end subroutine json_create_by_path
  5290. !*****************************************************************************************
  5291. !*****************************************************************************************
  5292. !>
  5293. ! Alternate version of [[json_create_by_path]] where "path" is kind=CDK.
  5294. subroutine wrap_json_create_by_path(json,me,path,p,found,was_created)
  5295. implicit none
  5296. class(json_core),intent(inout) :: json
  5297. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5298. character(kind=CDK,len=*),intent(in) :: path !! path to the variable
  5299. type(json_value),pointer,intent(out),optional :: p !! pointer to the variable
  5300. !! specify by `path`
  5301. logical(LK),intent(out),optional :: found !! true if there were no errors
  5302. !! (variable found or created)
  5303. logical(LK),intent(out),optional :: was_created !! true if it was actually created
  5304. !! (as opposed to already being there)
  5305. call json%create(me,to_unicode(path),p,found,was_created)
  5306. end subroutine wrap_json_create_by_path
  5307. !*****************************************************************************************
  5308. !*****************************************************************************************
  5309. !>
  5310. ! Rename a [[json_value]], given the path.
  5311. !
  5312. !@note this is a wrapper for [[json_value_rename]].
  5313. subroutine json_rename_by_path(json, me, path, name, found)
  5314. implicit none
  5315. class(json_core),intent(inout) :: json
  5316. type(json_value),pointer,intent(in) :: me
  5317. character(kind=CK,len=*),intent(in) :: path !! path to the variable to rename
  5318. character(kind=CK,len=*),intent(in) :: name !! the new name
  5319. logical(LK),intent(out),optional :: found !! if there were no errors
  5320. type(json_value),pointer :: p
  5321. if ( json%exception_thrown ) then
  5322. if ( present(found) ) found = .false.
  5323. return
  5324. end if
  5325. nullify(p)
  5326. call json%get(me=me, path=path, p=p)
  5327. if (.not. associated(p)) then
  5328. call json%throw_exception('Error in json_rename_by_path:'//&
  5329. ' Unable to resolve path: '//trim(path),found)
  5330. else
  5331. call json%rename(p,name)
  5332. nullify(p)
  5333. end if
  5334. if (json%exception_thrown) then
  5335. if (present(found)) then
  5336. found = .false.
  5337. call json%clear_exceptions()
  5338. end if
  5339. else
  5340. if (present(found)) found = .true.
  5341. end if
  5342. end subroutine json_rename_by_path
  5343. !*****************************************************************************************
  5344. !*****************************************************************************************
  5345. !>
  5346. ! Alternate version of [[json_rename_by_path]], where "path" and "name" are kind=CDK
  5347. subroutine wrap_json_rename_by_path(json, me, path, name, found)
  5348. implicit none
  5349. class(json_core),intent(inout) :: json
  5350. type(json_value),pointer,intent(in) :: me
  5351. character(kind=CDK,len=*),intent(in) :: path
  5352. character(kind=CDK,len=*),intent(in) :: name
  5353. logical(LK),intent(out),optional :: found
  5354. call json%rename(me,to_unicode(path),to_unicode(name),found)
  5355. end subroutine wrap_json_rename_by_path
  5356. !*****************************************************************************************
  5357. !*****************************************************************************************
  5358. !>
  5359. ! Alternate version of [[json_rename_by_path]], where "name" is kind=CDK
  5360. subroutine json_rename_by_path_name_ascii(json, me, path, name, found)
  5361. implicit none
  5362. class(json_core),intent(inout) :: json
  5363. type(json_value),pointer,intent(in) :: me
  5364. character(kind=CK,len=*),intent(in) :: path
  5365. character(kind=CDK,len=*),intent(in) :: name
  5366. logical(LK),intent(out),optional :: found
  5367. call json%rename(me,path,to_unicode(name),found)
  5368. end subroutine json_rename_by_path_name_ascii
  5369. !*****************************************************************************************
  5370. !*****************************************************************************************
  5371. !>
  5372. ! Alternate version of [[json_rename_by_path]], where "path" is kind=CDK
  5373. subroutine json_rename_by_path_path_ascii(json, me, path, name, found)
  5374. implicit none
  5375. class(json_core),intent(inout) :: json
  5376. type(json_value),pointer,intent(in) :: me
  5377. character(kind=CDK,len=*),intent(in) :: path
  5378. character(kind=CK,len=*),intent(in) :: name
  5379. logical(LK),intent(out),optional :: found
  5380. call json%rename(me,to_unicode(path),name,found)
  5381. end subroutine json_rename_by_path_path_ascii
  5382. !*****************************************************************************************
  5383. !*****************************************************************************************
  5384. !>
  5385. ! Returns the [[json_value]] pointer given the path string.
  5386. !
  5387. !### Example
  5388. !
  5389. !````fortran
  5390. ! type(json_core) :: json
  5391. ! type(json_value),pointer :: dat,p
  5392. ! logical :: found
  5393. ! !...
  5394. ! call json%initialize(path_mode=1) ! this is the default so not strictly necessary.
  5395. ! call json%get(dat,'data(2).version',p,found)
  5396. !````
  5397. !
  5398. !### Notes
  5399. ! The syntax used here is a subset of the
  5400. ! [http://goessner.net/articles/JsonPath/](JSONPath) "dot–notation".
  5401. ! The following special characters are used to denote paths:
  5402. !
  5403. ! * `$` - root
  5404. ! * `@` - this
  5405. ! * `.` - child object member (note this can be changed using `json%path_separator`)
  5406. ! * `[]` or `()` - child array element (note that indices are 1-based)
  5407. !
  5408. ! Thus, if any of these characters are present in the name key,
  5409. ! this routine cannot be used to get the value.
  5410. ! In that case, the `get_child` methods would need to be used.
  5411. ! Or, the alternate [[json_get_by_path_rfc6901]] could be used.
  5412. !
  5413. !### See also
  5414. ! * [[json_get_by_path_rfc6901]]
  5415. ! * [[json_get_by_path_jsonpath_bracket]]
  5416. !
  5417. !@note The syntax is inherited from FSON, and is basically a subset
  5418. ! of JSONPath "dot-notation", with the additional allowance of
  5419. ! () for array elements.
  5420. !
  5421. !@note JSON `null` values are used here for unknown variables when `create_it` is True.
  5422. ! So, it is possible that an existing null variable can be converted to another
  5423. ! type (object or array) if a child is specified in the path. Doing it this way
  5424. ! to avoid having to use another type (say `json_unknown`) that would have to be
  5425. ! converted to null once all the variables have been created (user would have
  5426. ! had to do this).
  5427. !
  5428. !@warning See (**) in code. I think we need to protect for memory leaks when
  5429. ! changing the type of a variable that already exists.
  5430. subroutine json_get_by_path_default(json,me,path,p,found,create_it,was_created)
  5431. implicit none
  5432. class(json_core),intent(inout) :: json
  5433. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5434. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5435. type(json_value),pointer,intent(out) :: p !! pointer to the variable
  5436. !! specify by `path`
  5437. logical(LK),intent(out),optional :: found !! true if it was found
  5438. logical(LK),intent(in),optional :: create_it !! if a variable is not present
  5439. !! in the path, then it is created.
  5440. !! the leaf node is returned as
  5441. !! a `null` json type and can be
  5442. !! changed by the caller.
  5443. logical(LK),intent(out),optional :: was_created !! if `create_it` is true, this
  5444. !! will be true if the variable
  5445. !! was actually created. Otherwise
  5446. !! it will be false.
  5447. integer(IK) :: i !! counter of characters in `path`
  5448. integer(IK) :: length !! significant length of `path`
  5449. integer(IK) :: child_i !! index for getting children
  5450. character(kind=CK,len=1) :: c !! a character in the `path`
  5451. logical(LK) :: array !! flag when searching for array index in `path`
  5452. type(json_value),pointer :: tmp !! temp variables for getting child objects
  5453. logical(LK) :: child_found !! if the child value was found
  5454. logical(LK) :: create !! if the object is to be created
  5455. logical(LK) :: created !! if `create` is true, then this will be
  5456. !! true if the leaf object had to be created
  5457. integer(IK) :: j !! counter of children when creating object
  5458. logical(LK) :: status_ok !! integer to string conversion flag
  5459. nullify(p)
  5460. if (.not. json%exception_thrown) then
  5461. if (present(create_it)) then
  5462. create = create_it
  5463. else
  5464. create = .false.
  5465. end if
  5466. ! default to assuming relative to me
  5467. p => me
  5468. child_i = 1
  5469. array = .false.
  5470. created = .false.
  5471. !keep trailing space or not:
  5472. if (json%trailing_spaces_significant) then
  5473. length = len(path)
  5474. else
  5475. length = len_trim(path)
  5476. end if
  5477. do i=1, length
  5478. c = path(i:i)
  5479. select case (c)
  5480. case (root)
  5481. ! root
  5482. do while (associated (p%parent))
  5483. p => p%parent
  5484. end do
  5485. child_i = i + 1
  5486. if (create) created = .false. ! should always exist
  5487. case (this)
  5488. ! this
  5489. p => me
  5490. child_i = i + 1
  5491. if (create) created = .false. ! should always exist
  5492. case (start_array,start_array_alt)
  5493. ! start looking for the array element index
  5494. array = .true.
  5495. ! get child member from p
  5496. if (child_i < i) then
  5497. nullify(tmp)
  5498. if (create) then
  5499. ! Example:
  5500. ! 'aaa.bbb(1)'
  5501. ! -> and aaa is a null, need to make it an object
  5502. !
  5503. ! What about the case: aaa.bbb(1)(3) ?
  5504. ! Is that already handled?
  5505. if (p%var_type==json_null) then ! (**)
  5506. ! if p was also created, then we need to
  5507. ! convert it into an object here:
  5508. p%var_type = json_object
  5509. end if
  5510. ! don't want to throw exceptions in this case
  5511. call json%get_child(p, path(child_i:i-1), tmp, child_found)
  5512. if (.not. child_found) then
  5513. ! have to create this child
  5514. ! [make it an array]
  5515. call json_value_create(tmp)
  5516. call json%to_array(tmp,path(child_i:i-1))
  5517. call json%add(p,tmp)
  5518. created = .true.
  5519. else
  5520. created = .false.
  5521. end if
  5522. else
  5523. ! call the normal way
  5524. call json%get_child(p, path(child_i:i-1), tmp)
  5525. end if
  5526. p => tmp
  5527. else
  5528. child_i = i + 1 ! say, '@('
  5529. cycle
  5530. end if
  5531. if (.not. associated(p)) then
  5532. call json%throw_exception('Error in json_get_by_path_default:'//&
  5533. ' Error getting array element',found)
  5534. exit
  5535. end if
  5536. child_i = i + 1
  5537. case (end_array,end_array_alt)
  5538. if (.not. array) then
  5539. call json%throw_exception('Error in json_get_by_path_default:'//&
  5540. ' Unexpected '//c,found)
  5541. exit
  5542. end if
  5543. array = .false.
  5544. call string_to_integer(path(child_i:i-1),child_i,status_ok)
  5545. if (.not. status_ok) then
  5546. call json%throw_exception('Error in json_get_by_path_default:'//&
  5547. ' Could not convert array index to integer: '//&
  5548. trim(path(child_i:i-1)),found)
  5549. exit
  5550. end if
  5551. nullify(tmp)
  5552. if (create) then
  5553. ! don't want to throw exceptions in this case
  5554. call json%get_child(p, child_i, tmp, child_found)
  5555. if (.not. child_found) then
  5556. if (p%var_type==json_null) then ! (**)
  5557. ! if p was also created, then we need to
  5558. ! convert it into an array here:
  5559. p%var_type = json_array
  5560. end if
  5561. ! have to create this element
  5562. ! [make it a null]
  5563. ! (and any missing ones before it)
  5564. do j = 1, child_i
  5565. nullify(tmp)
  5566. call json%get_child(p, j, tmp, child_found)
  5567. if (.not. child_found) then
  5568. call json_value_create(tmp)
  5569. call json%to_null(tmp) ! array element doesn't need a name
  5570. call json%add(p,tmp)
  5571. if (j==child_i) created = .true.
  5572. else
  5573. if (j==child_i) created = .false.
  5574. end if
  5575. end do
  5576. else
  5577. created = .false.
  5578. end if
  5579. else
  5580. ! call the normal way:
  5581. call json%get_child(p, child_i, tmp)
  5582. end if
  5583. p => tmp
  5584. child_i = i + 1
  5585. case default
  5586. if (c==json%path_separator) then
  5587. ! get child member from p
  5588. if (child_i < i) then
  5589. nullify(tmp)
  5590. if (create) then
  5591. if (p%var_type==json_null) then ! (**)
  5592. ! if p was also created, then we need to
  5593. ! convert it into an object here:
  5594. p%var_type = json_object
  5595. end if
  5596. ! don't want to throw exceptions in this case
  5597. call json%get_child(p, path(child_i:i-1), tmp, child_found)
  5598. if (.not. child_found) then
  5599. ! have to create this child
  5600. ! [make it an object]
  5601. call json_value_create(tmp)
  5602. call json%to_object(tmp,path(child_i:i-1))
  5603. call json%add(p,tmp)
  5604. created = .true.
  5605. else
  5606. created = .false.
  5607. end if
  5608. else
  5609. ! call the normal way
  5610. call json%get_child(p, path(child_i:i-1), tmp)
  5611. end if
  5612. p => tmp
  5613. else
  5614. child_i = i + 1 ! say '$.', '@.', or ').'
  5615. cycle
  5616. end if
  5617. if (.not. associated(p)) then
  5618. call json%throw_exception('Error in json_get_by_path_default:'//&
  5619. ' Error getting child member.',found)
  5620. exit
  5621. end if
  5622. child_i = i + 1
  5623. end if
  5624. end select
  5625. end do
  5626. if (json%exception_thrown) then
  5627. if (present(found)) then
  5628. nullify(p) ! just in case
  5629. found = .false.
  5630. call json%clear_exceptions()
  5631. end if
  5632. else
  5633. ! grab the last child if present in the path
  5634. if (child_i <= length) then
  5635. nullify(tmp)
  5636. if (create) then
  5637. if (p%var_type==json_null) then ! (**)
  5638. ! if p was also created, then we need to
  5639. ! convert it into an object here:
  5640. p%var_type = json_object
  5641. end if
  5642. call json%get_child(p, path(child_i:i-1), tmp, child_found)
  5643. if (.not. child_found) then
  5644. ! have to create this child
  5645. ! (make it a null since it is the leaf)
  5646. call json_value_create(tmp)
  5647. call json%to_null(tmp,path(child_i:i-1))
  5648. call json%add(p,tmp)
  5649. created = .true.
  5650. else
  5651. created = .false.
  5652. end if
  5653. else
  5654. ! call the normal way
  5655. call json%get_child(p, path(child_i:i-1), tmp)
  5656. end if
  5657. p => tmp
  5658. else
  5659. ! we already have p
  5660. if (create .and. created) then
  5661. ! make leaf p a null, but only
  5662. ! if it wasn't there
  5663. call json%to_null(p)
  5664. end if
  5665. end if
  5666. ! error checking
  5667. if (associated(p)) then
  5668. if (present(found)) found = .true. !everything seems to be ok
  5669. else
  5670. call json%throw_exception('Error in json_get_by_path_default:'//&
  5671. ' variable not found: '//trim(path),found)
  5672. if (present(found)) then
  5673. found = .false.
  5674. call json%clear_exceptions()
  5675. end if
  5676. end if
  5677. end if
  5678. ! if it had to be created:
  5679. if (present(was_created)) was_created = created
  5680. else
  5681. if (present(found)) found = .false.
  5682. if (present(was_created)) was_created = .false.
  5683. end if
  5684. end subroutine json_get_by_path_default
  5685. !*****************************************************************************************
  5686. !*****************************************************************************************
  5687. !> author: Jacob Williams
  5688. ! date: 2/4/2017
  5689. !
  5690. ! Returns the [[json_value]] pointer given the path string,
  5691. ! using the "JSON Pointer" path specification defined by RFC 6901.
  5692. !
  5693. ! Note that trailing whitespace significance and case sensitivity
  5694. ! are user-specified. To fully conform to the RFC 6901 standard,
  5695. ! should probably set (via `initialize`):
  5696. !
  5697. ! * `case_sensitive_keys = .true.` [this is the default setting]
  5698. ! * `trailing_spaces_significant = .true.` [this is *not* the default setting]
  5699. ! * `allow_duplicate_keys = .false.` [this is *not* the default setting]
  5700. !
  5701. !### Example
  5702. !
  5703. !````fortran
  5704. ! type(json_core) :: json
  5705. ! type(json_value),pointer :: dat,p
  5706. ! logical :: found
  5707. ! !...
  5708. ! call json%initialize(path_mode=2)
  5709. ! call json%get(dat,'/data/2/version',p,found)
  5710. !````
  5711. !
  5712. !### See also
  5713. ! * [[json_get_by_path_default]]
  5714. ! * [[json_get_by_path_jsonpath_bracket]]
  5715. !
  5716. !### Reference
  5717. ! * [JavaScript Object Notation (JSON) Pointer](https://tools.ietf.org/html/rfc6901)
  5718. !
  5719. !@note Not doing anything special about the `-` character to index an array.
  5720. ! This is considered a normal error.
  5721. !
  5722. !@note Unlike in the default path mode, the array indices here are 0-based
  5723. ! (in accordance with the RFC 6901 standard)
  5724. !
  5725. !@warning Not checking if the member that is referenced is unique.
  5726. ! (according to the standard, evaluation of non-unique references
  5727. ! should fail). Like [[json_get_by_path_default]], this one will just return
  5728. ! the first instance it encounters. This might be changed in the future.
  5729. !
  5730. !@warning I think the standard indicates that the input paths should use
  5731. ! escaped JSON strings (currently we are assuming they are not escaped).
  5732. subroutine json_get_by_path_rfc6901(json, me, path, p, found)
  5733. implicit none
  5734. class(json_core),intent(inout) :: json
  5735. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5736. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5737. !! (an RFC 6901 "JSON Pointer")
  5738. type(json_value),pointer,intent(out) :: p !! pointer to the variable
  5739. !! specify by `path`
  5740. logical(LK),intent(out),optional :: found !! true if it was found
  5741. character(kind=CK,len=:),allocatable :: token !! a token in the path (between the `/` characters)
  5742. integer(IK) :: i !! counter
  5743. integer(IK) :: islash_curr !! location of current '/' character in the path
  5744. integer(IK) :: islash_next !! location of next '/' character in the path
  5745. integer(IK) :: ilen !! length of `path` string
  5746. type(json_value),pointer :: tmp !! temporary variable for traversing the structure
  5747. integer(IK) :: ival !! integer array index value (0-based)
  5748. logical(LK) :: status_ok !! error flag
  5749. logical(LK) :: child_found !! for getting child values
  5750. nullify(p)
  5751. if (.not. json%exception_thrown) then
  5752. p => me ! initialize
  5753. if (path/=CK_'') then
  5754. if (path(1:1)==slash) then ! the first character must be a slash
  5755. islash_curr = 1 ! initialize current slash index
  5756. !keep trailing space or not:
  5757. if (json%trailing_spaces_significant) then
  5758. ilen = len(path)
  5759. else
  5760. ilen = len_trim(path)
  5761. end if
  5762. do
  5763. ! get the next token by finding the slashes
  5764. !
  5765. ! 1 2 3
  5766. ! /abc/d/efg
  5767. if (islash_curr==ilen) then
  5768. !the last token is an empty string
  5769. token = CK_''
  5770. islash_next = 0 ! will signal to stop
  5771. else
  5772. ! .
  5773. ! '/123/567/'
  5774. ! index in remaining string:
  5775. islash_next = index(path(islash_curr+1:ilen),slash)
  5776. if (islash_next<=0) then
  5777. !last token:
  5778. token = path(islash_curr+1:ilen)
  5779. else
  5780. ! convert to actual index in path:
  5781. islash_next = islash_curr + index(path(islash_curr+1:ilen),slash)
  5782. if (islash_next>islash_curr+1) then
  5783. token = path(islash_curr+1:islash_next-1)
  5784. else
  5785. !empty token:
  5786. token = CK_''
  5787. end if
  5788. end if
  5789. end if
  5790. ! remove trailing spaces in the token here if necessary:
  5791. if (.not. json%trailing_spaces_significant) &
  5792. token = trim(token)
  5793. ! decode the token:
  5794. token = decode_rfc6901(token)
  5795. ! now, parse the token:
  5796. ! first see if there is a child with this name
  5797. call json%get_child(p,token,tmp,child_found)
  5798. if (child_found) then
  5799. ! it was found
  5800. p => tmp
  5801. else
  5802. ! No key with this name.
  5803. ! Is it an integer? If so,
  5804. ! it might be an array index.
  5805. status_ok = (len(token)>0)
  5806. if (status_ok) then
  5807. do i=1,len(token)
  5808. ! It must only contain (0..9) characters
  5809. ! (it must be unsigned)
  5810. if (scan(token(i:i),CK_'0123456789')<1) then
  5811. status_ok = .false.
  5812. exit
  5813. end if
  5814. end do
  5815. if (status_ok) then
  5816. if (len(token)>1 .and. token(1:1)==CK_'0') then
  5817. ! leading zeros not allowed for some reason
  5818. status_ok = .false.
  5819. end if
  5820. end if
  5821. if (status_ok) then
  5822. ! if we make it this far, it should be
  5823. ! convertible to an integer, so do it.
  5824. call string_to_integer(token,ival,status_ok)
  5825. end if
  5826. end if
  5827. if (status_ok) then
  5828. ! ival is an array index (0-based)
  5829. call json%get_child(p,ival+1_IK,tmp,child_found)
  5830. if (child_found) then
  5831. p => tmp
  5832. else
  5833. ! not found
  5834. status_ok = .false.
  5835. end if
  5836. end if
  5837. if (.not. status_ok) then
  5838. call json%throw_exception('Error in json_get_by_path_rfc6901: '//&
  5839. 'invalid path specification: '//trim(path),found)
  5840. exit
  5841. end if
  5842. end if
  5843. if (islash_next<=0) exit ! finished
  5844. ! set up for next token:
  5845. islash_curr = islash_next
  5846. end do
  5847. else
  5848. call json%throw_exception('Error in json_get_by_path_rfc6901: '//&
  5849. 'invalid path specification: '//trim(path),found)
  5850. end if
  5851. end if
  5852. if (json%exception_thrown) then
  5853. nullify(p)
  5854. if (present(found)) then
  5855. found = .false.
  5856. call json%clear_exceptions()
  5857. end if
  5858. else
  5859. if (present(found)) found = .true.
  5860. end if
  5861. else
  5862. if (present(found)) found = .false.
  5863. end if
  5864. end subroutine json_get_by_path_rfc6901
  5865. !*****************************************************************************************
  5866. !*****************************************************************************************
  5867. !> author: Jacob Williams
  5868. ! date: 9/2/2017
  5869. !
  5870. ! Returns the [[json_value]] pointer given the path string,
  5871. ! using the "JSON Pointer" path specification defined by the
  5872. ! JSONPath "bracket-notation".
  5873. !
  5874. ! The first character `$` is optional, and signifies the root
  5875. ! of the structure. If it is not present, then the first key
  5876. ! is taken to be in the `me` object.
  5877. !
  5878. ! Single or real quotes may be used.
  5879. !
  5880. !### Example
  5881. !
  5882. !````fortran
  5883. ! type(json_core) :: json
  5884. ! type(json_value),pointer :: dat,p
  5885. ! logical :: found
  5886. ! !...
  5887. ! call json%initialize(path_mode=3)
  5888. ! call json%get(dat,"$['store']['book'][1]['title']",p,found)
  5889. !````
  5890. !
  5891. !### See also
  5892. ! * [[json_get_by_path_default]]
  5893. ! * [[json_get_by_path_rfc6901]]
  5894. !
  5895. !### Reference
  5896. ! * [JSONPath](http://goessner.net/articles/JsonPath/)
  5897. !
  5898. !@note Uses 1-based array indices (same as [[json_get_by_path_default]],
  5899. ! but unlike [[json_get_by_path_rfc6901]] which uses 0-based indices).
  5900. !
  5901. !@note When `create_it=True`, if the variable already exists and is a type
  5902. ! that is not compatible with the usage in the `path`, then it is
  5903. ! destroyed and replaced with what is specified in the `path`. Note that
  5904. ! this applies the all variables in the path as it is created. Currently,
  5905. ! this behavior is different from [[json_get_by_path_default]].
  5906. !
  5907. !@note JSON `null` values are used here for unknown variables
  5908. ! when `create_it` is True.
  5909. !
  5910. !@warning Note that if using single quotes, this routine cannot parse
  5911. ! a key containing `']`. If using real quotes, this routine
  5912. ! cannot parse a key containing `"]`. If the key contains both
  5913. ! `']` and `"]`, there is no way to parse it using this routine.
  5914. subroutine json_get_by_path_jsonpath_bracket(json,me,path,p,found,create_it,was_created)
  5915. implicit none
  5916. class(json_core),intent(inout) :: json
  5917. type(json_value),pointer,intent(in) :: me !! a JSON linked list
  5918. character(kind=CK,len=*),intent(in) :: path !! path to the variable
  5919. !! (using JSONPath
  5920. !! "bracket-notation")
  5921. type(json_value),pointer,intent(out) :: p !! pointer to the variable
  5922. !! specify by `path`
  5923. logical(LK),intent(out),optional :: found !! true if it was found
  5924. logical(LK),intent(in),optional :: create_it !! if a variable is not present
  5925. !! in the path, then it is created.
  5926. !! the leaf node is returned as
  5927. !! a `null` json type and can be
  5928. !! changed by the caller.
  5929. logical(LK),intent(out),optional :: was_created !! if `create_it` is true, this
  5930. !! will be true if the variable
  5931. !! was actually created. Otherwise
  5932. !! it will be false.
  5933. character(kind=CK,len=:),allocatable :: token !! a token in the path
  5934. !! (between the `['']` or
  5935. !! `[]` characters)
  5936. integer(IK) :: istart !! location of current '['
  5937. !! character in the path
  5938. integer(IK) :: iend !! location of current ']'
  5939. !! character in the path
  5940. integer(IK) :: ival !! integer array index value
  5941. logical(LK) :: status_ok !! error flag
  5942. type(json_value),pointer :: tmp !! temporary variable for
  5943. !! traversing the structure
  5944. integer(IK) :: i !! counter
  5945. integer(IK) :: ilen !! length of `path` string
  5946. logical(LK) :: real_quotes !! if the keys are enclosed in `"`,
  5947. !! rather than `'` tokens.
  5948. logical(LK) :: create !! if the object is to be created
  5949. logical(LK) :: created !! if `create` is true, then this will be
  5950. !! true if the leaf object had to be created
  5951. integer(IK) :: j !! counter of children when creating object
  5952. !TODO instead of reallocating `token` all the time, just
  5953. ! allocate a big size and keep track of the length,
  5954. ! then just reallocate only if necessary.
  5955. ! [would probably be inefficient if there was a very large token,
  5956. ! and then a bunch of small ones... but for similarly-sized ones
  5957. ! it should be way more efficient since it would avoid most
  5958. ! reallocations.]
  5959. nullify(p)
  5960. if (.not. json%exception_thrown) then
  5961. if (present(create_it)) then
  5962. create = create_it
  5963. else
  5964. create = .false.
  5965. end if
  5966. p => me ! initialize
  5967. created = .false.
  5968. if (path==CK_'') then
  5969. call json%throw_exception('Error in json_get_by_path_jsonpath_bracket: '//&
  5970. 'invalid path specification: '//trim(path),found)
  5971. else
  5972. if (path(1:1)==root .or. path(1:1)==start_array) then ! the first character must be
  5973. ! a `$` (root) or a `[`
  5974. ! (element of `me`)
  5975. if (path(1:1)==root) then
  5976. ! go to the root
  5977. do while (associated (p%parent))
  5978. p => p%parent
  5979. end do
  5980. if (create) created = .false. ! should always exist
  5981. end if
  5982. !path length (don't need trailing spaces:)
  5983. ilen = len_trim(path)
  5984. if (ilen>1) then
  5985. istart = 2 ! initialize first '[' location index
  5986. do
  5987. if (istart>ilen) exit ! finished
  5988. ! must be the next start bracket:
  5989. if (path(istart:istart) /= start_array) then
  5990. call json%throw_exception(&
  5991. 'Error in json_get_by_path_jsonpath_bracket: '//&
  5992. 'expecting "[", found: "'//trim(path(istart:istart))//&
  5993. '" in path: '//trim(path),found)
  5994. exit
  5995. end if
  5996. ! get the next token by checking:
  5997. !
  5998. ! * [''] -- is the token after istart a quote?
  5999. ! if so, then search for the next `']`
  6000. !
  6001. ! * [1] -- if not, then maybe it is a number,
  6002. ! so search for the next `]`
  6003. ! verify length of remaining string
  6004. if (istart+2<=ilen) then
  6005. real_quotes = path(istart+1:istart+1) == quotation_mark ! ["
  6006. if (real_quotes .or. path(istart+1:istart+1)==single_quote) then ! ['
  6007. ! it might be a key value: ['abc']
  6008. istart = istart + 1 ! move counter to ' index
  6009. if (real_quotes) then
  6010. iend = istart + index(path(istart+1:ilen),&
  6011. quotation_mark//end_array) ! "]
  6012. else
  6013. iend = istart + index(path(istart+1:ilen),&
  6014. single_quote//end_array) ! ']
  6015. end if
  6016. if (iend>istart) then
  6017. ! istart iend
  6018. ! | |
  6019. ! ['p']['abcdefg']
  6020. if (iend>istart+1) then
  6021. token = path(istart+1:iend-1)
  6022. else
  6023. token = CK_'' ! blank string
  6024. end if
  6025. ! remove trailing spaces in
  6026. ! the token here if necessary:
  6027. if (.not. json%trailing_spaces_significant) &
  6028. token = trim(token)
  6029. if (create) then
  6030. ! have a token, create it if necessary
  6031. ! we need to convert it into an object here
  6032. ! (e.g., if p was also just created)
  6033. ! and destroy its data to prevent a memory leak
  6034. call json%convert(p,json_object)
  6035. ! don't want to throw exceptions in this case
  6036. call json%get_child(p,token,tmp,status_ok)
  6037. if (.not. status_ok) then
  6038. ! have to create this child
  6039. ! [make it a null since we don't
  6040. ! know what it is yet]
  6041. call json_value_create(tmp)
  6042. call json%to_null(tmp,token)
  6043. call json%add(p,tmp)
  6044. status_ok = .true.
  6045. created = .true.
  6046. else
  6047. ! it was already there.
  6048. created = .false.
  6049. end if
  6050. else
  6051. ! have a token, see if it is valid:
  6052. call json%get_child(p,token,tmp,status_ok)
  6053. end if
  6054. if (status_ok) then
  6055. ! it was found
  6056. p => tmp
  6057. else
  6058. call json%throw_exception(&
  6059. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6060. 'invalid token found: "'//token//&
  6061. '" in path: '//trim(path),found)
  6062. exit
  6063. end if
  6064. iend = iend + 1 ! move counter to ] index
  6065. else
  6066. call json%throw_exception(&
  6067. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6068. 'invalid path: '//trim(path),found)
  6069. exit
  6070. end if
  6071. else
  6072. ! it might be an integer value: [123]
  6073. iend = istart + index(path(istart+1:ilen),end_array) ! ]
  6074. if (iend>istart+1) then
  6075. ! this should be an integer:
  6076. token = path(istart+1:iend-1)
  6077. ! verify that there are no spaces or other
  6078. ! characters in the string:
  6079. status_ok = .true.
  6080. do i=1,len(token)
  6081. ! It must only contain (0..9) characters
  6082. ! (it must be unsigned)
  6083. if (scan(token(i:i),CK_'0123456789')<1) then
  6084. status_ok = .false.
  6085. exit
  6086. end if
  6087. end do
  6088. if (status_ok) then
  6089. call string_to_integer(token,ival,status_ok)
  6090. if (status_ok) status_ok = ival>0 ! assuming 1-based array indices
  6091. end if
  6092. if (status_ok) then
  6093. ! have a valid integer to use as an index
  6094. ! see if this element is really there:
  6095. call json%get_child(p,ival,tmp,status_ok)
  6096. if (create .and. .not. status_ok) then
  6097. ! have to create it:
  6098. if (.not.(p%var_type==json_object .or. p%var_type==json_array)) then
  6099. ! we need to convert it into an array here
  6100. ! (e.g., if p was also just created)
  6101. ! and destroy its data to prevent a memory leak
  6102. call json%convert(p,json_array)
  6103. end if
  6104. ! have to create this element
  6105. ! [make it a null]
  6106. ! (and any missing ones before it)
  6107. do j = 1, ival
  6108. nullify(tmp)
  6109. call json%get_child(p, j, tmp, status_ok)
  6110. if (.not. status_ok) then
  6111. call json_value_create(tmp)
  6112. call json%to_null(tmp) ! array element doesn't need a name
  6113. call json%add(p,tmp)
  6114. if (j==ival) created = .true.
  6115. else
  6116. if (j==ival) created = .false.
  6117. end if
  6118. end do
  6119. status_ok = .true.
  6120. else
  6121. created = .false.
  6122. end if
  6123. if (status_ok) then
  6124. ! found it
  6125. p => tmp
  6126. else
  6127. ! not found
  6128. call json%throw_exception(&
  6129. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6130. 'invalid array index found: "'//token//&
  6131. '" in path: '//trim(path),found)
  6132. exit
  6133. end if
  6134. else
  6135. call json%throw_exception(&
  6136. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6137. 'invalid token: "'//token//&
  6138. '" in path: '//trim(path),found)
  6139. exit
  6140. end if
  6141. else
  6142. call json%throw_exception(&
  6143. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6144. 'invalid path: '//trim(path),found)
  6145. exit
  6146. end if
  6147. end if
  6148. else
  6149. call json%throw_exception(&
  6150. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6151. 'invalid path: '//trim(path),found)
  6152. exit
  6153. end if
  6154. ! set up for next token:
  6155. istart = iend + 1
  6156. end do
  6157. end if
  6158. else
  6159. call json%throw_exception(&
  6160. 'Error in json_get_by_path_jsonpath_bracket: '//&
  6161. 'expecting "'//root//'", found: "'//path(1:1)//&
  6162. '" in path: '//trim(path),found)
  6163. end if
  6164. end if
  6165. if (json%exception_thrown) then
  6166. nullify(p)
  6167. if (present(found)) then
  6168. found = .false.
  6169. call json%clear_exceptions()
  6170. end if
  6171. else
  6172. if (present(found)) found = .true.
  6173. end if
  6174. ! if it had to be created:
  6175. if (present(was_created)) was_created = created
  6176. else
  6177. if (present(found)) found = .false.
  6178. if (present(was_created)) was_created = .false.
  6179. end if
  6180. end subroutine json_get_by_path_jsonpath_bracket
  6181. !*****************************************************************************************
  6182. !*****************************************************************************************
  6183. !>
  6184. ! Convert an existing JSON variable `p` to a different variable type.
  6185. ! The existing variable (and its children) is destroyed. It is replaced
  6186. ! in the structure by a new variable of type `var_type`
  6187. ! (which can be a `json_null`, `json_object` or `json_array`).
  6188. !
  6189. !@note This is an internal routine used when creating variables by path.
  6190. subroutine convert(json,p,var_type)
  6191. implicit none
  6192. class(json_core),intent(inout) :: json
  6193. type(json_value),pointer :: p !! the variable to convert
  6194. integer(IK),intent(in) :: var_type !! the variable type to convert `p` to
  6195. type(json_value),pointer :: tmp !! temporary variable
  6196. character(kind=CK,len=:),allocatable :: name !! the name of a JSON variable
  6197. logical :: convert_it !! if `p` needs to be converted
  6198. convert_it = p%var_type /= var_type
  6199. if (convert_it) then
  6200. call json%info(p,name=name) ! get existing name
  6201. select case (var_type)
  6202. case(json_object)
  6203. call json%create_object(tmp,name)
  6204. case(json_array)
  6205. call json%create_array(tmp,name)
  6206. case(json_null)
  6207. call json%create_null(tmp,name)
  6208. case default
  6209. call json%throw_exception('Error in convert: invalid var_type value.')
  6210. return
  6211. end select
  6212. call json%replace(p,tmp,destroy=.true.)
  6213. p => tmp
  6214. nullify(tmp)
  6215. end if
  6216. end subroutine convert
  6217. !*****************************************************************************************
  6218. !*****************************************************************************************
  6219. !>
  6220. ! Alternate version of [[json_get_by_path]] where "path" is kind=CDK.
  6221. subroutine wrap_json_get_by_path(json, me, path, p, found)
  6222. implicit none
  6223. class(json_core),intent(inout) :: json
  6224. type(json_value),pointer,intent(in) :: me
  6225. character(kind=CDK,len=*),intent(in) :: path
  6226. type(json_value),pointer,intent(out) :: p
  6227. logical(LK),intent(out),optional :: found
  6228. call json%get(me, to_unicode(path), p, found)
  6229. end subroutine wrap_json_get_by_path
  6230. !*****************************************************************************************
  6231. !*****************************************************************************************
  6232. !>
  6233. ! Returns the path to a JSON object that is part
  6234. ! of a linked list structure.
  6235. !
  6236. ! The path returned would be suitable for input to
  6237. ! [[json_get_by_path]] and related routines.
  6238. !
  6239. !@note If an error occurs (which in this case means a malformed
  6240. ! JSON structure) then an exception will be thrown, unless
  6241. ! `found` is present, which will be set to `false`. `path`
  6242. ! will be a blank string.
  6243. !
  6244. !@note If `json%path_mode/=1`, then the `use_alt_array_tokens`
  6245. ! and `path_sep` inputs are ignored if present.
  6246. !
  6247. !@note [http://goessner.net/articles/JsonPath/](JSONPath) (`path_mode=3`)
  6248. ! does not specify whether or not the keys should be escaped (this routine
  6249. ! assumes not, as does http://jsonpath.com).
  6250. ! Also, we are using Fortran-style 1-based array indices,
  6251. ! not 0-based, to agree with the assumption in `path_mode=1`
  6252. subroutine json_get_path(json, p, path, found, use_alt_array_tokens, path_sep)
  6253. implicit none
  6254. class(json_core),intent(inout) :: json
  6255. type(json_value),pointer,intent(in) :: p !! a JSON linked list object
  6256. character(kind=CK,len=:),allocatable,intent(out) :: path !! path to the variable
  6257. logical(LK),intent(out),optional :: found !! true if there were no problems
  6258. logical(LK),intent(in),optional :: use_alt_array_tokens !! if true, then '()' are used for array elements
  6259. !! otherwise, '[]' are used [default]
  6260. !! (only used if `path_mode=1`)
  6261. character(kind=CK,len=1),intent(in),optional :: path_sep !! character to use for path separator
  6262. !! (otherwise use `json%path_separator`)
  6263. !! (only used if `path_mode=1`)
  6264. character(kind=CK,len=:),allocatable :: name !! variable name
  6265. character(kind=CK,len=:),allocatable :: parent_name !! variable's parent name
  6266. character(kind=CK,len=max_integer_str_len) :: istr !! for integer to string conversion
  6267. !! (array indices)
  6268. type(json_value),pointer :: tmp !! for traversing the structure
  6269. type(json_value),pointer :: element !! for traversing the structure
  6270. integer(IK) :: var_type !! JSON variable type flag
  6271. integer(IK) :: i !! counter
  6272. integer(IK) :: n_children !! number of children for parent
  6273. logical(LK) :: use_brackets !! to use '[]' characters for arrays
  6274. logical(LK) :: parent_is_root !! if the parent is the root
  6275. character(kind=CK,len=1) :: array_start !! for `path_mode=1`, the character to start arrays
  6276. character(kind=CK,len=1) :: array_end !! for `path_mode=1`, the character to end arrays
  6277. logical :: consecutive_arrays !! check for array of array case
  6278. integer(IK) :: parents_parent_var_type !! `var_type` for parent's parent
  6279. !optional input:
  6280. if (present(use_alt_array_tokens)) then
  6281. use_brackets = .not. use_alt_array_tokens
  6282. else
  6283. use_brackets = .true.
  6284. end if
  6285. if (json%path_mode==1_IK) then
  6286. if (use_brackets) then
  6287. array_start = start_array
  6288. array_end = end_array
  6289. else
  6290. array_start = start_array_alt
  6291. array_end = end_array_alt
  6292. end if
  6293. end if
  6294. ! initialize:
  6295. consecutive_arrays = .false.
  6296. if (associated(p)) then
  6297. !traverse the structure via parents up to the root
  6298. tmp => p
  6299. do
  6300. if (.not. associated(tmp)) exit !finished
  6301. !get info about the current variable:
  6302. call json%info(tmp,name=name)
  6303. if (json%path_mode==2_IK) then
  6304. name = encode_rfc6901(name)
  6305. end if
  6306. ! if tmp a child of an object, or an element of an array
  6307. if (associated(tmp%parent)) then
  6308. !get info about the parent:
  6309. call json%info(tmp%parent,var_type=var_type,&
  6310. n_children=n_children,name=parent_name)
  6311. if (json%path_mode==2_IK) then
  6312. parent_name = encode_rfc6901(parent_name)
  6313. end if
  6314. if (associated(tmp%parent%parent)) then
  6315. call json%info(tmp%parent%parent,var_type=parents_parent_var_type)
  6316. consecutive_arrays = parents_parent_var_type == json_array .and. &
  6317. var_type == json_array
  6318. else
  6319. consecutive_arrays = .false.
  6320. end if
  6321. select case (var_type)
  6322. case (json_array)
  6323. !get array index of this element:
  6324. element => tmp%parent%children
  6325. do i = 1, n_children
  6326. if (.not. associated(element)) then
  6327. call json%throw_exception('Error in json_get_path: '//&
  6328. 'malformed JSON structure. ',found)
  6329. exit
  6330. end if
  6331. if (associated(element,tmp)) then
  6332. exit
  6333. else
  6334. element => element%next
  6335. end if
  6336. if (i==n_children) then ! it wasn't found (should never happen)
  6337. call json%throw_exception('Error in json_get_path: '//&
  6338. 'malformed JSON structure. ',found)
  6339. exit
  6340. end if
  6341. end do
  6342. select case(json%path_mode)
  6343. case(3_IK)
  6344. ! JSONPath "bracket-notation"
  6345. ! example: `$['key'][1]`
  6346. ! [note: this uses 1-based indices]
  6347. call integer_to_string(i,int_fmt,istr)
  6348. if (consecutive_arrays) then
  6349. call add_to_path(start_array//trim(adjustl(istr))//end_array,CK_'')
  6350. else
  6351. call add_to_path(start_array//single_quote//parent_name//&
  6352. single_quote//end_array//&
  6353. start_array//trim(adjustl(istr))//end_array,CK_'')
  6354. end if
  6355. case(2_IK)
  6356. ! rfc6901
  6357. ! Example: '/key/0'
  6358. call integer_to_string(i-1_IK,int_fmt,istr) ! 0-based index
  6359. if (consecutive_arrays) then
  6360. call add_to_path(trim(adjustl(istr)))
  6361. else
  6362. call add_to_path(parent_name//slash//trim(adjustl(istr)))
  6363. end if
  6364. case(1_IK)
  6365. ! default
  6366. ! Example: `key[1]`
  6367. call integer_to_string(i,int_fmt,istr)
  6368. if (consecutive_arrays) then
  6369. call add_to_path(array_start//trim(adjustl(istr))//array_end,path_sep)
  6370. else
  6371. call add_to_path(parent_name//array_start//&
  6372. trim(adjustl(istr))//array_end,path_sep)
  6373. end if
  6374. end select
  6375. if (.not. consecutive_arrays) tmp => tmp%parent ! already added parent name
  6376. case (json_object)
  6377. if (.not. consecutive_arrays) then
  6378. ! idea is not to print the array name if
  6379. ! it was already printed with the array
  6380. !process parent on the next pass
  6381. select case(json%path_mode)
  6382. case(3_IK)
  6383. call add_to_path(start_array//single_quote//name//&
  6384. single_quote//end_array,CK_'')
  6385. case default
  6386. call add_to_path(name,path_sep)
  6387. end select
  6388. end if
  6389. case default
  6390. call json%throw_exception('Error in json_get_path: '//&
  6391. 'malformed JSON structure. '//&
  6392. 'A variable that is not an object '//&
  6393. 'or array should not have a child.',found)
  6394. exit
  6395. end select
  6396. else
  6397. !the last one:
  6398. select case(json%path_mode)
  6399. case(3_IK)
  6400. call add_to_path(start_array//single_quote//name//&
  6401. single_quote//end_array,CK_'')
  6402. case default
  6403. call add_to_path(name,path_sep)
  6404. end select
  6405. end if
  6406. if (associated(tmp%parent)) then
  6407. !check if the parent is the root:
  6408. parent_is_root = (.not. associated(tmp%parent%parent))
  6409. if (parent_is_root) exit
  6410. end if
  6411. !go to parent:
  6412. tmp => tmp%parent
  6413. end do
  6414. else
  6415. call json%throw_exception('Error in json_get_path: '//&
  6416. 'input pointer is not associated',found)
  6417. end if
  6418. !for errors, return blank string:
  6419. if (json%exception_thrown .or. .not. allocated(path)) then
  6420. path = CK_''
  6421. else
  6422. select case (json%path_mode)
  6423. case(3_IK)
  6424. ! add the outer level object identifier:
  6425. path = root//path
  6426. case(2_IK)
  6427. ! add the root slash:
  6428. path = slash//path
  6429. end select
  6430. end if
  6431. !optional output:
  6432. if (present(found)) then
  6433. if (json%exception_thrown) then
  6434. found = .false.
  6435. call json%clear_exceptions()
  6436. else
  6437. found = .true.
  6438. end if
  6439. end if
  6440. contains
  6441. subroutine add_to_path(str,path_sep)
  6442. !! prepend the string to the path
  6443. implicit none
  6444. character(kind=CK,len=*),intent(in) :: str !! string to prepend to `path`
  6445. character(kind=CK,len=*),intent(in),optional :: path_sep
  6446. !! path separator (default is '.').
  6447. !! (ignored if `json%path_mode/=1`)
  6448. select case (json%path_mode)
  6449. case(3_IK)
  6450. ! in this case, the options are ignored
  6451. if (.not. allocated(path)) then
  6452. path = str
  6453. else
  6454. path = str//path
  6455. end if
  6456. case(2_IK)
  6457. ! in this case, the options are ignored
  6458. if (.not. allocated(path)) then
  6459. path = str
  6460. else
  6461. path = str//slash//path
  6462. end if
  6463. case(1_IK)
  6464. ! default path format
  6465. if (.not. allocated(path)) then
  6466. path = str
  6467. else
  6468. ! shouldn't add the path_sep for cases like x[1][2]
  6469. ! [if current is an array element, and the previous was
  6470. ! also an array element] so check for that here:
  6471. if (.not. ( str(len(str):len(str))==array_end .and. &
  6472. path(1:1)==array_start )) then
  6473. if (present(path_sep)) then
  6474. ! use user specified:
  6475. path = str//path_sep//path
  6476. else
  6477. ! use the default:
  6478. path = str//json%path_separator//path
  6479. end if
  6480. else
  6481. path = str//path
  6482. end if
  6483. end if
  6484. end select
  6485. end subroutine add_to_path
  6486. end subroutine json_get_path
  6487. !*****************************************************************************************
  6488. !*****************************************************************************************
  6489. !>
  6490. ! Wrapper for [[json_get_path]] where "path" and "path_sep" are kind=CDK.
  6491. subroutine wrap_json_get_path(json, p, path, found, use_alt_array_tokens, path_sep)
  6492. implicit none
  6493. class(json_core),intent(inout) :: json
  6494. type(json_value),pointer,intent(in) :: p !! a JSON linked list object
  6495. character(kind=CDK,len=:),allocatable,intent(out) :: path !! path to the variable
  6496. logical(LK),intent(out),optional :: found !! true if there were no problems
  6497. logical(LK),intent(in),optional :: use_alt_array_tokens !! if true, then '()' are used
  6498. !! for array elements otherwise,
  6499. !! '[]' are used [default]
  6500. character(kind=CDK,len=1),intent(in),optional :: path_sep !! character to use for path
  6501. !! separator (default is '.')
  6502. character(kind=CK,len=:),allocatable :: ck_path !! path to the variable
  6503. ! call the main routine:
  6504. if (present(path_sep)) then
  6505. call json%get_path(p,ck_path,found,use_alt_array_tokens,to_unicode(path_sep))
  6506. else
  6507. call json%get_path(p,ck_path,found,use_alt_array_tokens)
  6508. end if
  6509. ! from unicode:
  6510. path = ck_path
  6511. end subroutine wrap_json_get_path
  6512. !*****************************************************************************************
  6513. !*****************************************************************************************
  6514. !>
  6515. ! Convert a string into an integer.
  6516. !
  6517. !@note Replacement for the `parse_integer` function in the original code.
  6518. function string_to_int(json,str) result(ival)
  6519. implicit none
  6520. class(json_core),intent(inout) :: json
  6521. character(kind=CK,len=*),intent(in) :: str !! a string
  6522. integer(IK) :: ival !! `str` converted to an integer
  6523. logical(LK) :: status_ok !! error flag for [[string_to_integer]]
  6524. ! call the core routine:
  6525. call string_to_integer(str,ival,status_ok)
  6526. if (.not. status_ok) then
  6527. ival = 0
  6528. call json%throw_exception('Error in string_to_int: '//&
  6529. 'string cannot be converted to an integer: '//&
  6530. trim(str))
  6531. end if
  6532. end function string_to_int
  6533. !*****************************************************************************************
  6534. !*****************************************************************************************
  6535. !>
  6536. ! Convert a string into a `real(RK)` value.
  6537. function string_to_dble(json,str) result(rval)
  6538. implicit none
  6539. class(json_core),intent(inout) :: json
  6540. character(kind=CK,len=*),intent(in) :: str !! a string
  6541. real(RK) :: rval !! `str` converted to a `real(RK)`
  6542. logical(LK) :: status_ok !! error flag for [[string_to_real]]
  6543. call string_to_real(str,json%use_quiet_nan,rval,status_ok)
  6544. if (.not. status_ok) then !if there was an error
  6545. rval = 0.0_RK
  6546. call json%throw_exception('Error in string_to_dble: '//&
  6547. 'string cannot be converted to a real: '//&
  6548. trim(str))
  6549. end if
  6550. end function string_to_dble
  6551. !*****************************************************************************************
  6552. !*****************************************************************************************
  6553. !>
  6554. ! Get an integer value from a [[json_value]].
  6555. subroutine json_get_integer(json, me, value)
  6556. implicit none
  6557. class(json_core),intent(inout) :: json
  6558. type(json_value),pointer,intent(in) :: me
  6559. integer(IK),intent(out) :: value !! the integer value
  6560. logical(LK) :: status_ok !! for [[string_to_integer]]
  6561. value = 0_IK
  6562. if ( json%exception_thrown ) return
  6563. if (me%var_type == json_integer) then
  6564. value = me%int_value
  6565. else
  6566. if (json%strict_type_checking) then
  6567. if (allocated(me%name)) then
  6568. call json%throw_exception('Error in json_get_integer:'//&
  6569. ' Unable to resolve value to integer: '//me%name)
  6570. else
  6571. call json%throw_exception('Error in json_get_integer:'//&
  6572. ' Unable to resolve value to integer')
  6573. end if
  6574. else
  6575. !type conversions
  6576. select case(me%var_type)
  6577. case (json_real)
  6578. value = int(me%dbl_value, IK)
  6579. case (json_logical)
  6580. if (me%log_value) then
  6581. value = 1_IK
  6582. else
  6583. value = 0_IK
  6584. end if
  6585. case (json_string)
  6586. call string_to_integer(me%str_value,value,status_ok)
  6587. if (.not. status_ok) then
  6588. value = 0_IK
  6589. if (allocated(me%name)) then
  6590. call json%throw_exception('Error in json_get_integer:'//&
  6591. ' Unable to convert string value to integer: '//&
  6592. me%name//' = '//trim(me%str_value))
  6593. else
  6594. call json%throw_exception('Error in json_get_integer:'//&
  6595. ' Unable to convert string value to integer: '//&
  6596. trim(me%str_value))
  6597. end if
  6598. end if
  6599. case default
  6600. if (allocated(me%name)) then
  6601. call json%throw_exception('Error in json_get_integer:'//&
  6602. ' Unable to resolve value to integer: '//me%name)
  6603. else
  6604. call json%throw_exception('Error in json_get_integer:'//&
  6605. ' Unable to resolve value to integer')
  6606. end if
  6607. end select
  6608. end if
  6609. end if
  6610. end subroutine json_get_integer
  6611. !*****************************************************************************************
  6612. !*****************************************************************************************
  6613. !>
  6614. ! Get an integer value from a [[json_value]], given the path string.
  6615. subroutine json_get_integer_by_path(json, me, path, value, found, default)
  6616. implicit none
  6617. class(json_core),intent(inout) :: json
  6618. type(json_value),pointer,intent(in) :: me
  6619. character(kind=CK,len=*),intent(in) :: path
  6620. integer(IK),intent(out) :: value
  6621. logical(LK),intent(out),optional :: found
  6622. integer(IK),intent(in),optional :: default !! default value if not found
  6623. integer(IK),parameter :: default_if_not_specified = 0_IK
  6624. character(kind=CK,len=*),parameter :: routine = CK_'json_get_integer_by_path'
  6625. #include "json_get_scalar_by_path.inc"
  6626. end subroutine json_get_integer_by_path
  6627. !*****************************************************************************************
  6628. !*****************************************************************************************
  6629. !>
  6630. ! Alternate version of [[json_get_integer_by_path]], where "path" is kind=CDK.
  6631. subroutine wrap_json_get_integer_by_path(json, me, path, value, found, default)
  6632. implicit none
  6633. class(json_core),intent(inout) :: json
  6634. type(json_value),pointer,intent(in) :: me
  6635. character(kind=CDK,len=*),intent(in) :: path
  6636. integer(IK),intent(out) :: value
  6637. logical(LK),intent(out),optional :: found
  6638. integer(IK),intent(in),optional :: default !! default value if not found
  6639. call json%get(me, to_unicode(path), value, found, default)
  6640. end subroutine wrap_json_get_integer_by_path
  6641. !*****************************************************************************************
  6642. !*****************************************************************************************
  6643. !> author: Jacob Williams
  6644. ! date: 5/14/2014
  6645. !
  6646. ! Get an integer vector from a [[json_value]].
  6647. subroutine json_get_integer_vec(json, me, vec)
  6648. implicit none
  6649. class(json_core),intent(inout) :: json
  6650. type(json_value),pointer :: me
  6651. integer(IK),dimension(:),allocatable,intent(out) :: vec
  6652. logical(LK) :: initialized
  6653. if ( json%exception_thrown ) return
  6654. ! check for 0-length arrays first:
  6655. select case (me%var_type)
  6656. case (json_array)
  6657. if (json%count(me)==0) then
  6658. allocate(vec(0))
  6659. return
  6660. end if
  6661. end select
  6662. initialized = .false.
  6663. !the callback function is called for each element of the array:
  6664. call json%get(me, array_callback=get_int_from_array)
  6665. if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
  6666. contains
  6667. subroutine get_int_from_array(json, element, i, count)
  6668. !! callback function for integer
  6669. implicit none
  6670. class(json_core),intent(inout) :: json
  6671. type(json_value),pointer,intent(in) :: element
  6672. integer(IK),intent(in) :: i !! index
  6673. integer(IK),intent(in) :: count !! size of array
  6674. !size the output array:
  6675. if (.not. initialized) then
  6676. allocate(vec(count))
  6677. initialized = .true.
  6678. end if
  6679. !populate the elements:
  6680. call json%get(element, value=vec(i))
  6681. end subroutine get_int_from_array
  6682. end subroutine json_get_integer_vec
  6683. !*****************************************************************************************
  6684. !*****************************************************************************************
  6685. !>
  6686. ! If `found` is present, set it it false.
  6687. subroutine flag_not_found(found)
  6688. implicit none
  6689. logical(LK),intent(out),optional :: found
  6690. if (present(found)) found = .false.
  6691. end subroutine flag_not_found
  6692. !*****************************************************************************************
  6693. !*****************************************************************************************
  6694. !>
  6695. ! Get an integer vector from a [[json_value]], given the path string.
  6696. subroutine json_get_integer_vec_by_path(json, me, path, vec, found, default)
  6697. implicit none
  6698. class(json_core),intent(inout) :: json
  6699. type(json_value),pointer,intent(in) :: me
  6700. character(kind=CK,len=*),intent(in) :: path
  6701. integer(IK),dimension(:),allocatable,intent(out) :: vec
  6702. logical(LK),intent(out),optional :: found
  6703. integer(IK),dimension(:),intent(in),optional :: default !! default value if not found
  6704. character(kind=CK,len=*),parameter :: routine = CK_'json_get_integer_vec_by_path'
  6705. #include "json_get_vec_by_path.inc"
  6706. end subroutine json_get_integer_vec_by_path
  6707. !*****************************************************************************************
  6708. !*****************************************************************************************
  6709. !>
  6710. ! Alternate version of [[json_get_integer_vec_by_path]], where "path" is kind=CDK
  6711. subroutine wrap_json_get_integer_vec_by_path(json, me, path, vec, found, default)
  6712. implicit none
  6713. class(json_core),intent(inout) :: json
  6714. type(json_value),pointer :: me
  6715. character(kind=CDK,len=*),intent(in) :: path
  6716. integer(IK),dimension(:),allocatable,intent(out) :: vec
  6717. logical(LK),intent(out),optional :: found
  6718. integer(IK),dimension(:),intent(in),optional :: default !! default value if not found
  6719. call json%get(me,path=to_unicode(path),vec=vec,found=found,default=default)
  6720. end subroutine wrap_json_get_integer_vec_by_path
  6721. !*****************************************************************************************
  6722. !*****************************************************************************************
  6723. !>
  6724. ! Get a real value from a [[json_value]].
  6725. subroutine json_get_real(json, me, value)
  6726. implicit none
  6727. class(json_core),intent(inout) :: json
  6728. type(json_value),pointer :: me
  6729. real(RK),intent(out) :: value
  6730. logical(LK) :: status_ok !! for [[string_to_real]]
  6731. value = 0.0_RK
  6732. if ( json%exception_thrown ) return
  6733. if (me%var_type == json_real) then
  6734. value = me%dbl_value
  6735. else
  6736. if (json%strict_type_checking) then
  6737. if (allocated(me%name)) then
  6738. call json%throw_exception('Error in json_get_real:'//&
  6739. ' Unable to resolve value to real: '//me%name)
  6740. else
  6741. call json%throw_exception('Error in json_get_real:'//&
  6742. ' Unable to resolve value to real')
  6743. end if
  6744. else
  6745. !type conversions
  6746. select case (me%var_type)
  6747. case (json_integer)
  6748. value = real(me%int_value, RK)
  6749. case (json_logical)
  6750. if (me%log_value) then
  6751. value = 1.0_RK
  6752. else
  6753. value = 0.0_RK
  6754. end if
  6755. case (json_string)
  6756. call string_to_real(me%str_value,json%use_quiet_nan,value,status_ok)
  6757. if (.not. status_ok) then
  6758. value = 0.0_RK
  6759. if (allocated(me%name)) then
  6760. call json%throw_exception('Error in json_get_real:'//&
  6761. ' Unable to convert string value to real: '//&
  6762. me%name//' = '//trim(me%str_value))
  6763. else
  6764. call json%throw_exception('Error in json_get_real:'//&
  6765. ' Unable to convert string value to real: '//&
  6766. trim(me%str_value))
  6767. end if
  6768. end if
  6769. case (json_null)
  6770. if (ieee_support_nan(value) .and. json%null_to_real_mode/=1_IK) then
  6771. select case (json%null_to_real_mode)
  6772. case(2_IK)
  6773. if (json%use_quiet_nan) then
  6774. value = ieee_value(value,ieee_quiet_nan)
  6775. else
  6776. value = ieee_value(value,ieee_signaling_nan)
  6777. end if
  6778. case(3_IK)
  6779. value = 0.0_RK
  6780. end select
  6781. else
  6782. if (allocated(me%name)) then
  6783. call json%throw_exception('Error in json_get_real:'//&
  6784. ' Cannot convert null to NaN: '//me%name)
  6785. else
  6786. call json%throw_exception('Error in json_get_real:'//&
  6787. ' Cannot convert null to NaN')
  6788. end if
  6789. end if
  6790. case default
  6791. if (allocated(me%name)) then
  6792. call json%throw_exception('Error in json_get_real:'//&
  6793. ' Unable to resolve value to real: '//me%name)
  6794. else
  6795. call json%throw_exception('Error in json_get_real:'//&
  6796. ' Unable to resolve value to real')
  6797. end if
  6798. end select
  6799. end if
  6800. end if
  6801. end subroutine json_get_real
  6802. !*****************************************************************************************
  6803. !*****************************************************************************************
  6804. !>
  6805. ! Get a real value from a [[json_value]], given the path.
  6806. subroutine json_get_real_by_path(json, me, path, value, found, default)
  6807. implicit none
  6808. class(json_core),intent(inout) :: json
  6809. type(json_value),pointer :: me
  6810. character(kind=CK,len=*),intent(in) :: path
  6811. real(RK),intent(out) :: value
  6812. logical(LK),intent(out),optional :: found
  6813. real(RK),intent(in),optional :: default !! default value if not found
  6814. real(RK),parameter :: default_if_not_specified = 0.0_RK
  6815. character(kind=CK,len=*),parameter :: routine = CK_'json_get_real_by_path'
  6816. #include "json_get_scalar_by_path.inc"
  6817. end subroutine json_get_real_by_path
  6818. !*****************************************************************************************
  6819. !*****************************************************************************************
  6820. !>
  6821. ! Alternate version of [[json_get_real_by_path]], where "path" is kind=CDK
  6822. subroutine wrap_json_get_real_by_path(json, me, path, value, found, default)
  6823. implicit none
  6824. class(json_core),intent(inout) :: json
  6825. type(json_value),pointer :: me
  6826. character(kind=CDK,len=*),intent(in) :: path
  6827. real(RK),intent(out) :: value
  6828. logical(LK),intent(out),optional :: found
  6829. real(RK),intent(in),optional :: default !! default value if not found
  6830. call json%get(me,to_unicode(path),value,found,default)
  6831. end subroutine wrap_json_get_real_by_path
  6832. !*****************************************************************************************
  6833. !*****************************************************************************************
  6834. !> author: Jacob Williams
  6835. ! date: 5/14/2014
  6836. !
  6837. ! Get a real vector from a [[json_value]].
  6838. subroutine json_get_real_vec(json, me, vec)
  6839. implicit none
  6840. class(json_core),intent(inout) :: json
  6841. type(json_value),pointer :: me
  6842. real(RK),dimension(:),allocatable,intent(out) :: vec
  6843. logical(LK) :: initialized
  6844. if ( json%exception_thrown ) return
  6845. ! check for 0-length arrays first:
  6846. select case (me%var_type)
  6847. case (json_array)
  6848. if (json%count(me)==0) then
  6849. allocate(vec(0))
  6850. return
  6851. end if
  6852. end select
  6853. initialized = .false.
  6854. !the callback function is called for each element of the array:
  6855. call json%get(me, array_callback=get_real_from_array)
  6856. if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
  6857. contains
  6858. subroutine get_real_from_array(json, element, i, count)
  6859. !! callback function for real
  6860. implicit none
  6861. class(json_core),intent(inout) :: json
  6862. type(json_value),pointer,intent(in) :: element
  6863. integer(IK),intent(in) :: i !! index
  6864. integer(IK),intent(in) :: count !! size of array
  6865. !size the output array:
  6866. if (.not. initialized) then
  6867. allocate(vec(count))
  6868. initialized = .true.
  6869. end if
  6870. !populate the elements:
  6871. call json%get(element, value=vec(i))
  6872. end subroutine get_real_from_array
  6873. end subroutine json_get_real_vec
  6874. !*****************************************************************************************
  6875. !*****************************************************************************************
  6876. !>
  6877. ! Get a real vector from a [[json_value]], given the path.
  6878. subroutine json_get_real_vec_by_path(json, me, path, vec, found, default)
  6879. implicit none
  6880. class(json_core),intent(inout) :: json
  6881. type(json_value),pointer,intent(in) :: me
  6882. character(kind=CK,len=*),intent(in) :: path
  6883. real(RK),dimension(:),allocatable,intent(out) :: vec
  6884. logical(LK),intent(out),optional :: found
  6885. real(RK),dimension(:),intent(in),optional :: default !! default value if not found
  6886. character(kind=CK,len=*),parameter :: routine = CK_'json_get_real_vec_by_path'
  6887. #include "json_get_vec_by_path.inc"
  6888. end subroutine json_get_real_vec_by_path
  6889. !*****************************************************************************************
  6890. !*****************************************************************************************
  6891. !>
  6892. ! Alternate version of [[json_get_real_vec_by_path]], where "path" is kind=CDK
  6893. subroutine wrap_json_get_real_vec_by_path(json, me, path, vec, found, default)
  6894. implicit none
  6895. class(json_core),intent(inout) :: json
  6896. type(json_value),pointer :: me
  6897. character(kind=CDK,len=*),intent(in) :: path
  6898. real(RK),dimension(:),allocatable,intent(out) :: vec
  6899. logical(LK),intent(out),optional :: found
  6900. real(RK),dimension(:),intent(in),optional :: default !! default value if not found
  6901. call json%get(me, to_unicode(path), vec, found, default)
  6902. end subroutine wrap_json_get_real_vec_by_path
  6903. !*****************************************************************************************
  6904. #ifndef REAL32
  6905. !*****************************************************************************************
  6906. !>
  6907. ! Alternate version of [[json_get_real]] where value=real32.
  6908. subroutine json_get_real32(json, me, value)
  6909. implicit none
  6910. class(json_core),intent(inout) :: json
  6911. type(json_value),pointer :: me
  6912. real(real32),intent(out) :: value
  6913. real(RK) :: tmp
  6914. call json%get(me, tmp)
  6915. value = real(tmp,real32)
  6916. end subroutine json_get_real32
  6917. !*****************************************************************************************
  6918. !*****************************************************************************************
  6919. !>
  6920. ! Alternate version of [[json_get_real_by_path]] where value=real32.
  6921. subroutine json_get_real32_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=CK,len=*),intent(in) :: path
  6926. real(real32),intent(out) :: value
  6927. logical(LK),intent(out),optional :: found
  6928. real(real32),intent(in),optional :: default !! default value if not found
  6929. real(RK) :: tmp
  6930. real(RK) :: tmp_default
  6931. if (present(default)) then
  6932. tmp_default = real(default,RK)
  6933. call json%get(me, path, tmp, found, tmp_default)
  6934. else
  6935. call json%get(me, path, tmp, found)
  6936. end if
  6937. value = real(tmp,real32)
  6938. end subroutine json_get_real32_by_path
  6939. !*****************************************************************************************
  6940. !*****************************************************************************************
  6941. !>
  6942. ! Alternate version of [[json_get_real32_by_path]], where "path" is kind=CDK
  6943. subroutine wrap_json_get_real32_by_path(json, me, path, value, found, default)
  6944. implicit none
  6945. class(json_core),intent(inout) :: json
  6946. type(json_value),pointer :: me
  6947. character(kind=CDK,len=*),intent(in) :: path
  6948. real(real32),intent(out) :: value
  6949. logical(LK),intent(out),optional :: found
  6950. real(real32),intent(in),optional :: default !! default value if not found
  6951. call json%get(me,to_unicode(path),value,found,default)
  6952. end subroutine wrap_json_get_real32_by_path
  6953. !*****************************************************************************************
  6954. !*****************************************************************************************
  6955. !>
  6956. ! Alternate version of [[json_get_real_vec]] where `vec` is `real32`.
  6957. subroutine json_get_real32_vec(json, me, vec)
  6958. implicit none
  6959. class(json_core),intent(inout) :: json
  6960. type(json_value),pointer :: me
  6961. real(real32),dimension(:),allocatable,intent(out) :: vec
  6962. real(RK),dimension(:),allocatable :: tmp
  6963. call json%get(me, tmp)
  6964. if (allocated(tmp)) vec = real(tmp,real32)
  6965. end subroutine json_get_real32_vec
  6966. !*****************************************************************************************
  6967. !*****************************************************************************************
  6968. !>
  6969. ! Alternate version of [[json_get_real_vec_by_path]] where `vec` is `real32`.
  6970. subroutine json_get_real32_vec_by_path(json, me, path, vec, found, default)
  6971. implicit none
  6972. class(json_core),intent(inout) :: json
  6973. type(json_value),pointer,intent(in) :: me
  6974. character(kind=CK,len=*),intent(in) :: path
  6975. real(real32),dimension(:),allocatable,intent(out) :: vec
  6976. logical(LK),intent(out),optional :: found
  6977. real(real32),dimension(:),intent(in),optional :: default !! default value if not found
  6978. real(RK),dimension(:),allocatable :: tmp
  6979. real(RK),dimension(:),allocatable :: tmp_default
  6980. if (present(default)) then
  6981. tmp_default = real(default,RK)
  6982. call json%get(me, path, tmp, found, tmp_default)
  6983. else
  6984. call json%get(me, path, tmp, found)
  6985. end if
  6986. if (allocated(tmp)) vec = real(tmp,real32)
  6987. end subroutine json_get_real32_vec_by_path
  6988. !*****************************************************************************************
  6989. !*****************************************************************************************
  6990. !>
  6991. ! Alternate version of [[json_get_real32_vec_by_path]], where "path" is kind=CDK
  6992. subroutine wrap_json_get_real32_vec_by_path(json, me, path, vec, found, default)
  6993. implicit none
  6994. class(json_core),intent(inout) :: json
  6995. type(json_value),pointer :: me
  6996. character(kind=CDK,len=*),intent(in) :: path
  6997. real(real32),dimension(:),allocatable,intent(out) :: vec
  6998. logical(LK),intent(out),optional :: found
  6999. real(real32),dimension(:),intent(in),optional :: default !! default value if not found
  7000. call json%get(me, to_unicode(path), vec, found, default)
  7001. end subroutine wrap_json_get_real32_vec_by_path
  7002. !*****************************************************************************************
  7003. #endif
  7004. #ifdef REAL128
  7005. !*****************************************************************************************
  7006. !>
  7007. ! Alternate version of [[json_get_real]] where `value` is `real64`.
  7008. subroutine json_get_real64(json, me, value)
  7009. implicit none
  7010. class(json_core),intent(inout) :: json
  7011. type(json_value),pointer :: me
  7012. real(real64),intent(out) :: value
  7013. real(RK) :: tmp
  7014. call json%get(me, tmp)
  7015. value = real(tmp,real64)
  7016. end subroutine json_get_real64
  7017. !*****************************************************************************************
  7018. !*****************************************************************************************
  7019. !>
  7020. ! Alternate version of [[json_get_real_by_path]] where `value` is `real64`.
  7021. subroutine json_get_real64_by_path(json, me, path, value, found, default)
  7022. implicit none
  7023. class(json_core),intent(inout) :: json
  7024. type(json_value),pointer :: me
  7025. character(kind=CK,len=*),intent(in) :: path
  7026. real(real64),intent(out) :: value
  7027. logical(LK),intent(out),optional :: found
  7028. real(real64),intent(in),optional :: default !! default value if not found
  7029. real(RK) :: tmp
  7030. call json%get(me, path, tmp, found, default)
  7031. value = real(tmp,real64)
  7032. end subroutine json_get_real64_by_path
  7033. !*****************************************************************************************
  7034. !*****************************************************************************************
  7035. !>
  7036. ! Alternate version of [[json_get_real64_by_path]], where "path" is kind=CDK
  7037. subroutine wrap_json_get_real64_by_path(json, me, path, value, found, default)
  7038. implicit none
  7039. class(json_core),intent(inout) :: json
  7040. type(json_value),pointer :: me
  7041. character(kind=CDK,len=*),intent(in) :: path
  7042. real(real64),intent(out) :: value
  7043. logical(LK),intent(out),optional :: found
  7044. real(real64),intent(in),optional :: default !! default value if not found
  7045. call json%get(me,to_unicode(path),value,found, default)
  7046. end subroutine wrap_json_get_real64_by_path
  7047. !*****************************************************************************************
  7048. !*****************************************************************************************
  7049. !>
  7050. ! Alternate version of [[json_get_real_vec]] where `vec` is `real64`.
  7051. subroutine json_get_real64_vec(json, me, vec)
  7052. implicit none
  7053. class(json_core),intent(inout) :: json
  7054. type(json_value),pointer :: me
  7055. real(real64),dimension(:),allocatable,intent(out) :: vec
  7056. real(RK),dimension(:),allocatable :: tmp
  7057. call json%get(me, tmp)
  7058. if (allocated(tmp)) vec = real(tmp,real64)
  7059. end subroutine json_get_real64_vec
  7060. !*****************************************************************************************
  7061. !*****************************************************************************************
  7062. !>
  7063. ! Alternate version of [[json_get_real_vec_by_path]] where `vec` is `real64`.
  7064. subroutine json_get_real64_vec_by_path(json, me, path, vec, found, default)
  7065. implicit none
  7066. class(json_core),intent(inout) :: json
  7067. type(json_value),pointer,intent(in) :: me
  7068. character(kind=CK,len=*),intent(in) :: path
  7069. real(real64),dimension(:),allocatable,intent(out) :: vec
  7070. logical(LK),intent(out),optional :: found
  7071. real(real64),dimension(:),intent(in),optional :: default !! default value if not found
  7072. real(RK),dimension(:),allocatable :: tmp
  7073. call json%get(me, path, tmp, found, default)
  7074. if (allocated(tmp)) vec = real(tmp,real64)
  7075. end subroutine json_get_real64_vec_by_path
  7076. !*****************************************************************************************
  7077. !*****************************************************************************************
  7078. !>
  7079. ! Alternate version of [[json_get_real64_vec_by_path]], where "path" is kind=CDK
  7080. subroutine wrap_json_get_real64_vec_by_path(json, me, path, vec, found, default)
  7081. implicit none
  7082. class(json_core),intent(inout) :: json
  7083. type(json_value),pointer :: me
  7084. character(kind=CDK,len=*),intent(in) :: path
  7085. real(real64),dimension(:),allocatable,intent(out) :: vec
  7086. logical(LK),intent(out),optional :: found
  7087. real(real64),dimension(:),intent(in),optional :: default !! default value if not found
  7088. call json%get(me, to_unicode(path), vec, found, default)
  7089. end subroutine wrap_json_get_real64_vec_by_path
  7090. !*****************************************************************************************
  7091. #endif
  7092. !*****************************************************************************************
  7093. !>
  7094. ! Get a logical value from a [[json_value]].
  7095. !
  7096. !### Note
  7097. ! If `strict_type_checking` is False, then the following assumptions are made:
  7098. !
  7099. ! * For integers: a value > 0 is True
  7100. ! * For reals: a value > 0 is True
  7101. ! * For strings: 'true' is True, and everything else is false. [case sensitive match]
  7102. subroutine json_get_logical(json, me, value)
  7103. implicit none
  7104. class(json_core),intent(inout) :: json
  7105. type(json_value),pointer,intent(in) :: me
  7106. logical(LK),intent(out) :: value
  7107. value = .false.
  7108. if ( json%exception_thrown ) return
  7109. if (me%var_type == json_logical) then
  7110. value = me%log_value
  7111. else
  7112. if (json%strict_type_checking) then
  7113. if (allocated(me%name)) then
  7114. call json%throw_exception('Error in json_get_logical: '//&
  7115. 'Unable to resolve value to logical: '//&
  7116. me%name)
  7117. else
  7118. call json%throw_exception('Error in json_get_logical: '//&
  7119. 'Unable to resolve value to logical')
  7120. end if
  7121. else
  7122. !type conversions
  7123. select case (me%var_type)
  7124. case (json_integer)
  7125. value = (me%int_value > 0_IK)
  7126. case (json_real)
  7127. value = (me%dbl_value > 0.0_RK)
  7128. case (json_string)
  7129. value = (me%str_value == true_str)
  7130. case default
  7131. if (allocated(me%name)) then
  7132. call json%throw_exception('Error in json_get_logical: '//&
  7133. 'Unable to resolve value to logical: '//&
  7134. me%name)
  7135. else
  7136. call json%throw_exception('Error in json_get_logical: '//&
  7137. 'Unable to resolve value to logical')
  7138. end if
  7139. end select
  7140. end if
  7141. end if
  7142. end subroutine json_get_logical
  7143. !*****************************************************************************************
  7144. !*****************************************************************************************
  7145. !>
  7146. ! Get a logical value from a [[json_value]], given the path.
  7147. subroutine json_get_logical_by_path(json, me, path, value, found, default)
  7148. implicit none
  7149. class(json_core),intent(inout) :: json
  7150. type(json_value),pointer,intent(in) :: me
  7151. character(kind=CK,len=*),intent(in) :: path
  7152. logical(LK),intent(out) :: value
  7153. logical(LK),intent(out),optional :: found
  7154. logical(LK),intent(in),optional :: default !! default value if not found
  7155. logical(LK),parameter :: default_if_not_specified = .false.
  7156. character(kind=CK,len=*),parameter :: routine = CK_'json_get_logical_by_path'
  7157. #include "json_get_scalar_by_path.inc"
  7158. end subroutine json_get_logical_by_path
  7159. !*****************************************************************************************
  7160. !*****************************************************************************************
  7161. !>
  7162. ! Alternate version of [[json_get_logical_by_path]], where "path" is kind=CDK
  7163. subroutine wrap_json_get_logical_by_path(json, me, path, value, found, default)
  7164. implicit none
  7165. class(json_core),intent(inout) :: json
  7166. type(json_value),pointer,intent(in) :: me
  7167. character(kind=CDK,len=*),intent(in) :: path
  7168. logical(LK),intent(out) :: value
  7169. logical(LK),intent(out),optional :: found
  7170. logical(LK),intent(in),optional :: default !! default value if not found
  7171. call json%get(me,to_unicode(path),value,found,default)
  7172. end subroutine wrap_json_get_logical_by_path
  7173. !*****************************************************************************************
  7174. !*****************************************************************************************
  7175. !> author: Jacob Williams
  7176. ! date: 5/14/2014
  7177. !
  7178. ! Get a logical vector from [[json_value]].
  7179. subroutine json_get_logical_vec(json, me, vec)
  7180. implicit none
  7181. class(json_core),intent(inout) :: json
  7182. type(json_value),pointer,intent(in) :: me
  7183. logical(LK),dimension(:),allocatable,intent(out) :: vec
  7184. logical(LK) :: initialized
  7185. if ( json%exception_thrown ) return
  7186. ! check for 0-length arrays first:
  7187. select case (me%var_type)
  7188. case (json_array)
  7189. if (json%count(me)==0) then
  7190. allocate(vec(0))
  7191. return
  7192. end if
  7193. end select
  7194. initialized = .false.
  7195. !the callback function is called for each element of the array:
  7196. call json%get(me, array_callback=get_logical_from_array)
  7197. if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
  7198. contains
  7199. subroutine get_logical_from_array(json, element, i, count)
  7200. !! callback function for logical
  7201. implicit none
  7202. class(json_core),intent(inout) :: json
  7203. type(json_value),pointer,intent(in) :: element
  7204. integer(IK),intent(in) :: i !! index
  7205. integer(IK),intent(in) :: count !! size of array
  7206. !size the output array:
  7207. if (.not. initialized) then
  7208. allocate(vec(count))
  7209. initialized = .true.
  7210. end if
  7211. !populate the elements:
  7212. call json%get(element, value=vec(i))
  7213. end subroutine get_logical_from_array
  7214. end subroutine json_get_logical_vec
  7215. !*****************************************************************************************
  7216. !*****************************************************************************************
  7217. !>
  7218. ! Get a logical vector from a [[json_value]], given the path.
  7219. subroutine json_get_logical_vec_by_path(json, me, path, vec, found, default)
  7220. implicit none
  7221. class(json_core),intent(inout) :: json
  7222. type(json_value),pointer,intent(in) :: me
  7223. character(kind=CK,len=*),intent(in) :: path
  7224. logical(LK),dimension(:),allocatable,intent(out) :: vec
  7225. logical(LK),intent(out),optional :: found
  7226. logical(LK),dimension(:),intent(in),optional :: default
  7227. character(kind=CK,len=*),parameter :: routine = CK_'json_get_logical_vec_by_path'
  7228. #include "json_get_vec_by_path.inc"
  7229. end subroutine json_get_logical_vec_by_path
  7230. !*****************************************************************************************
  7231. !*****************************************************************************************
  7232. !>
  7233. ! Alternate version of [[json_get_logical_vec_by_path]], where "path" is kind=CDK
  7234. subroutine wrap_json_get_logical_vec_by_path(json, me, path, vec, found, default)
  7235. implicit none
  7236. class(json_core),intent(inout) :: json
  7237. type(json_value),pointer,intent(in) :: me
  7238. character(kind=CDK,len=*),intent(in) :: path
  7239. logical(LK),dimension(:),allocatable,intent(out) :: vec
  7240. logical(LK),intent(out),optional :: found
  7241. logical(LK),dimension(:),intent(in),optional :: default
  7242. call json%get(me,to_unicode(path),vec,found,default)
  7243. end subroutine wrap_json_get_logical_vec_by_path
  7244. !*****************************************************************************************
  7245. !*****************************************************************************************
  7246. !>
  7247. ! Get a character string from a [[json_value]].
  7248. subroutine json_get_string(json, me, value)
  7249. implicit none
  7250. class(json_core),intent(inout) :: json
  7251. type(json_value),pointer,intent(in) :: me
  7252. character(kind=CK,len=:),allocatable,intent(out) :: value
  7253. value = CK_''
  7254. if (.not. json%exception_thrown) then
  7255. if (me%var_type == json_string) then
  7256. if (allocated(me%str_value)) then
  7257. if (json%unescaped_strings) then
  7258. ! default: it is stored already unescaped:
  7259. value = me%str_value
  7260. else
  7261. ! return the escaped version:
  7262. call escape_string(me%str_value, value, json%escape_solidus)
  7263. end if
  7264. else
  7265. call json%throw_exception('Error in json_get_string: '//&
  7266. 'me%str_value not allocated')
  7267. end if
  7268. else
  7269. if (json%strict_type_checking) then
  7270. if (allocated(me%name)) then
  7271. call json%throw_exception('Error in json_get_string:'//&
  7272. ' Unable to resolve value to string: '//me%name)
  7273. else
  7274. call json%throw_exception('Error in json_get_string:'//&
  7275. ' Unable to resolve value to string')
  7276. end if
  7277. else
  7278. select case (me%var_type)
  7279. case (json_integer)
  7280. if (allocated(me%int_value)) then
  7281. value = repeat(space, max_integer_str_len)
  7282. call integer_to_string(me%int_value,int_fmt,value)
  7283. value = trim(value)
  7284. else
  7285. call json%throw_exception('Error in json_get_string: '//&
  7286. 'me%int_value not allocated')
  7287. end if
  7288. case (json_real)
  7289. if (allocated(me%dbl_value)) then
  7290. value = repeat(space, max_numeric_str_len)
  7291. call real_to_string(me%dbl_value,json%real_fmt,&
  7292. json%non_normals_to_null,&
  7293. json%compact_real,value)
  7294. value = trim(value)
  7295. else
  7296. call json%throw_exception('Error in json_get_string: '//&
  7297. 'me%int_value not allocated')
  7298. end if
  7299. case (json_logical)
  7300. if (allocated(me%log_value)) then
  7301. if (me%log_value) then
  7302. value = true_str
  7303. else
  7304. value = false_str
  7305. end if
  7306. else
  7307. call json%throw_exception('Error in json_get_string: '//&
  7308. 'me%log_value not allocated')
  7309. end if
  7310. case (json_null)
  7311. value = null_str
  7312. case default
  7313. if (allocated(me%name)) then
  7314. call json%throw_exception('Error in json_get_string: '//&
  7315. 'Unable to resolve value to characters: '//&
  7316. me%name)
  7317. else
  7318. call json%throw_exception('Error in json_get_string: '//&
  7319. 'Unable to resolve value to characters')
  7320. end if
  7321. end select
  7322. end if
  7323. end if
  7324. end if
  7325. end subroutine json_get_string
  7326. !*****************************************************************************************
  7327. !*****************************************************************************************
  7328. !>
  7329. ! Get a character string from a [[json_value]], given the path.
  7330. subroutine json_get_string_by_path(json, me, path, value, found, default)
  7331. implicit none
  7332. class(json_core),intent(inout) :: json
  7333. type(json_value),pointer,intent(in) :: me
  7334. character(kind=CK,len=*),intent(in) :: path
  7335. character(kind=CK,len=:),allocatable,intent(out) :: value
  7336. logical(LK),intent(out),optional :: found
  7337. character(kind=CK,len=*),intent(in),optional :: default
  7338. character(kind=CK,len=*),parameter :: default_if_not_specified = CK_''
  7339. character(kind=CK,len=*),parameter :: routine = CK_'json_get_string_by_path'
  7340. #include "json_get_scalar_by_path.inc"
  7341. end subroutine json_get_string_by_path
  7342. !*****************************************************************************************
  7343. !*****************************************************************************************
  7344. !>
  7345. ! Alternate version of [[json_get_string_by_path]], where "path" is kind=CDK
  7346. subroutine wrap_json_get_string_by_path(json, me, path, value, found, default)
  7347. implicit none
  7348. class(json_core),intent(inout) :: json
  7349. type(json_value),pointer,intent(in) :: me
  7350. character(kind=CDK,len=*),intent(in) :: path
  7351. character(kind=CK,len=:),allocatable,intent(out) :: value
  7352. logical(LK),intent(out),optional :: found
  7353. character(kind=CK,len=*),intent(in),optional :: default
  7354. call json%get(me,to_unicode(path),value,found,default)
  7355. end subroutine wrap_json_get_string_by_path
  7356. !*****************************************************************************************
  7357. !*****************************************************************************************
  7358. !> author: Jacob Williams
  7359. ! date: 5/14/2014
  7360. !
  7361. ! Get a string vector from a [[json_value(type)]].
  7362. subroutine json_get_string_vec(json, me, vec)
  7363. implicit none
  7364. class(json_core),intent(inout) :: json
  7365. type(json_value),pointer,intent(in) :: me
  7366. character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
  7367. logical(LK) :: initialized
  7368. if ( json%exception_thrown ) return
  7369. ! check for 0-length arrays first:
  7370. select case (me%var_type)
  7371. case (json_array)
  7372. if (json%count(me)==0) then
  7373. allocate(vec(0))
  7374. return
  7375. end if
  7376. end select
  7377. initialized = .false.
  7378. !the callback function is called for each element of the array:
  7379. call json%get(me, array_callback=get_chars_from_array)
  7380. if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
  7381. contains
  7382. subroutine get_chars_from_array(json, element, i, count)
  7383. !! callback function for chars
  7384. implicit none
  7385. class(json_core),intent(inout) :: json
  7386. type(json_value),pointer,intent(in) :: element
  7387. integer(IK),intent(in) :: i !! index
  7388. integer(IK),intent(in) :: count !! size of array
  7389. character(kind=CK,len=:),allocatable :: cval
  7390. !size the output array:
  7391. if (.not. initialized) then
  7392. allocate(vec(count))
  7393. initialized = .true.
  7394. end if
  7395. !populate the elements:
  7396. call json%get(element, value=cval)
  7397. if (allocated(cval)) then
  7398. vec(i) = cval
  7399. deallocate(cval)
  7400. else
  7401. vec(i) = CK_''
  7402. end if
  7403. end subroutine get_chars_from_array
  7404. end subroutine json_get_string_vec
  7405. !*****************************************************************************************
  7406. !*****************************************************************************************
  7407. !>
  7408. ! Get a string vector from a [[json_value(type)]], given the path.
  7409. subroutine json_get_string_vec_by_path(json, me, path, vec, found, default)
  7410. implicit none
  7411. class(json_core),intent(inout) :: json
  7412. type(json_value),pointer,intent(in) :: me
  7413. character(kind=CK,len=*),intent(in) :: path
  7414. character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
  7415. logical(LK),intent(out),optional :: found
  7416. character(kind=CK,len=*),dimension(:),intent(in),optional :: default
  7417. character(kind=CK,len=*),parameter :: routine = CK_'json_get_string_vec_by_path'
  7418. #include "json_get_vec_by_path.inc"
  7419. end subroutine json_get_string_vec_by_path
  7420. !*****************************************************************************************
  7421. !*****************************************************************************************
  7422. !>
  7423. ! Alternate version of [[json_get_string_vec_by_path]], where "path" is kind=CDK
  7424. subroutine wrap_json_get_string_vec_by_path(json, me, path, vec, found, default)
  7425. implicit none
  7426. class(json_core),intent(inout) :: json
  7427. type(json_value),pointer,intent(in) :: me
  7428. character(kind=CDK,len=*),intent(in) :: path
  7429. character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
  7430. logical(LK),intent(out),optional :: found
  7431. character(kind=CK,len=*),dimension(:),intent(in),optional :: default
  7432. call json%get(me,to_unicode(path),vec,found,default)
  7433. end subroutine wrap_json_get_string_vec_by_path
  7434. !*****************************************************************************************
  7435. !*****************************************************************************************
  7436. !> author: Jacob Williams
  7437. ! date: 12/16/2016
  7438. !
  7439. ! Get a string vector from a [[json_value(type)]]. This is an alternate
  7440. ! version of [[json_get_string_vec]]. This one returns an allocatable
  7441. ! length character (where the string length is the maximum length of
  7442. ! any element in the array). It also returns an integer array of the
  7443. ! actual sizes of the strings in the JSON structure.
  7444. !
  7445. !@note This is somewhat inefficient since it does
  7446. ! cycle through the array twice.
  7447. !
  7448. !@warning The allocation of `vec` doesn't work with
  7449. ! gfortran 4.9 or 5 due to compiler bugs
  7450. subroutine json_get_alloc_string_vec(json, me, vec, ilen)
  7451. implicit none
  7452. class(json_core),intent(inout) :: json
  7453. type(json_value),pointer,intent(in) :: me
  7454. character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
  7455. integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
  7456. !! of each character
  7457. !! string in the array
  7458. logical(LK) :: initialized !! if the output array has been sized
  7459. integer(IK) :: max_len !! the length of the longest string in the array
  7460. if ( json%exception_thrown ) return
  7461. ! check for 0-length arrays first:
  7462. select case (me%var_type)
  7463. case (json_array)
  7464. if (json%count(me)==0) then
  7465. allocate(character(kind=CK,len=0) :: vec(0))
  7466. allocate(ilen(0))
  7467. return
  7468. end if
  7469. end select
  7470. initialized = .false.
  7471. call json%string_info(me,ilen=ilen,max_str_len=max_len)
  7472. if (.not. json%exception_thrown) then
  7473. ! now get each string using the callback function:
  7474. call json%get(me, array_callback=get_chars_from_array)
  7475. end if
  7476. if (json%exception_thrown) then
  7477. if (allocated(vec)) deallocate(vec)
  7478. if (allocated(ilen)) deallocate(ilen)
  7479. end if
  7480. contains
  7481. subroutine get_chars_from_array(json, element, i, count)
  7482. !! callback function for chars
  7483. implicit none
  7484. class(json_core),intent(inout) :: json
  7485. type(json_value),pointer,intent(in) :: element
  7486. integer(IK),intent(in) :: i !! index
  7487. integer(IK),intent(in) :: count !! size of array
  7488. character(kind=CK,len=:),allocatable :: cval !! for getting string
  7489. !size the output array:
  7490. if (.not. initialized) then
  7491. ! string length long enough to hold the longest one
  7492. ! Note that this doesn't work with gfortran 4.9 or 5.
  7493. allocate( character(kind=CK,len=max_len) :: vec(count) )
  7494. initialized = .true.
  7495. end if
  7496. !populate the elements:
  7497. call json%get(element, value=cval)
  7498. if (allocated(cval)) then
  7499. vec(i) = cval
  7500. ilen(i) = len(cval) ! return the actual length
  7501. deallocate(cval)
  7502. else
  7503. vec(i) = CK_''
  7504. ilen(i) = 0
  7505. end if
  7506. end subroutine get_chars_from_array
  7507. end subroutine json_get_alloc_string_vec
  7508. !*****************************************************************************************
  7509. !*****************************************************************************************
  7510. !>
  7511. ! Alternate version of [[json_get_alloc_string_vec]] where input is the path.
  7512. !
  7513. ! This is an alternate version of [[json_get_string_vec_by_path]].
  7514. ! This one returns an allocatable length character (where the string
  7515. ! length is the maximum length of any element in the array). It also
  7516. ! returns an integer array of the actual sizes of the strings in the
  7517. ! JSON structure.
  7518. !
  7519. !@note An alternative to using this routine is to use [[json_get_array]] with
  7520. ! a callback function that gets the string from each element and populates
  7521. ! a user-defined string type.
  7522. !
  7523. !@note If the `default` argument is used, and `default_ilen` is not present,
  7524. ! then `ilen` will just be returned as the length of the `default` dummy
  7525. ! argument (all elements with the same length).
  7526. subroutine json_get_alloc_string_vec_by_path(json,me,path,vec,ilen,found,default,default_ilen)
  7527. implicit none
  7528. class(json_core),intent(inout) :: json
  7529. type(json_value),pointer,intent(in) :: me
  7530. character(kind=CK,len=*),intent(in) :: path
  7531. character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
  7532. integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
  7533. !! of each character
  7534. !! string in the array
  7535. logical(LK),intent(out),optional :: found
  7536. character(kind=CK,len=*),dimension(:),intent(in),optional :: default
  7537. integer(IK),dimension(:),intent(in),optional :: default_ilen !! the actual
  7538. !! length of `default`
  7539. character(kind=CK,len=*),parameter :: routine = CK_'json_get_alloc_string_vec_by_path'
  7540. #include "json_get_vec_by_path_alloc.inc"
  7541. end subroutine json_get_alloc_string_vec_by_path
  7542. !*****************************************************************************************
  7543. !*****************************************************************************************
  7544. !>
  7545. ! Alternate version of [[json_get_alloc_string_vec_by_path]], where "path" is kind=CDK
  7546. subroutine wrap_json_get_alloc_string_vec_by_path(json,me,path,vec,ilen,found,default,default_ilen)
  7547. implicit none
  7548. class(json_core),intent(inout) :: json
  7549. type(json_value),pointer,intent(in) :: me
  7550. character(kind=CDK,len=*),intent(in) :: path
  7551. character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
  7552. integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
  7553. !! of each character
  7554. !! string in the array
  7555. logical(LK),intent(out),optional :: found
  7556. character(kind=CK,len=*),dimension(:),intent(in),optional :: default
  7557. integer(IK),dimension(:),intent(in),optional :: default_ilen !! the actual
  7558. !! length of `default`
  7559. call json%get(me,to_unicode(path),vec,ilen,found,default,default_ilen)
  7560. end subroutine wrap_json_get_alloc_string_vec_by_path
  7561. !*****************************************************************************************
  7562. !*****************************************************************************************
  7563. !>
  7564. ! This routine calls the user-supplied [[json_array_callback_func]]
  7565. ! subroutine for each element in the array.
  7566. !
  7567. !@note For integer, real, logical, and character arrays,
  7568. ! higher-level routines are provided (see `get` methods), so
  7569. ! this routine does not have to be used for those cases.
  7570. recursive subroutine json_get_array(json, me, array_callback)
  7571. implicit none
  7572. class(json_core),intent(inout) :: json
  7573. type(json_value),pointer,intent(in) :: me
  7574. procedure(json_array_callback_func) :: array_callback
  7575. type(json_value),pointer :: element !! temp variable for getting elements
  7576. integer(IK) :: i !! counter
  7577. integer(IK) :: count !! number of elements in the array
  7578. if ( json%exception_thrown ) return
  7579. select case (me%var_type)
  7580. case (json_array)
  7581. count = json%count(me)
  7582. element => me%children
  7583. do i = 1, count ! callback for each child
  7584. if (.not. associated(element)) then
  7585. call json%throw_exception('Error in json_get_array: '//&
  7586. 'Malformed JSON linked list')
  7587. return
  7588. end if
  7589. call array_callback(json, element, i, count)
  7590. if (json%exception_thrown) exit
  7591. element => element%next
  7592. end do
  7593. case default
  7594. call json%throw_exception('Error in json_get_array:'//&
  7595. ' Resolved value is not an array ')
  7596. end select
  7597. end subroutine json_get_array
  7598. !*****************************************************************************************
  7599. !*****************************************************************************************
  7600. !> author: Jacob Williams
  7601. ! date: 4/28/2016
  7602. !
  7603. ! Traverse a JSON structure.
  7604. ! This routine calls the user-specified [[json_traverse_callback_func]]
  7605. ! for each element of the structure.
  7606. subroutine json_traverse(json,p,traverse_callback)
  7607. implicit none
  7608. class(json_core),intent(inout) :: json
  7609. type(json_value),pointer,intent(in) :: p
  7610. procedure(json_traverse_callback_func) :: traverse_callback
  7611. logical(LK) :: finished !! can be used to stop the process
  7612. if (.not. json%exception_thrown) call traverse(p)
  7613. contains
  7614. recursive subroutine traverse(p)
  7615. !! recursive [[json_value]] traversal.
  7616. implicit none
  7617. type(json_value),pointer,intent(in) :: p
  7618. type(json_value),pointer :: element !! a child element
  7619. integer(IK) :: i !! counter
  7620. integer(IK) :: icount !! number of children
  7621. if (json%exception_thrown) return
  7622. call traverse_callback(json,p,finished) ! first call for this object
  7623. if (finished) return
  7624. !for arrays and objects, have to also call for all children:
  7625. if (p%var_type==json_array .or. p%var_type==json_object) then
  7626. icount = json%count(p) ! number of children
  7627. if (icount>0) then
  7628. element => p%children ! first one
  7629. do i = 1, icount ! call for each child
  7630. if (.not. associated(element)) then
  7631. call json%throw_exception('Error in json_traverse: '//&
  7632. 'Malformed JSON linked list')
  7633. return
  7634. end if
  7635. call traverse(element)
  7636. if (finished .or. json%exception_thrown) exit
  7637. element => element%next
  7638. end do
  7639. end if
  7640. nullify(element)
  7641. end if
  7642. end subroutine traverse
  7643. end subroutine json_traverse
  7644. !*****************************************************************************************
  7645. !*****************************************************************************************
  7646. !>
  7647. ! This routine calls the user-supplied array_callback subroutine
  7648. ! for each element in the array (specified by the path).
  7649. recursive subroutine json_get_array_by_path(json, me, path, array_callback, found)
  7650. implicit none
  7651. class(json_core),intent(inout) :: json
  7652. type(json_value),pointer,intent(in) :: me
  7653. character(kind=CK,len=*),intent(in) :: path
  7654. procedure(json_array_callback_func) :: array_callback
  7655. logical(LK),intent(out),optional :: found
  7656. type(json_value),pointer :: p
  7657. if ( json%exception_thrown ) then
  7658. if ( present(found) ) found = .false.
  7659. return
  7660. end if
  7661. nullify(p)
  7662. ! resolve the path to the value
  7663. call json%get(me=me, path=path, p=p)
  7664. if (.not. associated(p)) then
  7665. call json%throw_exception('Error in json_get_array:'//&
  7666. ' Unable to resolve path: '//trim(path),found)
  7667. else
  7668. call json%get(me=p,array_callback=array_callback)
  7669. nullify(p)
  7670. end if
  7671. if ( json%exception_thrown ) then
  7672. if ( present(found) ) then
  7673. found = .false.
  7674. call json%clear_exceptions()
  7675. end if
  7676. else
  7677. if ( present(found) ) found = .true.
  7678. end if
  7679. end subroutine json_get_array_by_path
  7680. !*****************************************************************************************
  7681. !*****************************************************************************************
  7682. !>
  7683. ! Alternate version of [[json_get_array_by_path]], where "path" is kind=CDK
  7684. recursive subroutine wrap_json_get_array_by_path(json, me, path, array_callback, found)
  7685. implicit none
  7686. class(json_core),intent(inout) :: json
  7687. type(json_value),pointer,intent(in) :: me
  7688. character(kind=CDK,len=*),intent(in) :: path
  7689. procedure(json_array_callback_func) :: array_callback
  7690. logical(LK),intent(out),optional :: found
  7691. call json%get(me, to_unicode(path), array_callback, found)
  7692. end subroutine wrap_json_get_array_by_path
  7693. !*****************************************************************************************
  7694. !*****************************************************************************************
  7695. !>
  7696. ! Internal routine to be called before parsing JSON.
  7697. ! Currently, all this does it allocate the `comment_char` if none was specified.
  7698. subroutine json_prepare_parser(json)
  7699. implicit none
  7700. class(json_core),intent(inout) :: json
  7701. if (json%allow_comments .and. .not. allocated(json%comment_char)) then
  7702. ! comments are enabled, but user hasn't set the comment char,
  7703. ! so in this case use the default:
  7704. json%comment_char = CK_'/!#'
  7705. end if
  7706. end subroutine json_prepare_parser
  7707. !*****************************************************************************************
  7708. !*****************************************************************************************
  7709. !>
  7710. ! Parse the JSON file and populate the [[json_value]] tree.
  7711. !
  7712. !### Inputs
  7713. !
  7714. ! The inputs can be:
  7715. !
  7716. ! * `file` & `unit` : the specified unit is used to read JSON from file.
  7717. ! [note if unit is already open, then the filename is ignored]
  7718. ! * `file` : JSON is read from file using internal unit number
  7719. !
  7720. !### Example
  7721. !
  7722. !````fortran
  7723. ! type(json_core) :: json
  7724. ! type(json_value),pointer :: p
  7725. ! call json%load(file='myfile.json', p=p)
  7726. !````
  7727. !
  7728. !### History
  7729. ! * Jacob Williams : 01/13/2015 : added read from string option.
  7730. ! * Izaak Beekman : 03/08/2015 : moved read from string to separate
  7731. ! subroutine, and error annotation to separate subroutine.
  7732. !
  7733. !@note When calling this routine, any exceptions thrown from previous
  7734. ! calls will automatically be cleared.
  7735. subroutine json_parse_file(json, file, p, unit)
  7736. implicit none
  7737. class(json_core),intent(inout) :: json
  7738. character(kind=CDK,len=*),intent(in) :: file !! JSON file name
  7739. type(json_value),pointer :: p !! output structure
  7740. integer(IK),intent(in),optional :: unit !! file unit number (/= 0)
  7741. integer(IK) :: iunit !! file unit actually used
  7742. integer(IK) :: istat !! iostat flag
  7743. logical(LK) :: is_open !! if the file is already open
  7744. logical(LK) :: has_duplicate !! if checking for duplicate keys
  7745. character(kind=CK,len=:),allocatable :: path !! path to any duplicate key
  7746. ! clear any exceptions and initialize:
  7747. call json%initialize()
  7748. call json%prepare_parser()
  7749. if ( present(unit) ) then
  7750. if (unit==0) then
  7751. call json%throw_exception('Error in json_parse_file: unit number must not be 0.')
  7752. return
  7753. end if
  7754. iunit = unit
  7755. ! check to see if the file is already open
  7756. ! if it is, then use it, otherwise open the file with the name given.
  7757. inquire(unit=iunit, opened=is_open, iostat=istat)
  7758. if (istat==0 .and. .not. is_open) then
  7759. ! open the file
  7760. open ( unit = iunit, &
  7761. file = file, &
  7762. status = 'OLD', &
  7763. action = 'READ', &
  7764. form = form_spec, &
  7765. access = access_spec, &
  7766. iostat = istat &
  7767. FILE_ENCODING )
  7768. else
  7769. ! if the file is already open, then we need to make sure
  7770. ! that it is open with the correct form/access/etc...
  7771. end if
  7772. else
  7773. ! open the file with a new unit number:
  7774. open ( newunit = iunit, &
  7775. file = file, &
  7776. status = 'OLD', &
  7777. action = 'READ', &
  7778. form = form_spec, &
  7779. access = access_spec, &
  7780. iostat = istat &
  7781. FILE_ENCODING )
  7782. end if
  7783. if (istat==0) then
  7784. if (use_unformatted_stream) then
  7785. ! save the file size to be read:
  7786. inquire(unit=iunit, size=json%filesize, iostat=istat)
  7787. end if
  7788. ! create the value and associate the pointer
  7789. call json_value_create(p)
  7790. ! Note: the name of the root json_value doesn't really matter,
  7791. ! but we'll allocate something here just in case.
  7792. p%name = trim(file) !use the file name
  7793. ! parse as a value
  7794. call json%parse_value(unit=iunit, str=CK_'', value=p)
  7795. call json%parse_end(unit=iunit, str=CK_'')
  7796. ! check for errors:
  7797. if (json%exception_thrown) then
  7798. call json%annotate_invalid_json(iunit,CK_'')
  7799. else
  7800. if (.not. json%allow_duplicate_keys) then
  7801. call json%check_for_duplicate_keys(p,has_duplicate,path=path)
  7802. if (.not. json%exception_thrown) then
  7803. if (has_duplicate) then
  7804. call json%throw_exception('Error in json_parse_file: '//&
  7805. 'Duplicate key found: '//path)
  7806. end if
  7807. end if
  7808. end if
  7809. end if
  7810. ! close the file:
  7811. close(unit=iunit, iostat=istat)
  7812. else
  7813. call json%throw_exception('Error in json_parse_file: Error opening file: '//trim(file))
  7814. nullify(p)
  7815. end if
  7816. end subroutine json_parse_file
  7817. !*****************************************************************************************
  7818. !*****************************************************************************************
  7819. !>
  7820. ! Parse the JSON string and populate the [[json_value]] tree.
  7821. !
  7822. !### See also
  7823. ! * [[json_parse_file]]
  7824. subroutine json_parse_string(json, p, str)
  7825. implicit none
  7826. class(json_core),intent(inout) :: json
  7827. type(json_value),pointer :: p !! output structure
  7828. character(kind=CK,len=*),intent(in) :: str !! string with JSON data
  7829. integer(IK),parameter :: iunit = 0 !! indicates that json data will be read from buffer
  7830. logical(LK) :: has_duplicate !! if checking for duplicate keys
  7831. character(kind=CK,len=:),allocatable :: path !! path to any duplicate key
  7832. ! clear any exceptions and initialize:
  7833. call json%initialize()
  7834. call json%prepare_parser()
  7835. ! create the value and associate the pointer
  7836. call json_value_create(p)
  7837. ! Note: the name of the root json_value doesn't really matter,
  7838. ! but we'll allocate something here just in case.
  7839. p%name = CK_''
  7840. ! parse as a value
  7841. call json%parse_value(unit=iunit, str=str, value=p)
  7842. call json%parse_end(unit=iunit, str=str)
  7843. if (json%exception_thrown) then
  7844. call json%annotate_invalid_json(iunit,str)
  7845. else
  7846. if (.not. json%allow_duplicate_keys) then
  7847. call json%check_for_duplicate_keys(p,has_duplicate,path=path)
  7848. if (.not. json%exception_thrown) then
  7849. if (has_duplicate) then
  7850. call json%throw_exception('Error in json_parse_string: '//&
  7851. 'Duplicate key found: '//path)
  7852. end if
  7853. end if
  7854. end if
  7855. end if
  7856. end subroutine json_parse_string
  7857. !*****************************************************************************************
  7858. !*****************************************************************************************
  7859. !>
  7860. ! An error checking routine to call after a file (or string) has been parsed.
  7861. ! It will throw an exception if there are any other non-whitespace characters
  7862. ! in the file.
  7863. subroutine json_parse_end(json, unit, str)
  7864. implicit none
  7865. class(json_core),intent(inout) :: json
  7866. integer(IK),intent(in) :: unit !! file unit number
  7867. character(kind=CK,len=*),intent(in) :: str !! string containing JSON
  7868. !! data (only used if `unit=0`)
  7869. logical(LK) :: eof !! end-of-file flag
  7870. character(kind=CK,len=1) :: c !! character read from file
  7871. !! (or string) by [[pop_char]]
  7872. ! first check for exceptions:
  7873. if (json%exception_thrown) return
  7874. ! pop the next non whitespace character off the file
  7875. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  7876. skip_comments=json%allow_comments, popped=c)
  7877. if (.not. eof) then
  7878. call json%throw_exception('Error in json_parse_end:'//&
  7879. ' Unexpected character found after parsing value. "'//&
  7880. c//'"')
  7881. end if
  7882. end subroutine json_parse_end
  7883. !*****************************************************************************************
  7884. !*****************************************************************************************
  7885. !>
  7886. ! Alternate version of [[json_parse_string]], where `str` is kind=CDK.
  7887. subroutine wrap_json_parse_string(json, p, str)
  7888. implicit none
  7889. class(json_core),intent(inout) :: json
  7890. type(json_value),pointer :: p !! output structure
  7891. character(kind=CDK,len=*),intent(in) :: str !! string with JSON data
  7892. call json%deserialize(p,to_unicode(str))
  7893. end subroutine wrap_json_parse_string
  7894. !*****************************************************************************************
  7895. !*****************************************************************************************
  7896. !>
  7897. ! Generate a warning message if there was an error parsing a JSON
  7898. ! file or string.
  7899. subroutine annotate_invalid_json(json,iunit,str)
  7900. implicit none
  7901. class(json_core),intent(inout) :: json
  7902. integer(IK),intent(in) :: iunit !! file unit number
  7903. character(kind=CK,len=*),intent(in) :: str !! string with JSON data
  7904. character(kind=CK,len=:),allocatable :: line !! line containing the error
  7905. character(kind=CK,len=:),allocatable :: arrow_str !! arrow string that points
  7906. !! to the current character
  7907. character(kind=CK,len=max_integer_str_len) :: line_str !! current line number string
  7908. character(kind=CK,len=max_integer_str_len) :: char_str !! current character count string
  7909. integer(IK) :: i !! line number counter
  7910. integer(IK) :: i_nl_prev !! index of previous newline character
  7911. integer(IK) :: i_nl !! index of current newline character
  7912. ! If there was an error reading the file, then
  7913. ! print the line where the error occurred:
  7914. if (json%exception_thrown) then
  7915. !the counters for the current line and the last character read:
  7916. call integer_to_string(json%line_count, int_fmt, line_str)
  7917. call integer_to_string(json%char_count, int_fmt, char_str)
  7918. !draw the arrow string that points to the current character:
  7919. arrow_str = repeat('-',max( 0_IK, json%char_count - 1_IK) )//'^'
  7920. if (json%line_count>0 .and. json%char_count>0) then
  7921. if (iunit/=0) then
  7922. if (use_unformatted_stream) then
  7923. call json%get_current_line_from_file_stream(iunit,line)
  7924. else
  7925. call json%get_current_line_from_file_sequential(iunit,line)
  7926. end if
  7927. else
  7928. !get the current line from the string:
  7929. ! [this is done by counting the newline characters]
  7930. i_nl_prev = 0 !index of previous newline character
  7931. i_nl = 2 !just in case line_count = 0
  7932. do i=1,json%line_count
  7933. i_nl = index(str(i_nl_prev+1:),newline)
  7934. if (i_nl==0) then !last line - no newline character
  7935. i_nl = len(str)+1
  7936. exit
  7937. end if
  7938. i_nl = i_nl + i_nl_prev !index of current newline character
  7939. i_nl_prev = i_nl !update for next iteration
  7940. end do
  7941. line = str(i_nl_prev+1 : i_nl-1) !extract current line
  7942. end if
  7943. else
  7944. !in this case, it was an empty line or file
  7945. line = CK_''
  7946. end if
  7947. ! add a newline for the error display if necessary:
  7948. line = trim(line)
  7949. if (len(line)>0) then
  7950. i = len(line)
  7951. if (line(i:i)/=newline) line = line//newline
  7952. else
  7953. line = line//newline
  7954. end if
  7955. !create the error message:
  7956. if (allocated(json%err_message)) then
  7957. json%err_message = json%err_message//newline
  7958. else
  7959. json%err_message = ''
  7960. end if
  7961. json%err_message = json%err_message//&
  7962. 'line: '//trim(adjustl(line_str))//', '//&
  7963. 'character: '//trim(adjustl(char_str))//newline//&
  7964. line//arrow_str
  7965. if (allocated(line)) deallocate(line)
  7966. end if
  7967. end subroutine annotate_invalid_json
  7968. !*****************************************************************************************
  7969. !*****************************************************************************************
  7970. !> author: Jacob Williams
  7971. !
  7972. ! Rewind the file to the beginning of the current line, and return this line.
  7973. ! The file is assumed to be opened.
  7974. ! This is the SEQUENTIAL version (see also [[get_current_line_from_file_stream]]).
  7975. subroutine get_current_line_from_file_sequential(iunit,line)
  7976. implicit none
  7977. integer(IK),intent(in) :: iunit !! file unit number
  7978. character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
  7979. character(kind=CK,len=seq_chunk_size) :: chunk !! for reading line in chunks
  7980. integer(IK) :: istat !! iostat flag
  7981. integer(IK) :: isize !! number of characters read in read statement
  7982. !initialize:
  7983. line = CK_''
  7984. !rewind to beginning of the current record:
  7985. backspace(iunit, iostat=istat)
  7986. !loop to read in all the characters in the current record.
  7987. ![the line is read in chunks until the end of the line is reached]
  7988. if (istat==0) then
  7989. do
  7990. isize = 0
  7991. read(iunit,fmt='(A)',advance='NO',size=isize,iostat=istat) chunk
  7992. if (istat==0) then
  7993. line = line//chunk
  7994. else
  7995. if (isize>0 .and. isize<=seq_chunk_size) line = line//chunk(1:isize)
  7996. exit
  7997. end if
  7998. end do
  7999. end if
  8000. end subroutine get_current_line_from_file_sequential
  8001. !*****************************************************************************************
  8002. !*****************************************************************************************
  8003. !> author: Jacob Williams
  8004. !
  8005. ! Rewind the file to the beginning of the current line, and return this line.
  8006. ! The file is assumed to be opened.
  8007. ! This is the STREAM version (see also [[get_current_line_from_file_sequential]]).
  8008. subroutine get_current_line_from_file_stream(json,iunit,line)
  8009. implicit none
  8010. class(json_core),intent(inout) :: json
  8011. integer(IK),intent(in) :: iunit !! file unit number
  8012. character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
  8013. integer(IK) :: istart !! start position of current line
  8014. integer(IK) :: iend !! end position of current line
  8015. integer(IK) :: ios !! file read `iostat` code
  8016. character(kind=CK,len=1) :: c !! a character read from the file
  8017. logical :: done !! flag to exit the loop
  8018. istart = json%ipos
  8019. do
  8020. if (istart<=1) then
  8021. istart = 1
  8022. exit
  8023. end if
  8024. read(iunit,pos=istart,iostat=ios) c
  8025. done = ios /= 0_IK
  8026. if (.not. done) done = c==newline
  8027. if (done) then
  8028. if (istart/=1) istart = istart - 1
  8029. exit
  8030. end if
  8031. istart = istart-1 !rewind until the beginning of the line
  8032. end do
  8033. iend = json%ipos
  8034. do
  8035. read(iunit,pos=iend,iostat=ios) c
  8036. if (IS_IOSTAT_END(ios)) then
  8037. ! account for end of file without linebreak
  8038. iend=iend-1
  8039. exit
  8040. end if
  8041. if (c==newline .or. ios/=0) exit
  8042. iend=iend+1
  8043. end do
  8044. allocate( character(kind=CK,len=iend-istart+1) :: line )
  8045. read(iunit,pos=istart,iostat=ios) line
  8046. end subroutine get_current_line_from_file_stream
  8047. !*****************************************************************************************
  8048. !*****************************************************************************************
  8049. !>
  8050. ! Core parsing routine.
  8051. recursive subroutine parse_value(json, unit, str, value)
  8052. implicit none
  8053. class(json_core),intent(inout) :: json
  8054. integer(IK),intent(in) :: unit !! file unit number
  8055. character(kind=CK,len=*),intent(in) :: str !! string containing JSON
  8056. !! data (only used if `unit=0`)
  8057. type(json_value),pointer :: value !! JSON data that is extracted
  8058. logical(LK) :: eof !! end-of-file flag
  8059. character(kind=CK,len=1) :: c !! character read from file
  8060. !! (or string) by [[pop_char]]
  8061. #if defined __GFORTRAN__
  8062. character(kind=CK,len=:),allocatable :: tmp !! this is a work-around for a bug
  8063. !! in the gfortran 4.9 compiler.
  8064. #endif
  8065. if (.not. json%exception_thrown) then
  8066. !the routine is being called incorrectly.
  8067. if (.not. associated(value)) then
  8068. call json%throw_exception('Error in parse_value: value pointer not associated.')
  8069. return
  8070. end if
  8071. ! pop the next non whitespace character off the file
  8072. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8073. skip_comments=json%allow_comments, popped=c)
  8074. if (eof) then
  8075. return
  8076. else
  8077. select case (c)
  8078. case (start_object)
  8079. ! start object
  8080. call json%to_object(value) !allocate class
  8081. call json%parse_object(unit, str, value)
  8082. case (start_array)
  8083. ! start array
  8084. call json%to_array(value) !allocate class
  8085. call json%parse_array(unit, str, value)
  8086. case (end_array)
  8087. ! end an empty array
  8088. call json%push_char(c)
  8089. if (associated(value)) then
  8090. deallocate(value)
  8091. nullify(value)
  8092. end if
  8093. case (quotation_mark)
  8094. ! string
  8095. call json%to_string(value) !allocate class
  8096. select case (value%var_type)
  8097. case (json_string)
  8098. #if defined __GFORTRAN__
  8099. ! write to a tmp variable because of
  8100. ! a bug in 4.9 gfortran compiler.
  8101. call json%parse_string(unit,str,tmp)
  8102. value%str_value = tmp
  8103. if (allocated(tmp)) deallocate(tmp)
  8104. #else
  8105. call json%parse_string(unit,str,value%str_value)
  8106. #endif
  8107. end select
  8108. case (CK_'t') !true_str(1:1) gfortran bug work around
  8109. !true
  8110. call json%parse_for_chars(unit, str, true_str(2:))
  8111. !allocate class and set value:
  8112. if (.not. json%exception_thrown) call json%to_logical(value,.true.)
  8113. case (CK_'f') !false_str(1:1) gfortran bug work around
  8114. !false
  8115. call json%parse_for_chars(unit, str, false_str(2:))
  8116. !allocate class and set value:
  8117. if (.not. json%exception_thrown) call json%to_logical(value,.false.)
  8118. case (CK_'n') !null_str(1:1) gfortran bug work around
  8119. !null
  8120. call json%parse_for_chars(unit, str, null_str(2:))
  8121. if (.not. json%exception_thrown) call json%to_null(value) ! allocate class
  8122. case(CK_'-', CK_'0': CK_'9', CK_'.', CK_'+')
  8123. call json%push_char(c)
  8124. call json%parse_number(unit, str, value)
  8125. case default
  8126. call json%throw_exception('Error in parse_value:'//&
  8127. ' Unexpected character while parsing value. "'//&
  8128. c//'"')
  8129. end select
  8130. end if
  8131. end if
  8132. end subroutine parse_value
  8133. !*****************************************************************************************
  8134. !*****************************************************************************************
  8135. !> author: Jacob Williams
  8136. !
  8137. ! Allocate a [[json_value]] pointer and make it a logical(LK) variable.
  8138. ! The pointer should not already be allocated.
  8139. !
  8140. !### Example
  8141. !````fortran
  8142. ! type(json_value),pointer :: p
  8143. ! type(json_core) :: json
  8144. ! call json%create_logical(p,'value',.true.)
  8145. !````
  8146. subroutine json_value_create_logical(json,p,val,name)
  8147. implicit none
  8148. class(json_core),intent(inout) :: json
  8149. type(json_value),pointer :: p
  8150. logical(LK),intent(in) :: val !! variable value
  8151. character(kind=CK,len=*),intent(in) :: name !! variable name
  8152. call json_value_create(p)
  8153. call json%to_logical(p,val,name)
  8154. end subroutine json_value_create_logical
  8155. !*****************************************************************************************
  8156. !*****************************************************************************************
  8157. !> author: Izaak Beekman
  8158. !
  8159. ! Wrapper for [[json_value_create_logical]] so `create_logical` method can
  8160. ! be called with name of character kind 'DEFAULT' or 'ISO_10646'
  8161. subroutine wrap_json_value_create_logical(json,p,val,name)
  8162. implicit none
  8163. class(json_core),intent(inout) :: json
  8164. type(json_value),pointer :: p
  8165. logical(LK),intent(in) :: val
  8166. character(kind=CDK,len=*),intent(in) :: name
  8167. call json%create_logical(p,val,to_unicode(name))
  8168. end subroutine wrap_json_value_create_logical
  8169. !*****************************************************************************************
  8170. !*****************************************************************************************
  8171. !> author: Jacob Williams
  8172. !
  8173. ! Allocate a [[json_value]] pointer and make it an integer(IK) variable.
  8174. ! The pointer should not already be allocated.
  8175. !
  8176. !### Example
  8177. !````fortran
  8178. ! type(json_value),pointer :: p
  8179. ! type(json_core) :: json
  8180. ! call json%create_integer(p,'value',1)
  8181. !````
  8182. subroutine json_value_create_integer(json,p,val,name)
  8183. implicit none
  8184. class(json_core),intent(inout) :: json
  8185. type(json_value),pointer :: p
  8186. integer(IK),intent(in) :: val
  8187. character(kind=CK,len=*),intent(in) :: name
  8188. call json_value_create(p)
  8189. call json%to_integer(p,val,name)
  8190. end subroutine json_value_create_integer
  8191. !*****************************************************************************************
  8192. !*****************************************************************************************
  8193. !> author: Izaak Beekman
  8194. !
  8195. ! A wrapper procedure for [[json_value_create_integer]] so that `create_integer`
  8196. ! method may be called with either a 'DEFAULT' or 'ISO_10646' character kind
  8197. ! `name` actual argument.
  8198. subroutine wrap_json_value_create_integer(json,p,val,name)
  8199. implicit none
  8200. class(json_core),intent(inout) :: json
  8201. type(json_value),pointer :: p
  8202. integer(IK),intent(in) :: val
  8203. character(kind=CDK,len=*),intent(in) :: name
  8204. call json%create_integer(p,val,to_unicode(name))
  8205. end subroutine wrap_json_value_create_integer
  8206. !*****************************************************************************************
  8207. !*****************************************************************************************
  8208. !> author: Jacob Williams
  8209. !
  8210. ! Allocate a [[json_value]] pointer and make it a real(RK) variable.
  8211. ! The pointer should not already be allocated.
  8212. !
  8213. !### Example
  8214. !````fortran
  8215. ! type(json_value),pointer :: p
  8216. ! type(json_core) :: json
  8217. ! call json%create_real(p,'value',1.0_RK)
  8218. !````
  8219. subroutine json_value_create_real(json,p,val,name)
  8220. implicit none
  8221. class(json_core),intent(inout) :: json
  8222. type(json_value),pointer :: p
  8223. real(RK),intent(in) :: val
  8224. character(kind=CK,len=*),intent(in) :: name
  8225. call json_value_create(p)
  8226. call json%to_real(p,val,name)
  8227. end subroutine json_value_create_real
  8228. !*****************************************************************************************
  8229. !*****************************************************************************************
  8230. !> author: Izaak Beekman
  8231. !
  8232. ! A wrapper for [[json_value_create_real]] so that `create_real` method
  8233. ! may be called with an actual argument corresponding to the dummy argument,
  8234. ! `name` that may be of 'DEFAULT' or 'ISO_10646' character kind.
  8235. subroutine wrap_json_value_create_real(json,p,val,name)
  8236. implicit none
  8237. class(json_core),intent(inout) :: json
  8238. type(json_value),pointer :: p
  8239. real(RK),intent(in) :: val
  8240. character(kind=CDK,len=*),intent(in) :: name
  8241. call json%create_real(p,val,to_unicode(name))
  8242. end subroutine wrap_json_value_create_real
  8243. !*****************************************************************************************
  8244. #ifndef REAL32
  8245. !*****************************************************************************************
  8246. !>
  8247. ! Alternate version of [[json_value_create_real]] where val=real32.
  8248. !
  8249. !@note The value is converted into a `real(RK)` variable internally.
  8250. subroutine json_value_create_real32(json,p,val,name)
  8251. implicit none
  8252. class(json_core),intent(inout) :: json
  8253. type(json_value),pointer :: p
  8254. real(real32),intent(in) :: val
  8255. character(kind=CK,len=*),intent(in) :: name
  8256. call json%create_real(p,real(val,RK),name)
  8257. end subroutine json_value_create_real32
  8258. !*****************************************************************************************
  8259. !*****************************************************************************************
  8260. !>
  8261. ! Alternate version of [[json_value_create_real32]] where "name" is kind(CDK).
  8262. subroutine wrap_json_value_create_real32(json,p,val,name)
  8263. implicit none
  8264. class(json_core),intent(inout) :: json
  8265. type(json_value),pointer :: p
  8266. real(real32),intent(in) :: val
  8267. character(kind=CDK,len=*),intent(in) :: name
  8268. call json%create_real(p,val,to_unicode(name))
  8269. end subroutine wrap_json_value_create_real32
  8270. !*****************************************************************************************
  8271. #endif
  8272. #ifdef REAL128
  8273. !*****************************************************************************************
  8274. !>
  8275. ! Alternate version of [[json_value_create_real]] where val=real64.
  8276. !
  8277. !@note The value is converted into a `real(RK)` variable internally.
  8278. subroutine json_value_create_real64(json,p,val,name)
  8279. implicit none
  8280. class(json_core),intent(inout) :: json
  8281. type(json_value),pointer :: p
  8282. real(real64),intent(in) :: val
  8283. character(kind=CK,len=*),intent(in) :: name
  8284. call json%create_real(p,real(val,RK),name)
  8285. end subroutine json_value_create_real64
  8286. !*****************************************************************************************
  8287. !*****************************************************************************************
  8288. !>
  8289. ! Alternate version of [[json_value_create_real64]] where "name" is kind(CDK).
  8290. subroutine wrap_json_value_create_real64(json,p,val,name)
  8291. implicit none
  8292. class(json_core),intent(inout) :: json
  8293. type(json_value),pointer :: p
  8294. real(real64),intent(in) :: val
  8295. character(kind=CDK,len=*),intent(in) :: name
  8296. call json%create_real(p,val,to_unicode(name))
  8297. end subroutine wrap_json_value_create_real64
  8298. !*****************************************************************************************
  8299. #endif
  8300. !*****************************************************************************************
  8301. !> author: Jacob Williams
  8302. !
  8303. ! Allocate a json_value pointer and make it a string variable.
  8304. ! The pointer should not already be allocated.
  8305. !
  8306. !### Example
  8307. !````fortran
  8308. ! type(json_value),pointer :: p
  8309. ! type(json_core) :: json
  8310. ! call json%create_string(p,'value','hello')
  8311. !````
  8312. subroutine json_value_create_string(json,p,val,name,trim_str,adjustl_str)
  8313. implicit none
  8314. class(json_core),intent(inout) :: json
  8315. type(json_value),pointer :: p
  8316. character(kind=CK,len=*),intent(in) :: val
  8317. character(kind=CK,len=*),intent(in) :: name
  8318. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  8319. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  8320. call json_value_create(p)
  8321. call json%to_string(p,val,name,trim_str,adjustl_str)
  8322. end subroutine json_value_create_string
  8323. !*****************************************************************************************
  8324. !*****************************************************************************************
  8325. !> author: Izaak Beekman
  8326. !
  8327. ! Wrap [[json_value_create_string]] so that `create_string` method may be called
  8328. ! with actual character string arguments for `name` and `val` that are BOTH of
  8329. ! 'DEFAULT' or 'ISO_10646' character kind.
  8330. subroutine wrap_json_value_create_string(json,p,val,name,trim_str,adjustl_str)
  8331. implicit none
  8332. class(json_core),intent(inout) :: json
  8333. type(json_value),pointer :: p
  8334. character(kind=CDK,len=*),intent(in) :: val
  8335. character(kind=CDK,len=*),intent(in) :: name
  8336. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  8337. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  8338. call json%create_string(p,to_unicode(val),to_unicode(name),trim_str,adjustl_str)
  8339. end subroutine wrap_json_value_create_string
  8340. !*****************************************************************************************
  8341. !*****************************************************************************************
  8342. !> author: Jacob Williams
  8343. !
  8344. ! Allocate a json_value pointer and make it a null variable.
  8345. ! The pointer should not already be allocated.
  8346. !
  8347. !### Example
  8348. !````fortran
  8349. ! type(json_value),pointer :: p
  8350. ! type(json_core) :: json
  8351. ! call json%create_null(p,'value')
  8352. !````
  8353. subroutine json_value_create_null(json,p,name)
  8354. implicit none
  8355. class(json_core),intent(inout) :: json
  8356. type(json_value),pointer :: p
  8357. character(kind=CK,len=*),intent(in) :: name
  8358. call json_value_create(p)
  8359. call json%to_null(p,name)
  8360. end subroutine json_value_create_null
  8361. !*****************************************************************************************
  8362. !*****************************************************************************************
  8363. !> author: Izaak Beekman
  8364. !
  8365. ! Wrap [[json_value_create_null]] so that `create_null` method may be called with
  8366. ! an actual argument corresponding to the dummy argument `name` that is either
  8367. ! of 'DEFAULT' or 'ISO_10646' character kind.
  8368. subroutine wrap_json_value_create_null(json,p,name)
  8369. implicit none
  8370. class(json_core),intent(inout) :: json
  8371. type(json_value),pointer :: p
  8372. character(kind=CDK,len=*),intent(in) :: name
  8373. call json%create_null(p,to_unicode(name))
  8374. end subroutine wrap_json_value_create_null
  8375. !*****************************************************************************************
  8376. !*****************************************************************************************
  8377. !> author: Jacob Williams
  8378. !
  8379. ! Allocate a [[json_value]] pointer and make it an object variable.
  8380. ! The pointer should not already be allocated.
  8381. !
  8382. !### Example
  8383. !````fortran
  8384. ! type(json_value),pointer :: p
  8385. ! type(json_core) :: json
  8386. ! call json%create_object(p,'objectname')
  8387. !````
  8388. !
  8389. !@note The name is not significant for the root structure or an array element.
  8390. ! In those cases, an empty string can be used.
  8391. subroutine json_value_create_object(json,p,name)
  8392. implicit none
  8393. class(json_core),intent(inout) :: json
  8394. type(json_value),pointer :: p
  8395. character(kind=CK,len=*),intent(in) :: name
  8396. call json_value_create(p)
  8397. call json%to_object(p,name)
  8398. end subroutine json_value_create_object
  8399. !*****************************************************************************************
  8400. !*****************************************************************************************
  8401. !> author: Izaak Beekman
  8402. !
  8403. ! Wrap [[json_value_create_object]] so that `create_object` method may be called
  8404. ! with an actual argument corresponding to the dummy argument `name` that is of
  8405. ! either 'DEFAULT' or 'ISO_10646' character kind.
  8406. subroutine wrap_json_value_create_object(json,p,name)
  8407. implicit none
  8408. class(json_core),intent(inout) :: json
  8409. type(json_value),pointer :: p
  8410. character(kind=CDK,len=*),intent(in) :: name
  8411. call json%create_object(p,to_unicode(name))
  8412. end subroutine wrap_json_value_create_object
  8413. !*****************************************************************************************
  8414. !*****************************************************************************************
  8415. !> author: Jacob Williams
  8416. !
  8417. ! Allocate a [[json_value]] pointer and make it an array variable.
  8418. ! The pointer should not already be allocated.
  8419. !
  8420. !### Example
  8421. !````fortran
  8422. ! type(json_value),pointer :: p
  8423. ! type(json_core) :: json
  8424. ! call json%create_array(p,'arrayname')
  8425. !````
  8426. subroutine json_value_create_array(json,p,name)
  8427. implicit none
  8428. class(json_core),intent(inout) :: json
  8429. type(json_value),pointer :: p
  8430. character(kind=CK,len=*),intent(in) :: name
  8431. call json_value_create(p)
  8432. call json%to_array(p,name)
  8433. end subroutine json_value_create_array
  8434. !*****************************************************************************************
  8435. !*****************************************************************************************
  8436. !> author: Izaak Beekman
  8437. !
  8438. ! A wrapper for [[json_value_create_array]] so that `create_array` method may be
  8439. ! called with an actual argument, corresponding to the dummy argument `name`,
  8440. ! that is either of 'DEFAULT' or 'ISO_10646' character kind.
  8441. subroutine wrap_json_value_create_array(json,p,name)
  8442. implicit none
  8443. class(json_core),intent(inout) :: json
  8444. type(json_value),pointer :: p
  8445. character(kind=CDK,len=*),intent(in) :: name
  8446. call json%create_array(p,to_unicode(name))
  8447. end subroutine wrap_json_value_create_array
  8448. !*****************************************************************************************
  8449. !*****************************************************************************************
  8450. !> author: Jacob Williams
  8451. !
  8452. ! Change the [[json_value]] variable to a logical.
  8453. subroutine to_logical(json,p,val,name)
  8454. implicit none
  8455. class(json_core),intent(inout) :: json
  8456. type(json_value),pointer :: p
  8457. logical(LK),intent(in),optional :: val !! if the value is also to be set
  8458. !! (if not present, then .false. is used).
  8459. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8460. !set type and value:
  8461. call destroy_json_data(p)
  8462. p%var_type = json_logical
  8463. allocate(p%log_value)
  8464. if (present(val)) then
  8465. p%log_value = val
  8466. else
  8467. p%log_value = .false. !default value
  8468. end if
  8469. !name:
  8470. if (present(name)) call json%rename(p,name)
  8471. end subroutine to_logical
  8472. !*****************************************************************************************
  8473. !*****************************************************************************************
  8474. !> author: Jacob Williams
  8475. !
  8476. ! Change the [[json_value]] variable to an integer.
  8477. subroutine to_integer(json,p,val,name)
  8478. implicit none
  8479. class(json_core),intent(inout) :: json
  8480. type(json_value),pointer :: p
  8481. integer(IK),intent(in),optional :: val !! if the value is also to be set
  8482. !! (if not present, then 0 is used).
  8483. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8484. !set type and value:
  8485. call destroy_json_data(p)
  8486. p%var_type = json_integer
  8487. allocate(p%int_value)
  8488. if (present(val)) then
  8489. p%int_value = val
  8490. else
  8491. p%int_value = 0_IK !default value
  8492. end if
  8493. !name:
  8494. if (present(name)) call json%rename(p,name)
  8495. end subroutine to_integer
  8496. !*****************************************************************************************
  8497. !*****************************************************************************************
  8498. !> author: Jacob Williams
  8499. !
  8500. ! Change the [[json_value]] variable to a real.
  8501. subroutine to_real(json,p,val,name)
  8502. implicit none
  8503. class(json_core),intent(inout) :: json
  8504. type(json_value),pointer :: p
  8505. real(RK),intent(in),optional :: val !! if the value is also to be set
  8506. !! (if not present, then 0.0_rk is used).
  8507. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8508. !set type and value:
  8509. call destroy_json_data(p)
  8510. p%var_type = json_real
  8511. allocate(p%dbl_value)
  8512. if (present(val)) then
  8513. p%dbl_value = val
  8514. else
  8515. p%dbl_value = 0.0_RK !default value
  8516. end if
  8517. !name:
  8518. if (present(name)) call json%rename(p,name)
  8519. end subroutine to_real
  8520. !*****************************************************************************************
  8521. !*****************************************************************************************
  8522. !> author: Jacob Williams
  8523. !
  8524. ! Change the [[json_value]] variable to a string.
  8525. !
  8526. !### Modified
  8527. ! * Izaak Beekman : 02/24/2015
  8528. subroutine to_string(json,p,val,name,trim_str,adjustl_str)
  8529. implicit none
  8530. class(json_core),intent(inout) :: json
  8531. type(json_value),pointer :: p
  8532. character(kind=CK,len=*),intent(in),optional :: val !! if the value is also to be set
  8533. !! (if not present, then '' is used).
  8534. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8535. logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
  8536. !! (only used if `val` is present)
  8537. logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
  8538. !! (only used if `val` is present)
  8539. !! (note that ADJUSTL is done before TRIM)
  8540. character(kind=CK,len=:),allocatable :: str !! temp string for `trim()` and/or `adjustl()`
  8541. logical :: trim_string !! if the string is to be trimmed
  8542. logical :: adjustl_string !! if the string is to be adjusted left
  8543. !set type and value:
  8544. call destroy_json_data(p)
  8545. p%var_type = json_string
  8546. if (present(val)) then
  8547. if (present(trim_str)) then
  8548. trim_string = trim_str
  8549. else
  8550. trim_string = .false.
  8551. end if
  8552. if (present(adjustl_str)) then
  8553. adjustl_string = adjustl_str
  8554. else
  8555. adjustl_string = .false.
  8556. end if
  8557. if (trim_string .or. adjustl_string) then
  8558. str = val
  8559. if (adjustl_string) str = adjustl(str)
  8560. if (trim_string) str = trim(str)
  8561. p%str_value = str
  8562. else
  8563. p%str_value = val
  8564. end if
  8565. else
  8566. p%str_value = CK_'' ! default value
  8567. end if
  8568. !name:
  8569. if (present(name)) call json%rename(p,name)
  8570. end subroutine to_string
  8571. !*****************************************************************************************
  8572. !*****************************************************************************************
  8573. !> author: Jacob Williams
  8574. !
  8575. ! Change the [[json_value]] variable to a null.
  8576. subroutine to_null(json,p,name)
  8577. implicit none
  8578. class(json_core),intent(inout) :: json
  8579. type(json_value),pointer :: p
  8580. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8581. !set type and value:
  8582. call destroy_json_data(p)
  8583. p%var_type = json_null
  8584. !name:
  8585. if (present(name)) call json%rename(p,name)
  8586. end subroutine to_null
  8587. !*****************************************************************************************
  8588. !*****************************************************************************************
  8589. !> author: Jacob Williams
  8590. !
  8591. ! Change the [[json_value]] variable to an object.
  8592. subroutine to_object(json,p,name)
  8593. implicit none
  8594. class(json_core),intent(inout) :: json
  8595. type(json_value),pointer :: p
  8596. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8597. !set type and value:
  8598. call destroy_json_data(p)
  8599. p%var_type = json_object
  8600. !name:
  8601. if (present(name)) call json%rename(p,name)
  8602. end subroutine to_object
  8603. !*****************************************************************************************
  8604. !*****************************************************************************************
  8605. !> author: Jacob Williams
  8606. !
  8607. ! Change the [[json_value]] variable to an array.
  8608. subroutine to_array(json,p,name)
  8609. implicit none
  8610. class(json_core),intent(inout) :: json
  8611. type(json_value),pointer :: p
  8612. character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
  8613. !set type and value:
  8614. call destroy_json_data(p)
  8615. p%var_type = json_array
  8616. !name:
  8617. if (present(name)) call json%rename(p,name)
  8618. end subroutine to_array
  8619. !*****************************************************************************************
  8620. !*****************************************************************************************
  8621. !>
  8622. ! Core parsing routine.
  8623. recursive subroutine parse_object(json, unit, str, parent)
  8624. implicit none
  8625. class(json_core),intent(inout) :: json
  8626. integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
  8627. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
  8628. type(json_value),pointer :: parent !! the parsed object will be added as a child of this
  8629. type(json_value),pointer :: pair !! temp variable
  8630. logical(LK) :: eof !! end of file flag
  8631. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8632. #if defined __GFORTRAN__
  8633. character(kind=CK,len=:),allocatable :: tmp !! this is a work-around for a bug
  8634. !! in the gfortran 4.9 compiler.
  8635. #endif
  8636. if (.not. json%exception_thrown) then
  8637. !the routine is being called incorrectly.
  8638. if (.not. associated(parent)) then
  8639. call json%throw_exception('Error in parse_object: parent pointer not associated.')
  8640. end if
  8641. nullify(pair) !probably not necessary
  8642. ! pair name
  8643. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8644. skip_comments=json%allow_comments, popped=c)
  8645. if (eof) then
  8646. call json%throw_exception('Error in parse_object:'//&
  8647. ' Unexpected end of file while parsing start of object.')
  8648. return
  8649. else if (end_object == c) then
  8650. ! end of an empty object
  8651. return
  8652. else if (quotation_mark == c) then
  8653. call json_value_create(pair)
  8654. #if defined __GFORTRAN__
  8655. call json%parse_string(unit,str,tmp) ! write to a tmp variable because of
  8656. pair%name = tmp ! a bug in 4.9 gfortran compiler.
  8657. deallocate(tmp)
  8658. #else
  8659. call json%parse_string(unit,str,pair%name)
  8660. #endif
  8661. if (json%exception_thrown) then
  8662. call json%destroy(pair)
  8663. return
  8664. end if
  8665. else
  8666. call json%throw_exception('Error in parse_object: Expecting string: "'//c//'"')
  8667. return
  8668. end if
  8669. ! pair value
  8670. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8671. skip_comments=json%allow_comments, popped=c)
  8672. if (eof) then
  8673. call json%destroy(pair)
  8674. call json%throw_exception('Error in parse_object:'//&
  8675. ' Unexpected end of file while parsing object member.')
  8676. return
  8677. else if (colon_char == c) then
  8678. ! parse the value
  8679. call json%parse_value(unit, str, pair)
  8680. if (json%exception_thrown) then
  8681. call json%destroy(pair)
  8682. return
  8683. else
  8684. call json%add(parent, pair)
  8685. end if
  8686. else
  8687. call json%destroy(pair)
  8688. call json%throw_exception('Error in parse_object:'//&
  8689. ' Expecting : and then a value: '//c)
  8690. return
  8691. end if
  8692. ! another possible pair
  8693. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8694. skip_comments=json%allow_comments, popped=c)
  8695. if (eof) then
  8696. call json%throw_exception('Error in parse_object: '//&
  8697. 'End of file encountered when parsing an object')
  8698. return
  8699. else if (delimiter == c) then
  8700. ! read the next member
  8701. call json%parse_object(unit = unit, str=str, parent = parent)
  8702. else if (end_object == c) then
  8703. ! end of object
  8704. return
  8705. else
  8706. call json%throw_exception('Error in parse_object: Expecting end of object: '//c)
  8707. return
  8708. end if
  8709. end if
  8710. end subroutine parse_object
  8711. !*****************************************************************************************
  8712. !*****************************************************************************************
  8713. !>
  8714. ! Core parsing routine.
  8715. recursive subroutine parse_array(json, unit, str, array)
  8716. implicit none
  8717. class(json_core),intent(inout) :: json
  8718. integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
  8719. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
  8720. type(json_value),pointer :: array
  8721. type(json_value),pointer :: element !! temp variable for array element
  8722. logical(LK) :: eof !! end of file flag
  8723. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8724. do
  8725. if (json%exception_thrown) exit
  8726. ! try to parse an element value
  8727. nullify(element)
  8728. call json_value_create(element)
  8729. call json%parse_value(unit, str, element)
  8730. if (json%exception_thrown) then
  8731. if (associated(element)) call json%destroy(element)
  8732. exit
  8733. end if
  8734. ! parse value will deallocate an empty array value
  8735. if (associated(element)) call json%add(array, element)
  8736. ! popped the next character
  8737. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
  8738. skip_comments=json%allow_comments, popped=c)
  8739. if (eof) then
  8740. ! The file ended before array was finished:
  8741. call json%throw_exception('Error in parse_array: '//&
  8742. 'End of file encountered when parsing an array.')
  8743. exit
  8744. else if (delimiter == c) then
  8745. ! parse the next element
  8746. cycle
  8747. else if (end_array == c) then
  8748. ! end of array
  8749. exit
  8750. else
  8751. call json%throw_exception('Error in parse_array: '//&
  8752. 'Unexpected character encountered when parsing array.')
  8753. exit
  8754. end if
  8755. end do
  8756. end subroutine parse_array
  8757. !*****************************************************************************************
  8758. !*****************************************************************************************
  8759. !>
  8760. ! Parses a string while reading a JSON file.
  8761. !
  8762. !### History
  8763. ! * Jacob Williams : 6/16/2014 : Added hex validation.
  8764. ! * Jacob Williams : 12/3/2015 : Fixed some bugs.
  8765. ! * Jacob Williams : 8/23/2015 : `string` is now returned unescaped.
  8766. ! * Jacob Williams : 7/21/2018 : moved hex validate to [[unescape_string]].
  8767. subroutine parse_string(json, unit, str, string)
  8768. implicit none
  8769. class(json_core),intent(inout) :: json
  8770. integer(IK),intent(in) :: unit !! file unit number (if
  8771. !! parsing from a file)
  8772. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing
  8773. !! from a string)
  8774. character(kind=CK,len=:),allocatable,intent(out) :: string !! the string (unescaped
  8775. !! if necessary)
  8776. logical(LK) :: eof !! end of file flag
  8777. logical(LK) :: escape !! for escape string parsing
  8778. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8779. integer(IK) :: ip !! index to put next character,
  8780. !! to speed up by reducing the number
  8781. !! of character string reallocations.
  8782. character(kind=CK,len=:),allocatable :: error_message !! for string unescaping
  8783. !at least return a blank string if there is a problem:
  8784. string = blank_chunk
  8785. if (.not. json%exception_thrown) then
  8786. !initialize:
  8787. escape = .false.
  8788. ip = 1
  8789. do
  8790. !get the next character from the file:
  8791. call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c)
  8792. if (eof) then
  8793. call json%throw_exception('Error in parse_string: Expecting end of string')
  8794. return
  8795. else if (c==quotation_mark .and. .not. escape) then !end of string
  8796. exit
  8797. else
  8798. !if the string is not big enough, then add another chunk:
  8799. if (ip>len(string)) string = string // blank_chunk
  8800. !append to string:
  8801. string(ip:ip) = c
  8802. ip = ip + 1
  8803. ! check for escape character, so we don't
  8804. ! exit prematurely if escaping a quotation
  8805. ! character:
  8806. if (escape) then
  8807. escape = .false.
  8808. else
  8809. escape = (c==backslash)
  8810. end if
  8811. end if
  8812. end do
  8813. !trim the string if necessary:
  8814. if (ip<len(string)+1) then
  8815. if (ip==1) then
  8816. string = CK_''
  8817. else
  8818. string = string(1:ip-1)
  8819. end if
  8820. end if
  8821. ! string is returned unescaped:
  8822. ! (this will also validate any hex strings present)
  8823. call unescape_string(string,error_message)
  8824. if (allocated(error_message)) then
  8825. call json%throw_exception(error_message)
  8826. deallocate(error_message) !cleanup
  8827. end if
  8828. end if
  8829. end subroutine parse_string
  8830. !*****************************************************************************************
  8831. !*****************************************************************************************
  8832. !>
  8833. ! Core parsing routine.
  8834. !
  8835. ! This is used to verify the strings `true`, `false`, and `null` during parsing.
  8836. subroutine parse_for_chars(json, unit, str, chars)
  8837. implicit none
  8838. class(json_core),intent(inout) :: json
  8839. integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
  8840. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
  8841. character(kind=CK,len=*),intent(in) :: chars !! the string to check for.
  8842. integer(IK) :: i !! counter
  8843. integer(IK) :: length !! trimmed length of `chars`
  8844. logical(LK) :: eof !! end of file flag
  8845. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8846. if (.not. json%exception_thrown) then
  8847. length = len_trim(chars)
  8848. do i = 1, length
  8849. call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c)
  8850. if (eof) then
  8851. call json%throw_exception('Error in parse_for_chars:'//&
  8852. ' Unexpected end of file while parsing.')
  8853. return
  8854. else if (c /= chars(i:i)) then
  8855. call json%throw_exception('Error in parse_for_chars:'//&
  8856. ' Unexpected character: "'//c//'" (expecting "'//&
  8857. chars(i:i)//'")')
  8858. return
  8859. end if
  8860. end do
  8861. end if
  8862. end subroutine parse_for_chars
  8863. !*****************************************************************************************
  8864. !*****************************************************************************************
  8865. !> author: Jacob Williams
  8866. ! date: 1/20/2014
  8867. !
  8868. ! Read a numerical value from the file (or string).
  8869. ! The routine will determine if it is an integer or a real, and
  8870. ! allocate the type accordingly.
  8871. !
  8872. !@note Complete rewrite of the original FSON routine, which had some problems.
  8873. subroutine parse_number(json, unit, str, value)
  8874. implicit none
  8875. class(json_core),intent(inout) :: json
  8876. integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
  8877. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
  8878. type(json_value),pointer :: value
  8879. character(kind=CK,len=:),allocatable :: tmp !! temp string
  8880. character(kind=CK,len=:),allocatable :: saved_err_message !! temp error message for
  8881. !! string to int conversion
  8882. character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
  8883. logical(LK) :: eof !! end of file flag
  8884. real(RK) :: rval !! real value
  8885. integer(IK) :: ival !! integer value
  8886. logical(LK) :: first !! first character
  8887. logical(LK) :: is_integer !! it is an integer
  8888. integer(IK) :: ip !! index to put next character
  8889. !! [to speed up by reducing the number
  8890. !! of character string reallocations]
  8891. if (.not. json%exception_thrown) then
  8892. tmp = blank_chunk
  8893. ip = 1
  8894. first = .true.
  8895. is_integer = .true. !assume it may be an integer, unless otherwise determined
  8896. !read one character at a time and accumulate the string:
  8897. do
  8898. !get the next character:
  8899. call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., popped=c)
  8900. select case (c)
  8901. case(CK_'-',CK_'+') !note: allowing a '+' as the first character here.
  8902. if (is_integer .and. (.not. first)) is_integer = .false.
  8903. !add it to the string:
  8904. !tmp = tmp // c !...original
  8905. if (ip>len(tmp)) tmp = tmp // blank_chunk
  8906. tmp(ip:ip) = c
  8907. ip = ip + 1
  8908. case(CK_'.',CK_'E',CK_'e',CK_'D',CK_'d') !can be present in real numbers
  8909. if (is_integer) is_integer = .false.
  8910. !add it to the string:
  8911. !tmp = tmp // c !...original
  8912. if (ip>len(tmp)) tmp = tmp // blank_chunk
  8913. tmp(ip:ip) = c
  8914. ip = ip + 1
  8915. case(CK_'0':CK_'9') !valid characters for numbers
  8916. !add it to the string:
  8917. !tmp = tmp // c !...original
  8918. if (ip>len(tmp)) tmp = tmp // blank_chunk
  8919. tmp(ip:ip) = c
  8920. ip = ip + 1
  8921. case default
  8922. !push back the last character read:
  8923. call json%push_char(c)
  8924. !string to value:
  8925. if (is_integer) then
  8926. ! it is an integer:
  8927. ival = json%string_to_int(tmp)
  8928. if (json%exception_thrown .and. .not. json%strict_integer_type_checking) then
  8929. ! if it couldn't be converted to an integer,
  8930. ! then try to convert it to a real value and see if that works
  8931. saved_err_message = json%err_message ! keep the original error message
  8932. call json%clear_exceptions() ! clear exceptions
  8933. rval = json%string_to_dble(tmp)
  8934. if (json%exception_thrown) then
  8935. ! restore original error message and continue
  8936. json%err_message = saved_err_message
  8937. call json%to_integer(value,ival) ! just so we have something
  8938. else
  8939. ! in this case, we return a real
  8940. call json%to_real(value,rval)
  8941. end if
  8942. else
  8943. call json%to_integer(value,ival)
  8944. end if
  8945. else
  8946. ! it is a real:
  8947. rval = json%string_to_dble(tmp)
  8948. call json%to_real(value,rval)
  8949. end if
  8950. exit !finished
  8951. end select
  8952. if (first) first = .false.
  8953. end do
  8954. !cleanup:
  8955. if (allocated(tmp)) deallocate(tmp)
  8956. end if
  8957. end subroutine parse_number
  8958. !*****************************************************************************************
  8959. !*****************************************************************************************
  8960. !>
  8961. ! Get the next character from the file (or string).
  8962. !
  8963. !### See also
  8964. ! * [[push_char]]
  8965. !
  8966. !@note This routine ignores non-printing ASCII characters
  8967. ! (`iachar<=31`) that are in strings.
  8968. subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped)
  8969. implicit none
  8970. class(json_core),intent(inout) :: json
  8971. integer(IK),intent(in) :: unit !! file unit number (if parsing
  8972. !! from a file)
  8973. character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a
  8974. !! string) -- only used if `unit=0`
  8975. logical(LK),intent(in),optional :: skip_ws !! to ignore whitespace [default False]
  8976. logical(LK),intent(in),optional :: skip_comments !! to ignore comment lines [default False]
  8977. logical(LK),intent(out) :: eof !! true if the end of the file has
  8978. !! been reached.
  8979. character(kind=CK,len=1),intent(out) :: popped !! the popped character returned
  8980. integer(IK) :: ios !! `iostat` flag
  8981. integer(IK) :: str_len !! length of `str`
  8982. character(kind=CK,len=1) :: c !! a character read from the file (or string)
  8983. logical(LK) :: ignore !! if whitespace is to be ignored
  8984. logical(LK) :: ignore_comments !! if comment lines are to be ignored
  8985. logical(LK) :: parsing_comment !! if we are in the process
  8986. !! of parsing a comment line
  8987. if (.not. json%exception_thrown) then
  8988. eof = .false.
  8989. if (.not. present(skip_ws)) then
  8990. ignore = .false.
  8991. else
  8992. ignore = skip_ws
  8993. end if
  8994. parsing_comment = .false.
  8995. if (.not. present(skip_comments)) then
  8996. ignore_comments = .false.
  8997. else
  8998. ignore_comments = skip_comments
  8999. end if
  9000. do
  9001. if (json%pushed_index > 0) then
  9002. ! there is a character pushed back on, most likely
  9003. ! from the number parsing. Note: this can only occur if
  9004. ! reading from a file when use_unformatted_stream=.false.
  9005. c = json%pushed_char(json%pushed_index:json%pushed_index)
  9006. json%pushed_index = json%pushed_index - 1
  9007. else
  9008. if (unit/=0) then !read from the file
  9009. !read the next character:
  9010. if (use_unformatted_stream) then
  9011. ! in this case, we read the file in chunks.
  9012. ! if we already have the character we need,
  9013. ! then get it from the chunk. Otherwise,
  9014. ! read in another chunk.
  9015. if (json%ichunk<1) then
  9016. ! read in a chunk:
  9017. json%ichunk = 0
  9018. if (json%filesize<json%ipos+len(json%chunk)-1) then
  9019. ! for the last chunk, we resize
  9020. ! it to the correct size:
  9021. json%chunk = repeat(space, json%filesize-json%ipos+1)
  9022. end if
  9023. read(unit=unit,pos=json%ipos,iostat=ios) json%chunk
  9024. else
  9025. ios = 0
  9026. end if
  9027. json%ichunk = json%ichunk + 1
  9028. if (json%ichunk>len(json%chunk)) then
  9029. ! check this just in case
  9030. ios = IOSTAT_END
  9031. else
  9032. ! get the next character from the chunk:
  9033. c = json%chunk(json%ichunk:json%ichunk)
  9034. if (json%ichunk==len(json%chunk)) then
  9035. json%ichunk = 0 ! reset for next chunk
  9036. end if
  9037. end if
  9038. else
  9039. ! a formatted read:
  9040. read(unit=unit,fmt='(A1)',advance='NO',iostat=ios) c
  9041. end if
  9042. json%ipos = json%ipos + 1
  9043. else !read from the string
  9044. str_len = len(str) !length of the string
  9045. if (json%ipos<=str_len) then
  9046. c = str(json%ipos:json%ipos)
  9047. ios = 0
  9048. else
  9049. ios = IOSTAT_END !end of the string
  9050. end if
  9051. json%ipos = json%ipos + 1
  9052. end if
  9053. json%char_count = json%char_count + 1 !character count in the current line
  9054. if (IS_IOSTAT_END(ios)) then !end of file
  9055. ! no character to return
  9056. json%char_count = 0
  9057. eof = .true.
  9058. popped = space ! just to set a value
  9059. exit
  9060. else if (IS_IOSTAT_EOR(ios) .or. c==newline) then !end of record
  9061. json%char_count = 0
  9062. json%line_count = json%line_count + 1
  9063. if (ignore_comments) parsing_comment = .false. ! done parsing this comment line
  9064. cycle
  9065. end if
  9066. end if
  9067. if (ignore_comments .and. (parsing_comment .or. scan(c,json%comment_char,kind=IK)>0_IK) ) then
  9068. ! skipping the comment
  9069. parsing_comment = .true.
  9070. cycle
  9071. else if (any(c == control_chars)) then
  9072. ! non printing ascii characters
  9073. cycle
  9074. else if (ignore .and. c == space) then
  9075. ! ignoring whitespace
  9076. cycle
  9077. else
  9078. ! return the character
  9079. popped = c
  9080. exit
  9081. end if
  9082. end do
  9083. end if
  9084. end subroutine pop_char
  9085. !*****************************************************************************************
  9086. !*****************************************************************************************
  9087. !>
  9088. ! Core routine.
  9089. !
  9090. !### See also
  9091. ! * [[pop_char]]
  9092. !
  9093. !### History
  9094. ! * Jacob Williams : 5/3/2015 : replaced original version of this routine.
  9095. subroutine push_char(json,c)
  9096. implicit none
  9097. class(json_core),intent(inout) :: json
  9098. character(kind=CK,len=1),intent(in) :: c !! to character to push
  9099. character(kind=CK,len=max_numeric_str_len) :: istr !! for error printing
  9100. if (.not. json%exception_thrown) then
  9101. if (use_unformatted_stream) then
  9102. !in this case, c is ignored, and we just
  9103. !decrement the stream position counter:
  9104. json%ipos = json%ipos - 1
  9105. json%ichunk = json%ichunk - 1
  9106. else
  9107. json%pushed_index = json%pushed_index + 1
  9108. if (json%pushed_index>0 .and. json%pushed_index<=len(json%pushed_char)) then
  9109. json%pushed_char(json%pushed_index:json%pushed_index) = c
  9110. else
  9111. call integer_to_string(json%pushed_index,int_fmt,istr)
  9112. call json%throw_exception('Error in push_char: '//&
  9113. 'invalid valid of pushed_index: '//trim(istr))
  9114. end if
  9115. end if
  9116. !character count in the current line
  9117. json%char_count = json%char_count - 1
  9118. end if
  9119. end subroutine push_char
  9120. !*****************************************************************************************
  9121. !*****************************************************************************************
  9122. !> author: Jacob Williams
  9123. !
  9124. ! Print any error message, and then clear the exceptions.
  9125. !
  9126. !@note This routine is used by the unit tests.
  9127. ! It was originally in json_example.f90, and was
  9128. ! moved here 2/26/2015 by Izaak Beekman.
  9129. subroutine json_print_error_message(json,io_unit)
  9130. implicit none
  9131. class(json_core),intent(inout) :: json
  9132. integer, intent(in), optional :: io_unit !! unit number for
  9133. !! printing error message
  9134. character(kind=CK,len=:),allocatable :: error_msg !! error message
  9135. logical :: status_ok !! false if there were any errors thrown
  9136. !get error message:
  9137. call json%check_for_errors(status_ok, error_msg)
  9138. !print it if there is one:
  9139. if (.not. status_ok) then
  9140. if (present(io_unit)) then
  9141. write(io_unit,'(A)') error_msg
  9142. else
  9143. write(output_unit,'(A)') error_msg
  9144. end if
  9145. deallocate(error_msg)
  9146. call json%clear_exceptions()
  9147. end if
  9148. end subroutine json_print_error_message
  9149. !*****************************************************************************************
  9150. !*****************************************************************************************
  9151. end module json_value_module
  9152. !*****************************************************************************************