Line data Source code
1 : !> JSON serializer: dump an hsd_table tree to JSON.
2 : !>
3 : !> Mapping (per SPECIFICATION.md §3.3):
4 : !> hsd_table → JSON object { ... }
5 : !> hsd_value (int) → number
6 : !> hsd_value (real) → number
7 : !> hsd_value (bool) → true / false
8 : !> hsd_value (str) → "string"
9 : !> hsd_value (complex)→ {"re": r, "im": i}
10 : !> node%attrib → sibling key "name__attrib": "value"
11 : !> anonymous value → "_value": ...
12 : !> root table → top-level { ... }
13 : module hsd_data_json_writer
14 : use hsd, only: hsd_table, hsd_value, hsd_node, hsd_node_ptr, &
15 : & VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
16 : & VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, &
17 : & VALUE_TYPE_COMPLEX, hsd_error_t, dp, HSD_STAT_IO_ERROR
18 : use hsd_data_json_escape, only: json_escape_string
19 : implicit none(type, external)
20 : private
21 :
22 : public :: json_dump_to_string, json_dump_file
23 :
24 : !> Suffix for attribute sibling keys
25 : character(len=*), parameter :: ATTRIB_SUFFIX = "__attrib"
26 :
27 : !> Key for anonymous values
28 : character(len=*), parameter :: ANON_VALUE_KEY = "_value"
29 :
30 : !> Default indentation width
31 : integer, parameter :: INDENT_WIDTH = 2
32 :
33 : contains
34 :
35 : !> Dump an hsd_table tree to a JSON string.
36 88 : subroutine json_dump_to_string(root, output, pretty)
37 : type(hsd_table), intent(in) :: root
38 : character(len=:), allocatable, intent(out) :: output
39 : logical, intent(in), optional :: pretty
40 :
41 88 : logical :: do_pretty
42 88 : character(len=:), allocatable :: buf
43 88 : integer :: buf_len, buf_cap
44 :
45 88 : do_pretty = .true.
46 8 : if (present(pretty)) do_pretty = pretty
47 :
48 88 : buf_cap = 4096
49 88 : allocate(character(len=buf_cap) :: buf)
50 88 : buf_len = 0
51 :
52 88 : call write_table(root, buf, buf_len, buf_cap, 0, do_pretty)
53 88 : call append_newline(buf, buf_len, buf_cap, do_pretty)
54 :
55 88 : output = buf(1:buf_len)
56 :
57 176 : end subroutine json_dump_to_string
58 :
59 : !> Dump an hsd_table tree to a JSON file.
60 7 : subroutine json_dump_file(root, filename, error, pretty)
61 : type(hsd_table), intent(in) :: root
62 : character(len=*), intent(in) :: filename
63 : type(hsd_error_t), allocatable, intent(out), optional :: error
64 : logical, intent(in), optional :: pretty
65 :
66 7 : character(len=:), allocatable :: output
67 7 : integer :: unit_num, ios
68 :
69 7 : call json_dump_to_string(root, output, pretty)
70 :
71 : open(newunit=unit_num, file=filename, status="replace", action="write", &
72 7 : & iostat=ios)
73 7 : if (ios /= 0) then
74 0 : if (present(error)) then
75 0 : allocate(error)
76 0 : error%code = HSD_STAT_IO_ERROR
77 0 : error%message = "Failed to open file for writing: " // trim(filename)
78 : end if
79 0 : return
80 : end if
81 7 : write(unit_num, "(a)", iostat=ios) output
82 7 : close(unit_num)
83 :
84 7 : if (ios /= 0 .and. present(error)) then
85 0 : allocate(error)
86 0 : error%code = HSD_STAT_IO_ERROR
87 0 : error%message = "Failed to write to file: " // trim(filename)
88 : end if
89 :
90 95 : end subroutine json_dump_file
91 :
92 : !> Write a table as a JSON object.
93 : !> Same-named children are grouped into JSON arrays to avoid duplicate keys.
94 522 : recursive subroutine write_table(table, buf, buf_len, buf_cap, depth, pretty)
95 : type(hsd_table), intent(in) :: table
96 : character(len=:), allocatable, intent(inout) :: buf
97 : integer, intent(inout) :: buf_len, buf_cap
98 : integer, intent(in) :: depth
99 : logical, intent(in) :: pretty
100 :
101 522 : integer :: ii, jj, member_count, name_count
102 522 : character(len=:), allocatable :: child_name
103 522 : logical, allocatable :: emitted(:)
104 :
105 522 : call append_str(buf, buf_len, buf_cap, "{")
106 522 : call append_newline(buf, buf_len, buf_cap, pretty)
107 :
108 522 : member_count = 0
109 :
110 : ! Track which children have been emitted (for duplicate-name grouping)
111 522 : allocate(emitted(table%num_children))
112 1347 : emitted = .false.
113 :
114 1347 : do ii = 1, table%num_children
115 825 : if (.not. associated(table%children(ii)%node)) cycle
116 825 : if (emitted(ii)) cycle
117 :
118 : ! Get this child's name
119 823 : child_name = get_child_name(table%children(ii)%node)
120 :
121 : ! Count how many children share this name
122 823 : name_count = 0
123 2131 : do jj = ii, table%num_children
124 1308 : if (.not. associated(table%children(jj)%node)) cycle
125 3439 : if (get_child_name(table%children(jj)%node) == child_name) then
126 2133 : name_count = name_count + 1
127 : end if
128 : end do
129 :
130 : ! Emit comma separator between members
131 823 : if (member_count > 0) then
132 302 : call append_str(buf, buf_len, buf_cap, ",")
133 302 : call append_newline(buf, buf_len, buf_cap, pretty)
134 : end if
135 :
136 1345 : if (name_count > 1) then
137 : ! Multiple children with same name → emit as JSON array
138 2 : call write_array_group(table, child_name, ii, emitted, &
139 2 : & buf, buf_len, buf_cap, depth + 1, pretty)
140 2 : member_count = member_count + 1
141 : else
142 : ! Single child → emit normally
143 821 : emitted(ii) = .true.
144 0 : select type (child => table%children(ii)%node)
145 : type is (hsd_table)
146 430 : call write_table_member(child, buf, buf_len, buf_cap, depth + 1, pretty)
147 430 : member_count = member_count + 1
148 :
149 : ! Emit attrib sibling if present
150 860 : if (allocated(child%attrib)) then
151 17 : if (len_trim(child%attrib) > 0) then
152 17 : call append_str(buf, buf_len, buf_cap, ",")
153 17 : call append_newline(buf, buf_len, buf_cap, pretty)
154 0 : call write_attrib_member(child%name, child%attrib, &
155 17 : & buf, buf_len, buf_cap, depth + 1, pretty)
156 17 : member_count = member_count + 1
157 : end if
158 : end if
159 :
160 : type is (hsd_value)
161 391 : call write_value_member(child, buf, buf_len, buf_cap, depth + 1, pretty)
162 391 : member_count = member_count + 1
163 :
164 : ! Emit attrib sibling if present
165 782 : if (allocated(child%attrib)) then
166 47 : if (len_trim(child%attrib) > 0) then
167 47 : call append_str(buf, buf_len, buf_cap, ",")
168 47 : call append_newline(buf, buf_len, buf_cap, pretty)
169 0 : call write_attrib_member(child%name, child%attrib, &
170 47 : & buf, buf_len, buf_cap, depth + 1, pretty)
171 47 : member_count = member_count + 1
172 : end if
173 : end if
174 : end select
175 : end if
176 : end do
177 :
178 522 : if (member_count > 0) then
179 521 : call append_newline(buf, buf_len, buf_cap, pretty)
180 : end if
181 522 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
182 522 : call append_str(buf, buf_len, buf_cap, "}")
183 :
184 529 : end subroutine write_table
185 :
186 : !> Get the effective name of a child node.
187 2135 : function get_child_name(node) result(name)
188 : class(hsd_node), intent(in) :: node
189 : character(len=:), allocatable :: name
190 :
191 : select type (node)
192 : type is (hsd_table)
193 1169 : if (allocated(node%name)) then
194 1169 : if (len_trim(node%name) > 0) then
195 1169 : name = node%name
196 : else
197 0 : name = ANON_VALUE_KEY
198 : end if
199 : else
200 0 : name = ANON_VALUE_KEY
201 : end if
202 : type is (hsd_value)
203 966 : if (allocated(node%name)) then
204 966 : if (len_trim(node%name) > 0) then
205 940 : name = node%name
206 : else
207 26 : name = ANON_VALUE_KEY
208 : end if
209 : else
210 0 : name = ANON_VALUE_KEY
211 : end if
212 : class default
213 0 : name = ANON_VALUE_KEY
214 : end select
215 :
216 2135 : end function get_child_name
217 :
218 : !> Write all children with the given name as a JSON array.
219 : !> Marks each emitted child in the `emitted` array.
220 2 : recursive subroutine write_array_group(table, name, start_idx, emitted, &
221 : & buf, buf_len, buf_cap, depth, pretty)
222 : type(hsd_table), intent(in) :: table
223 : character(len=*), intent(in) :: name
224 : integer, intent(in) :: start_idx
225 : logical, intent(inout) :: emitted(:)
226 : character(len=:), allocatable, intent(inout) :: buf
227 : integer, intent(inout) :: buf_len, buf_cap
228 : integer, intent(in) :: depth
229 : logical, intent(in) :: pretty
230 :
231 2 : integer :: jj, arr_count
232 :
233 : ! Emit key
234 2 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
235 2 : call append_str(buf, buf_len, buf_cap, '"' // json_escape_string(name) // '":')
236 2 : if (pretty) call append_str(buf, buf_len, buf_cap, " ")
237 :
238 : ! Open array
239 2 : call append_str(buf, buf_len, buf_cap, "[")
240 2 : call append_newline(buf, buf_len, buf_cap, pretty)
241 :
242 2 : arr_count = 0
243 6 : do jj = start_idx, table%num_children
244 4 : if (.not. associated(table%children(jj)%node)) cycle
245 4 : if (get_child_name(table%children(jj)%node) /= name) cycle
246 :
247 4 : emitted(jj) = .true.
248 :
249 4 : if (arr_count > 0) then
250 2 : call append_str(buf, buf_len, buf_cap, ",")
251 2 : call append_newline(buf, buf_len, buf_cap, pretty)
252 : end if
253 :
254 0 : select type (child => table%children(jj)%node)
255 : type is (hsd_table)
256 4 : call write_indent(buf, buf_len, buf_cap, depth + 1, pretty)
257 4 : call write_table(child, buf, buf_len, buf_cap, depth + 1, pretty)
258 : type is (hsd_value)
259 0 : call write_indent(buf, buf_len, buf_cap, depth + 1, pretty)
260 0 : call write_value_content(child, buf, buf_len, buf_cap)
261 : end select
262 6 : arr_count = arr_count + 1
263 : end do
264 :
265 2 : call append_newline(buf, buf_len, buf_cap, pretty)
266 2 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
267 2 : call append_str(buf, buf_len, buf_cap, "]")
268 :
269 2 : end subroutine write_array_group
270 :
271 : !> Write a table child as "key": { ... }
272 430 : recursive subroutine write_table_member(table, buf, buf_len, buf_cap, &
273 : & depth, pretty)
274 : type(hsd_table), intent(in) :: table
275 : character(len=:), allocatable, intent(inout) :: buf
276 : integer, intent(inout) :: buf_len, buf_cap
277 : integer, intent(in) :: depth
278 : logical, intent(in) :: pretty
279 :
280 430 : character(len=:), allocatable :: key
281 :
282 430 : if (allocated(table%name)) then
283 430 : if (len_trim(table%name) > 0) then
284 430 : key = table%name
285 : else
286 0 : key = ANON_VALUE_KEY
287 : end if
288 : else
289 0 : key = ANON_VALUE_KEY
290 : end if
291 :
292 430 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
293 430 : call append_str(buf, buf_len, buf_cap, '"' // json_escape_string(key) // '":')
294 430 : if (pretty) call append_str(buf, buf_len, buf_cap, " ")
295 430 : call write_table(table, buf, buf_len, buf_cap, depth, pretty)
296 :
297 430 : end subroutine write_table_member
298 :
299 : !> Write a value child as "key": value
300 391 : subroutine write_value_member(val, buf, buf_len, buf_cap, depth, pretty)
301 : type(hsd_value), intent(in) :: val
302 : character(len=:), allocatable, intent(inout) :: buf
303 : integer, intent(inout) :: buf_len, buf_cap
304 : integer, intent(in) :: depth
305 : logical, intent(in) :: pretty
306 :
307 391 : character(len=:), allocatable :: key
308 :
309 391 : if (allocated(val%name)) then
310 391 : if (len_trim(val%name) > 0) then
311 378 : key = val%name
312 : else
313 13 : key = ANON_VALUE_KEY
314 : end if
315 : else
316 0 : key = ANON_VALUE_KEY
317 : end if
318 :
319 391 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
320 391 : call append_str(buf, buf_len, buf_cap, '"' // json_escape_string(key) // '":')
321 391 : if (pretty) call append_str(buf, buf_len, buf_cap, " ")
322 391 : call write_value_content(val, buf, buf_len, buf_cap)
323 :
324 391 : end subroutine write_value_member
325 :
326 : !> Write an attribute as a sibling member "name__attrib": "value"
327 64 : subroutine write_attrib_member(name, attrib, buf, buf_len, buf_cap, &
328 : & depth, pretty)
329 : character(len=*), intent(in) :: name
330 : character(len=*), intent(in) :: attrib
331 : character(len=:), allocatable, intent(inout) :: buf
332 : integer, intent(inout) :: buf_len, buf_cap
333 : integer, intent(in) :: depth
334 : logical, intent(in) :: pretty
335 :
336 64 : character(len=:), allocatable :: key
337 :
338 64 : if (len_trim(name) > 0) then
339 64 : key = name // ATTRIB_SUFFIX
340 : else
341 0 : key = ANON_VALUE_KEY // ATTRIB_SUFFIX
342 : end if
343 :
344 64 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
345 : call append_str(buf, buf_len, buf_cap, &
346 64 : & '"' // json_escape_string(key) // '":')
347 64 : if (pretty) call append_str(buf, buf_len, buf_cap, " ")
348 : call append_str(buf, buf_len, buf_cap, &
349 64 : & '"' // json_escape_string(attrib) // '"')
350 :
351 455 : end subroutine write_attrib_member
352 :
353 : !> Write a value's content (number, string, boolean, complex, null).
354 391 : subroutine write_value_content(val, buf, buf_len, buf_cap)
355 : type(hsd_value), intent(in) :: val
356 : character(len=:), allocatable, intent(inout) :: buf
357 : integer, intent(inout) :: buf_len, buf_cap
358 :
359 : character(len=64) :: num_buf
360 :
361 392 : select case (val%value_type)
362 : case (VALUE_TYPE_INTEGER)
363 1 : write(num_buf, "(i0)") val%int_value
364 1 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
365 :
366 : case (VALUE_TYPE_REAL)
367 0 : call format_real(val%real_value, num_buf)
368 0 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
369 :
370 : case (VALUE_TYPE_LOGICAL)
371 0 : if (val%logical_value) then
372 0 : call append_str(buf, buf_len, buf_cap, "true")
373 : else
374 0 : call append_str(buf, buf_len, buf_cap, "false")
375 : end if
376 :
377 : case (VALUE_TYPE_COMPLEX)
378 1 : write(num_buf, "(a)") "{"
379 1 : call append_str(buf, buf_len, buf_cap, trim(num_buf))
380 1 : call append_str(buf, buf_len, buf_cap, '"re":')
381 1 : call format_real(real(val%complex_value, dp), num_buf)
382 1 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
383 1 : call append_str(buf, buf_len, buf_cap, ',"im":')
384 1 : call format_real(aimag(val%complex_value), num_buf)
385 1 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
386 1 : call append_str(buf, buf_len, buf_cap, "}")
387 :
388 : case (VALUE_TYPE_ARRAY)
389 52 : call write_array_value(val, buf, buf_len, buf_cap)
390 :
391 : case (VALUE_TYPE_STRING)
392 674 : if (allocated(val%string_value)) then
393 : ! Sniff whether the string looks like a JSON primitive so that
394 : ! HSD-originating trees (which store everything as strings) emit
395 : ! proper unquoted JSON numbers and booleans.
396 460 : if (looks_like_json_number(val%string_value)) then
397 123 : call append_str(buf, buf_len, buf_cap, val%string_value)
398 214 : else if (is_hsd_boolean(val%string_value)) then
399 : call append_str(buf, buf_len, buf_cap, &
400 55 : & hsd_bool_to_json(val%string_value))
401 : else
402 : call append_str(buf, buf_len, buf_cap, &
403 159 : & '"' // json_escape_string(val%string_value) // '"')
404 : end if
405 : else
406 0 : call append_str(buf, buf_len, buf_cap, '""')
407 : end if
408 :
409 : case (VALUE_TYPE_NONE)
410 : ! Try string_value, fall back to null
411 0 : if (allocated(val%string_value)) then
412 0 : if (len(val%string_value) > 0) then
413 : call append_str(buf, buf_len, buf_cap, &
414 0 : & '"' // json_escape_string(val%string_value) // '"')
415 : else
416 0 : call append_str(buf, buf_len, buf_cap, "null")
417 : end if
418 : else
419 0 : call append_str(buf, buf_len, buf_cap, "null")
420 : end if
421 :
422 : case default
423 : ! Unknown type: emit as string if available
424 0 : if (allocated(val%string_value)) then
425 : call append_str(buf, buf_len, buf_cap, &
426 0 : & '"' // json_escape_string(val%string_value) // '"')
427 : else
428 0 : call append_str(buf, buf_len, buf_cap, "null")
429 : end if
430 : end select
431 :
432 64 : end subroutine write_value_content
433 :
434 : !> Write an array value as a JSON array.
435 : !> Single-line text → flat array: [1, 2, 3]
436 : !> Multi-line text → nested arrays: [[1, 2, 3], [4, 5, 6]]
437 52 : subroutine write_array_value(val, buf, buf_len, buf_cap)
438 : type(hsd_value), intent(in) :: val
439 : character(len=:), allocatable, intent(inout) :: buf
440 : integer, intent(inout) :: buf_len, buf_cap
441 :
442 52 : character(len=:), allocatable :: text
443 52 : integer :: ii, nlines, line_start, line_end
444 52 : logical :: has_newlines, is_nl
445 :
446 52 : if (allocated(val%string_value)) then
447 52 : text = val%string_value
448 0 : else if (allocated(val%raw_text)) then
449 0 : text = val%raw_text
450 : else
451 0 : call append_str(buf, buf_len, buf_cap, "[]")
452 0 : return
453 : end if
454 :
455 52 : if (len_trim(text) == 0) then
456 0 : call append_str(buf, buf_len, buf_cap, "[]")
457 0 : return
458 : end if
459 :
460 : ! Check for newlines (indicates matrix / multi-row data)
461 52 : has_newlines = .false.
462 1838 : do ii = 1, len(text)
463 1838 : if (text(ii:ii) == new_line("a")) then
464 29 : has_newlines = .true.
465 29 : exit
466 : end if
467 : end do
468 :
469 75 : if (has_newlines) then
470 : ! Matrix: emit as nested arrays [[...], [...], ...]
471 29 : call append_str(buf, buf_len, buf_cap, "[")
472 29 : line_start = 1
473 29 : nlines = 0
474 1081 : do ii = 1, len(text) + 1
475 : ! Guard against out-of-bounds (gfortran evaluates both sides of .or.)
476 1052 : if (ii > len(text)) then
477 29 : is_nl = .true.
478 : else
479 1023 : is_nl = (text(ii:ii) == new_line("a"))
480 : end if
481 1081 : if (is_nl) then
482 72 : line_end = ii - 1
483 72 : if (line_start <= line_end .and. len_trim(text(line_start:line_end)) > 0) then
484 72 : if (nlines > 0) call append_str(buf, buf_len, buf_cap, ",")
485 72 : call write_tokens_as_array(text(line_start:line_end), buf, buf_len, buf_cap)
486 72 : nlines = nlines + 1
487 : end if
488 72 : line_start = ii + 1
489 : end if
490 : end do
491 29 : call append_str(buf, buf_len, buf_cap, "]")
492 : else
493 : ! Flat array: emit as [t1, t2, ...]
494 23 : call write_tokens_as_array(text, buf, buf_len, buf_cap)
495 : end if
496 :
497 443 : end subroutine write_array_value
498 :
499 : !> Write space-separated tokens as a JSON array: [t1, t2, ...]
500 : !> Tokens that look like numbers are emitted unquoted; others as strings.
501 95 : subroutine write_tokens_as_array(line, buf, buf_len, buf_cap)
502 : character(len=*), intent(in) :: line
503 : character(len=:), allocatable, intent(inout) :: buf
504 : integer, intent(inout) :: buf_len, buf_cap
505 :
506 95 : integer :: ii, tok_start, tok_count
507 95 : logical :: in_token, is_sep
508 95 : character(len=:), allocatable :: token
509 :
510 95 : call append_str(buf, buf_len, buf_cap, "[")
511 95 : tok_count = 0
512 95 : in_token = .false.
513 95 : tok_start = 1
514 :
515 2573 : do ii = 1, len(line) + 1
516 : ! Check if current position is a separator (or past end of string)
517 2478 : if (ii > len(line)) then
518 95 : is_sep = .true.
519 : else
520 4766 : is_sep = (line(ii:ii) == " " .or. line(ii:ii) == achar(9) &
521 7149 : & .or. line(ii:ii) == ",")
522 : end if
523 :
524 2573 : if (is_sep) then
525 404 : if (in_token) then
526 350 : token = line(tok_start:ii - 1)
527 350 : if (tok_count > 0) call append_str(buf, buf_len, buf_cap, ",")
528 680 : if (looks_like_json_number(token)) then
529 330 : call append_str(buf, buf_len, buf_cap, token)
530 20 : else if (is_hsd_boolean(token)) then
531 0 : call append_str(buf, buf_len, buf_cap, hsd_bool_to_json(token))
532 : else
533 : call append_str(buf, buf_len, buf_cap, &
534 20 : & '"' // json_escape_string(token) // '"')
535 : end if
536 350 : tok_count = tok_count + 1
537 350 : in_token = .false.
538 : end if
539 : else
540 2074 : if (.not. in_token) then
541 350 : tok_start = ii
542 350 : in_token = .true.
543 : end if
544 : end if
545 : end do
546 95 : call append_str(buf, buf_len, buf_cap, "]")
547 :
548 147 : end subroutine write_tokens_as_array
549 :
550 : !> Format a real number for JSON (no trailing zeros, always has decimal).
551 2 : subroutine format_real(rval, buf)
552 : real(dp), intent(in) :: rval
553 : character(len=64), intent(out) :: buf
554 :
555 2 : integer :: dot_pos, last_nonzero
556 :
557 : ! Use G0 for compact output (fixed or scientific as appropriate)
558 2 : write(buf, "(g0)") rval
559 2 : buf = adjustl(buf)
560 :
561 : ! Ensure there is always a decimal point (JSON requires it for reals)
562 2 : dot_pos = index(buf, ".")
563 2 : if (dot_pos == 0 .and. scan(buf, "eEdD") == 0) then
564 0 : buf = trim(buf) // ".0"
565 0 : return
566 : end if
567 :
568 2 : if (dot_pos == 0) return
569 :
570 : ! Find 'E' or 'e' for exponent
571 2 : last_nonzero = scan(buf, "eE") - 1
572 2 : if (last_nonzero < dot_pos) last_nonzero = len_trim(buf)
573 :
574 : ! Strip trailing zeros before exponent (keep at least one after dot)
575 17 : do while (last_nonzero > dot_pos + 1 .and. buf(last_nonzero:last_nonzero) == "0")
576 15 : last_nonzero = last_nonzero - 1
577 : end do
578 :
579 : ! Reconstruct: number part + exponent part
580 2 : if (scan(buf, "eE") > 0) then
581 0 : buf = buf(1:last_nonzero) // buf(scan(buf, "eE"):len_trim(buf))
582 : else
583 2 : buf = buf(1:last_nonzero)
584 : end if
585 :
586 97 : end subroutine format_real
587 :
588 : ! ─── String sniffing helpers (for HSD-originating VALUE_TYPE_STRING) ───
589 :
590 : !> Check if a string looks like a JSON number (integer or real).
591 687 : pure function looks_like_json_number(str) result(is_num)
592 : character(len=*), intent(in) :: str
593 : logical :: is_num
594 :
595 687 : integer :: ii, slen
596 :
597 687 : is_num = .false.
598 687 : slen = len_trim(str)
599 1 : if (slen == 0) return
600 :
601 686 : ii = 1
602 : ! Optional minus
603 686 : if (str(ii:ii) == "-") then
604 6 : ii = ii + 1
605 6 : if (ii > slen) return
606 : end if
607 :
608 : ! Must start with a digit
609 686 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") return
610 :
611 : ! Integer part
612 1149 : do while (ii <= slen)
613 1011 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
614 633 : ii = ii + 1
615 : end do
616 :
617 : ! Optional fraction
618 516 : if (ii <= slen) then
619 378 : if (str(ii:ii) == ".") then
620 335 : ii = ii + 1
621 335 : if (ii > slen .or. str(ii:ii) < "0" .or. str(ii:ii) > "9") return
622 2221 : do while (ii <= slen)
623 1914 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
624 1886 : ii = ii + 1
625 : end do
626 : end if
627 : end if
628 :
629 : ! Optional exponent
630 516 : if (ii <= slen) then
631 71 : if (str(ii:ii) == "e" .or. str(ii:ii) == "E") then
632 8 : ii = ii + 1
633 8 : if (ii <= slen .and. (str(ii:ii) == "+" .or. str(ii:ii) == "-")) &
634 8 : & ii = ii + 1
635 8 : if (ii > slen .or. str(ii:ii) < "0" .or. str(ii:ii) > "9") return
636 16 : do while (ii <= slen)
637 8 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
638 8 : ii = ii + 1
639 : end do
640 : end if
641 : end if
642 :
643 516 : is_num = (ii > slen)
644 :
645 689 : end function looks_like_json_number
646 :
647 : !> Check if a string is an HSD boolean (Yes/No, True/False, .true./.false.)
648 234 : pure function is_hsd_boolean(str) result(is_bool)
649 : character(len=*), intent(in) :: str
650 : logical :: is_bool
651 :
652 234 : character(len=:), allocatable :: lower
653 234 : integer :: ii
654 :
655 234 : is_bool = .false.
656 :
657 234 : allocate(character(len=len_trim(str)) :: lower)
658 661589 : do ii = 1, len_trim(str)
659 661589 : if (str(ii:ii) >= "A" .and. str(ii:ii) <= "Z") then
660 124 : lower(ii:ii) = achar(iachar(str(ii:ii)) + 32)
661 : else
662 661231 : lower(ii:ii) = str(ii:ii)
663 : end if
664 : end do
665 :
666 : is_bool = (lower == "yes" .or. lower == "no" .or. lower == "true" &
667 234 : & .or. lower == "false" .or. lower == ".true." .or. lower == ".false.")
668 :
669 921 : end function is_hsd_boolean
670 :
671 : !> Convert an HSD boolean string to JSON "true"/"false".
672 55 : pure function hsd_bool_to_json(str) result(json)
673 : character(len=*), intent(in) :: str
674 : character(len=:), allocatable :: json
675 :
676 55 : character(len=:), allocatable :: lower
677 55 : integer :: ii
678 :
679 55 : allocate(character(len=len_trim(str)) :: lower)
680 213 : do ii = 1, len_trim(str)
681 213 : if (str(ii:ii) >= "A" .and. str(ii:ii) <= "Z") then
682 55 : lower(ii:ii) = achar(iachar(str(ii:ii)) + 32)
683 : else
684 103 : lower(ii:ii) = str(ii:ii)
685 : end if
686 : end do
687 :
688 55 : if (lower == "yes" .or. lower == "true" .or. lower == ".true.") then
689 48 : json = "true"
690 : else
691 7 : json = "false"
692 : end if
693 :
694 289 : end function hsd_bool_to_json
695 :
696 : ! ─── Buffer utilities (same pattern as XML writer) ───
697 :
698 5952 : subroutine append_str(buf, buf_len, buf_cap, str)
699 : character(len=:), allocatable, intent(inout) :: buf
700 : integer, intent(inout) :: buf_len, buf_cap
701 : character(len=*), intent(in) :: str
702 :
703 5952 : integer :: slen
704 :
705 5952 : slen = len(str)
706 5952 : call ensure_capacity(buf, buf_len, buf_cap, slen)
707 5952 : buf(buf_len + 1:buf_len + slen) = str
708 5952 : buf_len = buf_len + slen
709 :
710 55 : end subroutine append_str
711 :
712 1503 : subroutine append_newline(buf, buf_len, buf_cap, pretty)
713 : character(len=:), allocatable, intent(inout) :: buf
714 : integer, intent(inout) :: buf_len, buf_cap
715 : logical, intent(in) :: pretty
716 :
717 1475 : if (pretty) call append_str(buf, buf_len, buf_cap, new_line("a"))
718 :
719 5952 : end subroutine append_newline
720 :
721 1415 : subroutine write_indent(buf, buf_len, buf_cap, depth, pretty)
722 : character(len=:), allocatable, intent(inout) :: buf
723 : integer, intent(inout) :: buf_len, buf_cap
724 : integer, intent(in) :: depth
725 : logical, intent(in) :: pretty
726 :
727 1415 : integer :: spaces
728 :
729 26 : if (.not. pretty) return
730 1389 : spaces = depth * INDENT_WIDTH
731 1389 : if (spaces > 0) then
732 1303 : call ensure_capacity(buf, buf_len, buf_cap, spaces)
733 35435 : buf(buf_len + 1:buf_len + spaces) = repeat(" ", spaces)
734 1303 : buf_len = buf_len + spaces
735 : end if
736 :
737 2918 : end subroutine write_indent
738 :
739 7255 : subroutine ensure_capacity(buf, buf_len, buf_cap, needed)
740 : character(len=:), allocatable, intent(inout) :: buf
741 : integer, intent(in) :: buf_len, needed
742 : integer, intent(inout) :: buf_cap
743 :
744 7255 : character(len=:), allocatable :: tmp
745 7255 : integer :: new_cap
746 :
747 7255 : if (buf_len + needed <= buf_cap) return
748 :
749 5 : new_cap = buf_cap * 2
750 16 : do while (buf_len + needed > new_cap)
751 11 : new_cap = new_cap * 2
752 : end do
753 :
754 5 : allocate(character(len=new_cap) :: tmp)
755 5 : tmp(1:buf_len) = buf(1:buf_len)
756 5 : call move_alloc(tmp, buf)
757 5 : buf_cap = new_cap
758 :
759 8670 : end subroutine ensure_capacity
760 :
761 2960 : end module hsd_data_json_writer
|
