Line data Source code
1 : !> HSD Formatter/Serializer
2 : !>
3 : !> This module provides functionality to write HSD data structures back to
4 : !> text format.
5 : module hsd_formatter
6 : use hsd_constants, only: dp, CHAR_NEWLINE, CHAR_DQUOTE, CHAR_SQUOTE, CHAR_BACKSLASH
7 : use hsd_types, only: hsd_node_t, hsd_iterator_t, &
8 : NODE_TYPE_TABLE, NODE_TYPE_VALUE, &
9 : VALUE_TYPE_NONE, VALUE_TYPE_ARRAY, VALUE_TYPE_STRING, &
10 : VALUE_TYPE_INTEGER, VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_COMPLEX
11 : use hsd_error, only: hsd_error_t, HSD_STAT_OK, HSD_STAT_IO_ERROR, make_error
12 : use hsd_utils, only: string_buffer_t
13 : implicit none (type, external)
14 : private
15 :
16 : public :: hsd_dump, hsd_dump_to_string
17 :
18 : !> Indentation string (2 spaces)
19 : character(len=*), parameter :: INDENT_STR = " "
20 :
21 : !> Characters that require quoting
22 : character(len=*), parameter :: QUOTE_TRIGGER_CHARS = "{}[]= <>" // char(9)
23 :
24 : contains
25 :
26 : !> Check whether a node name is anonymous (unset, blank, or "#text")
27 : !>
28 : !> Uses nested if-blocks to avoid non-short-circuit .and./.or. evaluation
29 : !> that can access unallocated allocatable components.
30 1135 : pure function is_anon_name_(name) result(res)
31 : character(len=:), allocatable, intent(in) :: name
32 : logical :: res
33 :
34 1135 : res = .true.
35 1135 : if (allocated(name)) then
36 1134 : if (len_trim(name) > 0 .and. name /= "#text") then
37 1125 : res = .false.
38 : end if
39 : end if
40 :
41 1135 : end function is_anon_name_
42 :
43 : !> Safely retrieve a node name, returning empty string if unallocated
44 14 : pure function safe_name_(name) result(res)
45 : character(len=:), allocatable, intent(in) :: name
46 : character(len=:), allocatable :: res
47 :
48 14 : if (allocated(name)) then
49 14 : res = name
50 : else
51 0 : res = ""
52 : end if
53 :
54 1135 : end function safe_name_
55 :
56 : !> Check whether a node has a non-blank name
57 : !>
58 : !> Uses nested if to avoid non-short-circuit access to unallocated name.
59 45 : pure function has_name_(name) result(res)
60 : character(len=:), allocatable, intent(in) :: name
61 : logical :: res
62 :
63 45 : res = .false.
64 45 : if (allocated(name)) then
65 43 : if (len_trim(name) > 0) res = .true.
66 : end if
67 :
68 59 : end function has_name_
69 :
70 : !> Write HSD table to a file
71 23 : subroutine hsd_dump(root, filename, error)
72 : type(hsd_node_t), intent(in) :: root
73 : character(len=*), intent(in) :: filename
74 : type(hsd_error_t), allocatable, intent(out), optional :: error
75 :
76 23 : integer :: unit_num, io_stat
77 : character(len=256) :: io_msg
78 :
79 : open(newunit=unit_num, file=filename, status='replace', action='write', &
80 23 : iostat=io_stat, iomsg=io_msg)
81 23 : if (io_stat /= 0) then
82 1 : if (present(error)) then
83 : call make_error(error, HSD_STAT_IO_ERROR, &
84 1 : "Cannot open file for writing: " // trim(io_msg), filename)
85 : end if
86 1 : return
87 : end if
88 :
89 22 : call write_table_content(unit_num, root, 0)
90 :
91 22 : close(unit_num)
92 :
93 68 : end subroutine hsd_dump
94 :
95 : !> Write HSD table to a string (dynamically allocated)
96 : !>
97 : !> Uses string_buffer_t internally to avoid O(n²) concatenation.
98 43 : subroutine hsd_dump_to_string(root, output)
99 : type(hsd_node_t), intent(in) :: root
100 : character(len=:), allocatable, intent(out) :: output
101 :
102 43 : type(string_buffer_t) :: buf
103 :
104 43 : call buf%init()
105 43 : call write_table_to_string_buf(root, 0, buf)
106 43 : output = buf%get_string()
107 :
108 66 : end subroutine hsd_dump_to_string
109 :
110 : !> Write table contents to unit
111 47 : recursive subroutine write_table_content(unit_num, table, indent_level)
112 : integer, intent(in) :: unit_num
113 : type(hsd_node_t), intent(in) :: table
114 : integer, intent(in) :: indent_level
115 :
116 47 : integer :: i
117 : type(hsd_node_t), pointer :: child
118 47 : character(len=:), allocatable :: indent
119 :
120 81 : indent = repeat(INDENT_STR, indent_level)
121 :
122 133 : do i = 1, table%num_children
123 86 : call table%get_child(i, child)
124 86 : if (.not. associated(child)) cycle
125 :
126 162 : if (child%node_type == NODE_TYPE_TABLE) then
127 29 : call write_table_node(unit_num, child, indent_level)
128 114 : else if (child%node_type == NODE_TYPE_VALUE) then
129 57 : call write_value_node(unit_num, child, indent_level)
130 : end if
131 : end do
132 :
133 90 : end subroutine write_table_content
134 :
135 : !> Write a table node
136 29 : recursive subroutine write_table_node(unit_num, table, indent_level)
137 : integer, intent(in) :: unit_num
138 : type(hsd_node_t), intent(in) :: table
139 : integer, intent(in) :: indent_level
140 :
141 29 : character(len=:), allocatable :: indent, attrib_str
142 :
143 40 : indent = repeat(INDENT_STR, indent_level)
144 :
145 : ! Build attribute string
146 29 : if (table%has_attrib()) then
147 1 : attrib_str = " [" // table%get_attrib() // "]"
148 : else
149 28 : attrib_str = ""
150 : end if
151 :
152 : ! Check if table has single child (for = syntax)
153 29 : if (table%num_children == 1) then
154 : block
155 : type(hsd_node_t), pointer :: single_child
156 17 : call table%get_child(1, single_child)
157 :
158 17 : if (single_child%node_type == NODE_TYPE_TABLE) then
159 : ! Tag = ChildTag { ... }
160 9 : if (has_name_(table%name)) then
161 : write(unit_num, '(A)') indent // trim(table%name) // attrib_str // &
162 8 : " = " // trim(safe_name_(single_child%name)) // " {"
163 8 : call write_table_content(unit_num, single_child, indent_level + 1)
164 8 : write(unit_num, '(A)') indent // "}"
165 : else
166 : ! Unnamed table, just write children
167 1 : call write_table_content(unit_num, table, indent_level)
168 : end if
169 13 : return
170 :
171 8 : else if (single_child%node_type == NODE_TYPE_VALUE) then
172 : ! Tag = value (for unnamed/anonymous or #text-named children)
173 8 : if (is_anon_name_(single_child%name)) then
174 8 : if (has_name_(table%name)) then
175 3 : call write_tag_value(unit_num, table%name, attrib_str, &
176 6 : single_child, indent_level)
177 : else
178 1 : call write_value_node(unit_num, single_child, indent_level)
179 : end if
180 4 : return
181 : end if
182 : ! Named child — fall through to regular block
183 : end if
184 : end block
185 : end if
186 :
187 : ! Regular block: Tag { ... }
188 16 : if (has_name_(table%name)) then
189 15 : write(unit_num, '(A)') indent // trim(table%name) // attrib_str // " {"
190 15 : call write_table_content(unit_num, table, indent_level + 1)
191 15 : write(unit_num, '(A)') indent // "}"
192 : else
193 : ! Root or unnamed table - just write content
194 1 : call write_table_content(unit_num, table, indent_level)
195 : end if
196 :
197 29 : end subroutine write_table_node
198 :
199 : !> Write a value node
200 58 : subroutine write_value_node(unit_num, val, indent_level)
201 : integer, intent(in) :: unit_num
202 : type(hsd_node_t), intent(in) :: val
203 : integer, intent(in) :: indent_level
204 :
205 58 : character(len=:), allocatable :: indent, attrib_str, value_str, raw_text
206 58 : logical :: is_anonymous
207 :
208 118 : indent = repeat(INDENT_STR, indent_level)
209 :
210 : ! Build attribute string
211 58 : if (val%has_attrib()) then
212 2 : attrib_str = " [" // val%get_attrib() // "]"
213 : else
214 56 : attrib_str = ""
215 : end if
216 :
217 : ! Treat #text-named values as anonymous (inline content)
218 58 : is_anonymous = is_anon_name_(val%name)
219 :
220 : ! For anonymous values with multiline raw text, use unquoted format
221 58 : if (is_anonymous) then
222 : ! Check for raw text with newlines (block content like GenFormat data)
223 3 : raw_text = get_raw_text_(val)
224 5 : if (index(raw_text, CHAR_NEWLINE) > 0) then
225 2 : call write_multiline(unit_num, raw_text, indent_level)
226 2 : return
227 : end if
228 : end if
229 :
230 : ! Get value string (may quote/escape)
231 56 : value_str = format_value(val)
232 :
233 : ! Write
234 56 : if (.not. is_anonymous) then
235 55 : if (index(value_str, CHAR_NEWLINE) > 0) then
236 : ! Multi-line value
237 0 : write(unit_num, '(A)') indent // trim(val%name) // attrib_str // " {"
238 0 : call write_multiline(unit_num, value_str, indent_level + 1)
239 0 : write(unit_num, '(A)') indent // "}"
240 : else
241 : ! Single-line value
242 55 : write(unit_num, '(A)') indent // trim(val%name) // attrib_str // " = " // value_str
243 : end if
244 : else
245 : ! Anonymous value (data content)
246 1 : if (index(value_str, CHAR_NEWLINE) > 0) then
247 0 : call write_multiline(unit_num, value_str, indent_level)
248 : else
249 1 : write(unit_num, '(A)') indent // value_str
250 : end if
251 : end if
252 :
253 58 : end subroutine write_value_node
254 :
255 : !> Write tag = value
256 3 : subroutine write_tag_value(unit_num, name, attrib_str, val, indent_level)
257 : integer, intent(in) :: unit_num
258 : character(len=*), intent(in) :: name
259 : character(len=*), intent(in) :: attrib_str
260 : type(hsd_node_t), intent(in) :: val
261 : integer, intent(in) :: indent_level
262 :
263 3 : character(len=:), allocatable :: indent, value_str, val_attrib, raw_text
264 :
265 3 : indent = repeat(INDENT_STR, indent_level)
266 :
267 : ! Combine attributes
268 3 : if (val%has_attrib()) then
269 1 : val_attrib = " [" // val%get_attrib() // "]"
270 : else
271 2 : val_attrib = attrib_str
272 : end if
273 :
274 : ! Check for multiline raw text first (e.g. GenFormat data) — use unquoted format
275 3 : raw_text = get_raw_text_(val)
276 3 : if (index(raw_text, CHAR_NEWLINE) > 0) then
277 1 : write(unit_num, '(A)') indent // trim(name) // val_attrib // " {"
278 1 : call write_multiline(unit_num, raw_text, indent_level + 1)
279 1 : write(unit_num, '(A)') indent // "}"
280 1 : return
281 : end if
282 :
283 2 : value_str = format_value(val)
284 :
285 2 : if (index(value_str, CHAR_NEWLINE) > 0) then
286 : ! Multi-line value
287 0 : write(unit_num, '(A)') indent // trim(name) // val_attrib // " {"
288 0 : call write_multiline(unit_num, value_str, indent_level + 1)
289 0 : write(unit_num, '(A)') indent // "}"
290 : else
291 2 : write(unit_num, '(A)') indent // trim(name) // val_attrib // " = " // value_str
292 : end if
293 :
294 61 : end subroutine write_tag_value
295 :
296 : !> Write multi-line content
297 3 : subroutine write_multiline(unit_num, text, indent_level)
298 : integer, intent(in) :: unit_num
299 : character(len=*), intent(in) :: text
300 : integer, intent(in) :: indent_level
301 :
302 3 : character(len=:), allocatable :: indent
303 3 : integer :: pos, next_pos, text_len
304 :
305 6 : indent = repeat(INDENT_STR, indent_level)
306 3 : text_len = len(text)
307 3 : pos = 1
308 :
309 13 : do while (pos <= text_len)
310 13 : next_pos = index(text(pos:), CHAR_NEWLINE)
311 13 : if (next_pos > 0) then
312 10 : next_pos = pos + next_pos - 1
313 10 : if (next_pos > pos) then
314 10 : write(unit_num, '(A)') indent // text(pos:next_pos-1)
315 : else
316 0 : write(unit_num, '(A)') ""
317 : end if
318 10 : pos = next_pos + 1
319 : else
320 3 : write(unit_num, '(A)') indent // text(pos:)
321 3 : exit
322 : end if
323 : end do
324 :
325 6 : end subroutine write_multiline
326 :
327 : !> Get raw text content from a value node (unquoted, with real newlines)
328 9 : function get_raw_text_(val) result(text)
329 : type(hsd_node_t), intent(in) :: val
330 : character(len=:), allocatable :: text
331 :
332 9 : if (allocated(val%string_value)) then
333 9 : text = val%string_value
334 : else
335 0 : text = ""
336 : end if
337 :
338 3 : end function get_raw_text_
339 :
340 : !> Format a value for output
341 1119 : function format_value(val) result(str)
342 : type(hsd_node_t), intent(in) :: val
343 : character(len=:), allocatable :: str
344 :
345 1119 : if (allocated(val%string_value)) then
346 1118 : str = quote_if_needed(val%string_value)
347 : else
348 1 : str = ""
349 : end if
350 :
351 9 : end function format_value
352 :
353 : !> Quote a string if it contains special characters.
354 : !>
355 : !> Newlines, backslashes, tabs, and quote characters are escaped so that
356 : !> the result is always a single-line quoted token that round-trips cleanly.
357 1118 : function quote_if_needed(str) result(quoted)
358 : character(len=*), intent(in) :: str
359 : character(len=:), allocatable :: quoted
360 :
361 1118 : logical :: needs_quote
362 1118 : integer :: i
363 : character(len=1) :: ch
364 :
365 1118 : needs_quote = .false.
366 6600 : do i = 1, len(str)
367 5509 : ch = str(i:i)
368 : if (index(QUOTE_TRIGGER_CHARS, ch) > 0 &
369 : & .or. ch == CHAR_NEWLINE &
370 : & .or. ch == CHAR_BACKSLASH &
371 : & .or. ch == CHAR_DQUOTE &
372 6600 : & .or. ch == CHAR_SQUOTE) then
373 27 : needs_quote = .true.
374 27 : exit
375 : end if
376 : end do
377 :
378 1118 : if (.not. needs_quote) then
379 1091 : quoted = str
380 : else
381 27 : quoted = CHAR_DQUOTE // escape_string(str) // CHAR_DQUOTE
382 : end if
383 :
384 1119 : end function quote_if_needed
385 :
386 : !> Escape special characters in a string for HSD quoted output.
387 : !>
388 : !> Handles: backslash, double-quote, newline, tab.
389 : !> Uses string_buffer_t to avoid O(n^2) concatenation.
390 27 : function escape_string(str) result(escaped)
391 : character(len=*), intent(in) :: str
392 : character(len=:), allocatable :: escaped
393 :
394 27 : type(string_buffer_t) :: buf
395 27 : integer :: i
396 : character(len=1) :: ch
397 :
398 27 : call buf%init()
399 417 : do i = 1, len(str)
400 390 : ch = str(i:i)
401 417 : if (ch == CHAR_BACKSLASH) then
402 1 : call buf%append_str(CHAR_BACKSLASH // CHAR_BACKSLASH)
403 389 : else if (ch == CHAR_DQUOTE) then
404 6 : call buf%append_str(CHAR_BACKSLASH // CHAR_DQUOTE)
405 383 : else if (ch == CHAR_NEWLINE) then
406 9 : call buf%append_str(CHAR_BACKSLASH // "n")
407 374 : else if (ch == char(9)) then
408 1 : call buf%append_str(CHAR_BACKSLASH // "t")
409 : else
410 373 : call buf%append_char(ch)
411 : end if
412 : end do
413 27 : escaped = buf%get_string()
414 :
415 1145 : end function escape_string
416 :
417 : !> Write table to string_buffer_t (for string output, avoids O(n²) concatenation)
418 : !>
419 : !> Mirrors the file-output path including the single-child `= ChildTag { }`
420 : !> and `Tag = value` shorthand syntax.
421 58 : recursive subroutine write_table_to_string_buf(table, indent_level, buf)
422 : type(hsd_node_t), intent(in) :: table
423 : integer, intent(in) :: indent_level
424 : type(string_buffer_t), intent(inout) :: buf
425 :
426 58 : integer :: i
427 : type(hsd_node_t), pointer :: child
428 58 : character(len=:), allocatable :: indent, attrib_str, line, value_str
429 :
430 76 : indent = repeat(INDENT_STR, indent_level)
431 :
432 1135 : do i = 1, table%num_children
433 1077 : call table%get_child(i, child)
434 1077 : if (.not. associated(child)) cycle
435 :
436 1151 : if (child%node_type == NODE_TYPE_TABLE) then
437 16 : call write_table_node_to_buf(child, indent_level, buf)
438 :
439 1061 : else if (child%node_type == NODE_TYPE_VALUE) then
440 1061 : block
441 1061 : logical :: is_anon
442 1061 : character(len=:), allocatable :: raw_text
443 :
444 1061 : if (child%has_attrib()) then
445 4 : attrib_str = " [" // child%get_attrib() // "]"
446 : else
447 1057 : attrib_str = ""
448 : end if
449 :
450 : ! Treat #text-named values as anonymous
451 1061 : is_anon = is_anon_name_(child%name)
452 :
453 2124 : if (is_anon) then
454 : ! Anonymous/inline content — check for multiline raw text first
455 2 : raw_text = get_raw_text_(child)
456 2 : if (index(raw_text, CHAR_NEWLINE) > 0) then
457 0 : call write_multiline_to_buf(raw_text, indent_level, buf)
458 : else
459 2 : value_str = format_value(child)
460 2 : if (index(value_str, CHAR_NEWLINE) > 0) then
461 0 : call write_multiline_to_buf(value_str, indent_level, buf)
462 : else
463 2 : line = indent // value_str
464 2 : call buf%append_str(line)
465 2 : call buf%append_str(CHAR_NEWLINE)
466 : end if
467 : end if
468 : else
469 1059 : value_str = format_value(child)
470 1059 : if (index(value_str, CHAR_NEWLINE) > 0) then
471 0 : call buf%append_str(indent // trim(child%name) // attrib_str // " {")
472 0 : call buf%append_str(CHAR_NEWLINE)
473 0 : call write_multiline_to_buf(value_str, indent_level + 1, buf)
474 0 : call buf%append_str(indent // "}")
475 0 : call buf%append_str(CHAR_NEWLINE)
476 : else
477 1059 : line = indent // trim(child%name) // attrib_str // " = " // value_str
478 1059 : call buf%append_str(line)
479 1059 : call buf%append_str(CHAR_NEWLINE)
480 : end if
481 : end if
482 : end block
483 : end if
484 : end do
485 :
486 85 : end subroutine write_table_to_string_buf
487 :
488 : !> Write a table node to string buffer with single-child shorthand
489 16 : recursive subroutine write_table_node_to_buf(table, indent_level, buf)
490 : type(hsd_node_t), intent(in) :: table
491 : integer, intent(in) :: indent_level
492 : type(string_buffer_t), intent(inout) :: buf
493 :
494 16 : character(len=:), allocatable :: indent, attrib_str, value_str, val_attrib
495 :
496 20 : indent = repeat(INDENT_STR, indent_level)
497 :
498 : ! Build attribute string
499 16 : if (table%has_attrib()) then
500 0 : attrib_str = " [" // table%get_attrib() // "]"
501 : else
502 16 : attrib_str = ""
503 : end if
504 :
505 : ! Check for single-child shorthand (= syntax)
506 16 : if (table%num_children == 1) then
507 : block
508 : type(hsd_node_t), pointer :: single_child
509 14 : call table%get_child(1, single_child)
510 :
511 14 : if (single_child%node_type == NODE_TYPE_TABLE) then
512 : ! Tag = ChildTag { ... }
513 6 : if (has_name_(table%name)) then
514 : call buf%append_str(indent // trim(table%name) // attrib_str // &
515 6 : " = " // trim(safe_name_(single_child%name)) // " {")
516 6 : call buf%append_str(CHAR_NEWLINE)
517 6 : call write_table_to_string_buf(single_child, indent_level + 1, buf)
518 6 : call buf%append_str(indent // "}")
519 6 : call buf%append_str(CHAR_NEWLINE)
520 : else
521 0 : call write_table_to_string_buf(table, indent_level, buf)
522 : end if
523 7 : return
524 :
525 8 : else if (single_child%node_type == NODE_TYPE_VALUE) then
526 : ! Tag = value (for unnamed/anonymous or #text-named children)
527 8 : if (is_anon_name_(single_child%name)) then
528 1 : if (has_name_(table%name)) then
529 1 : block
530 1 : character(len=:), allocatable :: raw_text
531 : ! Check for multiline raw text (e.g. GenFormat data)
532 1 : raw_text = get_raw_text_(single_child)
533 1 : if (single_child%has_attrib()) then
534 0 : val_attrib = " [" // single_child%get_attrib() // "]"
535 : else
536 1 : val_attrib = attrib_str
537 : end if
538 3 : if (index(raw_text, CHAR_NEWLINE) > 0) then
539 : ! Multiline content — write as block
540 1 : call buf%append_str(indent // trim(table%name) // val_attrib // " {")
541 1 : call buf%append_str(CHAR_NEWLINE)
542 1 : call write_multiline_to_buf(raw_text, indent_level + 1, buf)
543 1 : call buf%append_str(indent // "}")
544 1 : call buf%append_str(CHAR_NEWLINE)
545 : else
546 0 : value_str = format_value(single_child)
547 : call buf%append_str(indent // trim(table%name) // val_attrib // &
548 0 : " = " // value_str)
549 0 : call buf%append_str(CHAR_NEWLINE)
550 : end if
551 : end block
552 : else
553 0 : value_str = format_value(single_child)
554 0 : call buf%append_str(indent // value_str)
555 0 : call buf%append_str(CHAR_NEWLINE)
556 : end if
557 1 : return
558 : end if
559 : ! Named child — fall through to regular block
560 : end if
561 : end block
562 : end if
563 :
564 : ! Regular block: Tag { ... }
565 9 : if (has_name_(table%name)) then
566 8 : call buf%append_str(indent // trim(table%name) // attrib_str // " {")
567 8 : call buf%append_str(CHAR_NEWLINE)
568 8 : call write_table_to_string_buf(table, indent_level + 1, buf)
569 8 : call buf%append_str(indent // "}")
570 8 : call buf%append_str(CHAR_NEWLINE)
571 : else
572 1 : call write_table_to_string_buf(table, indent_level, buf)
573 : end if
574 :
575 16 : end subroutine write_table_node_to_buf
576 :
577 : !> Write multi-line content to string buffer
578 1 : subroutine write_multiline_to_buf(text, indent_level, buf)
579 : character(len=*), intent(in) :: text
580 : integer, intent(in) :: indent_level
581 : type(string_buffer_t), intent(inout) :: buf
582 :
583 1 : character(len=:), allocatable :: indent
584 1 : integer :: pos, next_pos, text_len
585 :
586 2 : indent = repeat(INDENT_STR, indent_level)
587 1 : text_len = len(text)
588 1 : pos = 1
589 :
590 3 : do while (pos <= text_len)
591 3 : next_pos = index(text(pos:), CHAR_NEWLINE)
592 3 : if (next_pos > 0) then
593 2 : next_pos = pos + next_pos - 1
594 2 : if (next_pos > pos) then
595 2 : call buf%append_str(indent // text(pos:next_pos-1))
596 : end if
597 2 : call buf%append_str(CHAR_NEWLINE)
598 2 : pos = next_pos + 1
599 : else
600 1 : call buf%append_str(indent // text(pos:))
601 1 : call buf%append_str(CHAR_NEWLINE)
602 1 : exit
603 : end if
604 : end do
605 :
606 2 : end subroutine write_multiline_to_buf
607 :
608 : end module hsd_formatter
|
