Line data Source code
1 : !> XML serializer: dump an hsd_table tree to well-formed XML 1.0.
2 : !>
3 : !> Uses custom recursive traversal (not hsd_accept) because XML needs
4 : !> closing tags emitted after children, which the visitor pattern does
5 : !> not support directly.
6 : module hsd_data_xml_writer
7 : use hsd, only: hsd_table, hsd_value, hsd_node, hsd_node_ptr, &
8 : & VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
9 : & VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, &
10 : & VALUE_TYPE_COMPLEX, hsd_error_t, dp, HSD_STAT_IO_ERROR
11 : use hsd_data_xml_escape, only: xml_escape_text, xml_escape_attrib
12 : implicit none(type, external)
13 : private
14 :
15 : public :: xml_dump_to_string, xml_dump_file
16 :
17 : !> Default indentation width
18 : integer, parameter :: INDENT_WIDTH = 2
19 :
20 : !> Prefix for non-unit attribute children
21 : character(len=*), parameter :: ATTR_PREFIX = "__attr_"
22 :
23 : contains
24 :
25 : !> Dump an hsd_table tree to an XML string.
26 60 : subroutine xml_dump_to_string(root, output, pretty)
27 : type(hsd_table), intent(in) :: root
28 : character(len=:), allocatable, intent(out) :: output
29 : logical, intent(in), optional :: pretty
30 :
31 60 : logical :: do_pretty
32 60 : character(len=:), allocatable :: buf
33 60 : integer :: buf_len, buf_cap
34 :
35 60 : do_pretty = .true.
36 7 : if (present(pretty)) do_pretty = pretty
37 :
38 : ! Start with XML declaration
39 60 : buf_cap = 4096
40 60 : allocate(character(len=buf_cap) :: buf)
41 60 : buf_len = 0
42 :
43 60 : call append_str(buf, buf_len, buf_cap, '<?xml version="1.0" encoding="UTF-8"?>')
44 60 : call append_newline(buf, buf_len, buf_cap, do_pretty)
45 :
46 : ! If root has a name, wrap in root element
47 60 : if (allocated(root%name)) then
48 4 : if (len_trim(root%name) > 0) then
49 0 : call write_table(root, buf, buf_len, buf_cap, 0, do_pretty)
50 : else
51 : ! Anonymous root: wrap in <root> document element for valid XML
52 4 : call append_str(buf, buf_len, buf_cap, "<root>")
53 4 : call append_newline(buf, buf_len, buf_cap, do_pretty)
54 4 : call write_children(root, buf, buf_len, buf_cap, 1, do_pretty)
55 4 : call append_str(buf, buf_len, buf_cap, "</root>")
56 4 : call append_newline(buf, buf_len, buf_cap, do_pretty)
57 : end if
58 : else
59 : ! Anonymous root: wrap in <root> document element for valid XML
60 56 : call append_str(buf, buf_len, buf_cap, "<root>")
61 56 : call append_newline(buf, buf_len, buf_cap, do_pretty)
62 56 : call write_children(root, buf, buf_len, buf_cap, 1, do_pretty)
63 56 : call append_str(buf, buf_len, buf_cap, "</root>")
64 56 : call append_newline(buf, buf_len, buf_cap, do_pretty)
65 : end if
66 :
67 60 : output = buf(1:buf_len)
68 :
69 120 : end subroutine xml_dump_to_string
70 :
71 : !> Dump an hsd_table tree to an XML file.
72 7 : subroutine xml_dump_file(root, filename, error, pretty)
73 : type(hsd_table), intent(in) :: root
74 : character(len=*), intent(in) :: filename
75 : type(hsd_error_t), allocatable, intent(out), optional :: error
76 : logical, intent(in), optional :: pretty
77 :
78 7 : character(len=:), allocatable :: output
79 7 : integer :: unit_num, ios
80 :
81 7 : call xml_dump_to_string(root, output, pretty)
82 :
83 : open(newunit=unit_num, file=filename, status="replace", action="write", &
84 7 : & iostat=ios)
85 7 : if (ios /= 0) then
86 0 : if (present(error)) then
87 0 : allocate(error)
88 0 : error%code = HSD_STAT_IO_ERROR
89 0 : error%message = "Failed to open file for writing: " // trim(filename)
90 : end if
91 0 : return
92 : end if
93 7 : write(unit_num, "(a)", iostat=ios) output
94 7 : close(unit_num)
95 :
96 7 : if (ios /= 0 .and. present(error)) then
97 0 : allocate(error)
98 0 : error%code = HSD_STAT_IO_ERROR
99 0 : error%message = "Failed to write to file: " // trim(filename)
100 : end if
101 :
102 67 : end subroutine xml_dump_file
103 :
104 : !> Write a table node as an XML element.
105 451 : recursive subroutine write_table(table, buf, buf_len, buf_cap, depth, pretty)
106 : type(hsd_table), intent(in) :: table
107 : character(len=:), allocatable, intent(inout) :: buf
108 : integer, intent(inout) :: buf_len, buf_cap
109 : integer, intent(in) :: depth
110 : logical, intent(in) :: pretty
111 :
112 451 : character(len=:), allocatable :: tag_name
113 :
114 451 : integer :: real_children
115 :
116 451 : tag_name = table%name
117 :
118 : ! Indent and open tag
119 451 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
120 451 : call append_str(buf, buf_len, buf_cap, "<" // tag_name)
121 :
122 : ! Write attributes
123 451 : if (allocated(table%attrib)) then
124 28 : if (len_trim(table%attrib) > 0) then
125 14 : call write_attrib_string(table%attrib, buf, buf_len, buf_cap)
126 : end if
127 : end if
128 :
129 : ! Write __attr_* children as XML attributes
130 451 : call write_extra_attrs(table, buf, buf_len, buf_cap)
131 :
132 : ! Count non-attr children
133 451 : real_children = count_real_children(table)
134 :
135 : ! Check for empty table (no non-attr children)
136 451 : if (real_children == 0) then
137 0 : call append_str(buf, buf_len, buf_cap, "/>")
138 0 : call append_newline(buf, buf_len, buf_cap, pretty)
139 0 : return
140 : end if
141 :
142 : ! Check for table with single anonymous or #text value child → inline
143 451 : if (real_children == 1) then
144 0 : select type (child => table%children(first_real_child(table))%node)
145 : type is (hsd_value)
146 90 : if (.not. allocated(child%name)) then
147 1 : call append_str(buf, buf_len, buf_cap, ">")
148 1 : call write_value_content(child, buf, buf_len, buf_cap, pretty)
149 1 : call append_str(buf, buf_len, buf_cap, "</" // tag_name // ">")
150 1 : call append_newline(buf, buf_len, buf_cap, pretty)
151 45 : return
152 132 : else if (len_trim(child%name) == 0 .or. child%name == "#text") then
153 44 : call append_str(buf, buf_len, buf_cap, ">")
154 44 : call write_value_content(child, buf, buf_len, buf_cap, pretty)
155 44 : call append_str(buf, buf_len, buf_cap, "</" // tag_name // ">")
156 44 : call append_newline(buf, buf_len, buf_cap, pretty)
157 44 : return
158 : end if
159 : end select
160 : end if
161 :
162 : ! Close opening tag, write children, close tag
163 406 : call append_str(buf, buf_len, buf_cap, ">")
164 406 : call append_newline(buf, buf_len, buf_cap, pretty)
165 :
166 406 : call write_children(table, buf, buf_len, buf_cap, depth + 1, pretty)
167 :
168 406 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
169 406 : call append_str(buf, buf_len, buf_cap, "</" // tag_name // ">")
170 406 : call append_newline(buf, buf_len, buf_cap, pretty)
171 :
172 458 : end subroutine write_table
173 :
174 : !> Write all children of a table.
175 466 : recursive subroutine write_children(table, buf, buf_len, buf_cap, depth, pretty)
176 : type(hsd_table), intent(in) :: table
177 : character(len=:), allocatable, intent(inout) :: buf
178 : integer, intent(inout) :: buf_len, buf_cap
179 : integer, intent(in) :: depth
180 : logical, intent(in) :: pretty
181 :
182 466 : integer :: ii
183 :
184 2134 : do ii = 1, table%num_children
185 1668 : if (.not. associated(table%children(ii)%node)) cycle
186 1668 : if (is_attr_child(table%children(ii)%node)) cycle
187 :
188 466 : select type (child => table%children(ii)%node)
189 : type is (hsd_table)
190 451 : call write_table(child, buf, buf_len, buf_cap, depth, pretty)
191 : type is (hsd_value)
192 1217 : call write_value(child, buf, buf_len, buf_cap, depth, pretty)
193 : end select
194 : end do
195 :
196 466 : end subroutine write_children
197 :
198 : !> Write a value node as an XML element.
199 1217 : subroutine write_value(val, buf, buf_len, buf_cap, depth, pretty)
200 : type(hsd_value), intent(in) :: val
201 : character(len=:), allocatable, intent(inout) :: buf
202 : integer, intent(inout) :: buf_len, buf_cap
203 : integer, intent(in) :: depth
204 : logical, intent(in) :: pretty
205 :
206 1217 : character(len=:), allocatable :: tag_name
207 :
208 : ! Anonymous or #text value: write as bare text content
209 1217 : if (.not. allocated(val%name)) then
210 0 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
211 0 : call write_value_content(val, buf, buf_len, buf_cap, pretty)
212 0 : call append_newline(buf, buf_len, buf_cap, pretty)
213 0 : return
214 1217 : else if (len_trim(val%name) == 0 .or. val%name == "#text") then
215 0 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
216 0 : call write_value_content(val, buf, buf_len, buf_cap, pretty)
217 0 : call append_newline(buf, buf_len, buf_cap, pretty)
218 0 : return
219 : end if
220 :
221 1217 : tag_name = val%name
222 :
223 1217 : call write_indent(buf, buf_len, buf_cap, depth, pretty)
224 1217 : call append_str(buf, buf_len, buf_cap, "<" // tag_name)
225 :
226 : ! Write attributes
227 1217 : if (allocated(val%attrib)) then
228 68 : if (len_trim(val%attrib) > 0) then
229 34 : call write_attrib_string(val%attrib, buf, buf_len, buf_cap)
230 : end if
231 : end if
232 :
233 1217 : call append_str(buf, buf_len, buf_cap, ">")
234 1217 : call write_value_content(val, buf, buf_len, buf_cap, pretty)
235 1217 : call append_str(buf, buf_len, buf_cap, "</" // tag_name // ">")
236 1217 : call append_newline(buf, buf_len, buf_cap, pretty)
237 :
238 1217 : end subroutine write_value
239 :
240 : !> Write the text content of a value node (no surrounding tags).
241 1262 : subroutine write_value_content(val, buf, buf_len, buf_cap, pretty)
242 : type(hsd_value), intent(in) :: val
243 : character(len=:), allocatable, intent(inout) :: buf
244 : integer, intent(inout) :: buf_len, buf_cap
245 : logical, intent(in), optional :: pretty
246 :
247 : character(len=40) :: num_buf
248 1262 : logical :: do_pretty
249 :
250 1262 : do_pretty = .true.
251 1262 : if (present(pretty)) do_pretty = pretty
252 :
253 2497 : select case (val%value_type)
254 : case (VALUE_TYPE_STRING)
255 2470 : if (allocated(val%string_value)) then
256 1235 : if (do_pretty) then
257 1230 : call append_str(buf, buf_len, buf_cap, xml_escape_text(val%string_value))
258 : else
259 : call append_str(buf, buf_len, buf_cap, &
260 5 : & xml_escape_text(collapse_newlines(val%string_value)))
261 : end if
262 : end if
263 : case (VALUE_TYPE_INTEGER)
264 0 : write(num_buf, "(i0)") val%int_value
265 0 : call append_str(buf, buf_len, buf_cap, trim(num_buf))
266 : case (VALUE_TYPE_REAL)
267 0 : write(num_buf, "(es23.15e3)") val%real_value
268 0 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
269 : case (VALUE_TYPE_LOGICAL)
270 0 : if (val%logical_value) then
271 0 : call append_str(buf, buf_len, buf_cap, "Yes")
272 : else
273 0 : call append_str(buf, buf_len, buf_cap, "No")
274 : end if
275 : case (VALUE_TYPE_COMPLEX)
276 2 : write(num_buf, "(es23.15e3)") real(val%complex_value, dp)
277 2 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)) // " ")
278 2 : write(num_buf, "(es23.15e3)") aimag(val%complex_value)
279 2 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
280 : case (VALUE_TYPE_ARRAY, VALUE_TYPE_NONE)
281 : ! Use raw_text if available, otherwise empty
282 1262 : if (allocated(val%raw_text)) then
283 25 : if (do_pretty) then
284 23 : call append_str(buf, buf_len, buf_cap, xml_escape_text(val%raw_text))
285 : else
286 : call append_str(buf, buf_len, buf_cap, &
287 2 : & xml_escape_text(collapse_newlines(val%raw_text)))
288 : end if
289 : end if
290 : case default
291 : ! Unknown value type: skip
292 : end select
293 :
294 1217 : end subroutine write_value_content
295 :
296 : !> Parse HSD attribute string and write as XML attributes.
297 : !> HSD stores attributes like "Angstrom" (simple unit) or "key=val, key2=val2".
298 48 : subroutine write_attrib_string(attrib, buf, buf_len, buf_cap)
299 : character(len=*), intent(in) :: attrib
300 : character(len=:), allocatable, intent(inout) :: buf
301 : integer, intent(inout) :: buf_len, buf_cap
302 :
303 : ! Simple case: treat the whole attribute as a unit
304 48 : call append_str(buf, buf_len, buf_cap, ' unit="')
305 48 : call append_str(buf, buf_len, buf_cap, xml_escape_attrib(trim(attrib)))
306 48 : call append_str(buf, buf_len, buf_cap, '"')
307 :
308 1262 : end subroutine write_attrib_string
309 :
310 : !> Check if a node is an __attr_* value child.
311 3505 : pure function is_attr_child(node) result(is_attr)
312 : class(hsd_node), intent(in) :: node
313 : logical :: is_attr
314 :
315 3505 : is_attr = .false.
316 : select type (node)
317 : type is (hsd_value)
318 2549 : if (allocated(node%name)) then
319 2547 : if (len(node%name) > len(ATTR_PREFIX)) then
320 2283 : is_attr = node%name(1:len(ATTR_PREFIX)) == ATTR_PREFIX
321 : end if
322 : end if
323 : end select
324 :
325 3553 : end function is_attr_child
326 :
327 : !> Write __attr_* children as XML attributes.
328 451 : subroutine write_extra_attrs(table, buf, buf_len, buf_cap)
329 : type(hsd_table), intent(in) :: table
330 : character(len=:), allocatable, intent(inout) :: buf
331 : integer, intent(inout) :: buf_len, buf_cap
332 :
333 451 : integer :: ii
334 :
335 2033 : do ii = 1, table%num_children
336 1582 : if (.not. associated(table%children(ii)%node)) cycle
337 451 : select type (child => table%children(ii)%node)
338 : type is (hsd_value)
339 1241 : if (allocated(child%name)) then
340 1240 : if (len(child%name) > len(ATTR_PREFIX)) then
341 1124 : if (child%name(1:len(ATTR_PREFIX)) == ATTR_PREFIX) then
342 : call append_str(buf, buf_len, buf_cap, " " &
343 2 : & // child%name(len(ATTR_PREFIX) + 1:) // '="')
344 2 : if (allocated(child%string_value)) then
345 : call append_str(buf, buf_len, buf_cap, &
346 2 : & xml_escape_attrib(child%string_value))
347 : end if
348 2 : call append_str(buf, buf_len, buf_cap, '"')
349 : end if
350 : end if
351 : end if
352 : end select
353 : end do
354 :
355 3956 : end subroutine write_extra_attrs
356 :
357 : !> Count non-attr children.
358 451 : pure function count_real_children(table) result(cnt)
359 : type(hsd_table), intent(in) :: table
360 : integer :: cnt
361 :
362 451 : integer :: ii
363 :
364 451 : cnt = 0
365 2033 : do ii = 1, table%num_children
366 1582 : if (.not. associated(table%children(ii)%node)) cycle
367 2033 : if (.not. is_attr_child(table%children(ii)%node)) cnt = cnt + 1
368 : end do
369 :
370 902 : end function count_real_children
371 :
372 : !> Find the index of the first non-attr child.
373 253 : pure function first_real_child(table) result(idx)
374 : type(hsd_table), intent(in) :: table
375 : integer :: idx
376 :
377 253 : integer :: ii
378 :
379 253 : idx = 1
380 255 : do ii = 1, table%num_children
381 255 : if (.not. associated(table%children(ii)%node)) cycle
382 255 : if (.not. is_attr_child(table%children(ii)%node)) then
383 253 : idx = ii
384 253 : return
385 : end if
386 : end do
387 :
388 704 : end function first_real_child
389 :
390 : !> Write indentation.
391 2074 : subroutine write_indent(buf, buf_len, buf_cap, depth, pretty)
392 : character(len=:), allocatable, intent(inout) :: buf
393 : integer, intent(inout) :: buf_len, buf_cap
394 : integer, intent(in) :: depth
395 : logical, intent(in) :: pretty
396 :
397 2074 : integer :: spaces, ii
398 :
399 15 : if (.not. pretty) return
400 2059 : spaces = depth * INDENT_WIDTH
401 40861 : do ii = 1, spaces
402 40861 : call append_char(buf, buf_len, buf_cap, " ")
403 : end do
404 :
405 2327 : end subroutine write_indent
406 :
407 : !> Append a newline if pretty-printing.
408 2254 : subroutine append_newline(buf, buf_len, buf_cap, pretty)
409 : character(len=:), allocatable, intent(inout) :: buf
410 : integer, intent(inout) :: buf_len, buf_cap
411 : logical, intent(in) :: pretty
412 :
413 2233 : if (pretty) call append_char(buf, buf_len, buf_cap, new_line("a"))
414 :
415 2074 : end subroutine append_newline
416 :
417 : !> Append a string to the buffer, growing if needed.
418 6598 : subroutine append_str(buf, buf_len, buf_cap, str)
419 : character(len=:), allocatable, intent(inout) :: buf
420 : integer, intent(inout) :: buf_len, buf_cap
421 : character(len=*), intent(in) :: str
422 :
423 6598 : integer :: new_len
424 :
425 6598 : new_len = buf_len + len(str)
426 6598 : call ensure_capacity(buf, buf_cap, new_len)
427 6598 : buf(buf_len + 1:new_len) = str
428 6598 : buf_len = new_len
429 :
430 2254 : end subroutine append_str
431 :
432 : !> Append a single character.
433 41035 : subroutine append_char(buf, buf_len, buf_cap, ch)
434 : character(len=:), allocatable, intent(inout) :: buf
435 : integer, intent(inout) :: buf_len, buf_cap
436 : character(len=*), intent(in) :: ch
437 :
438 41035 : call ensure_capacity(buf, buf_cap, buf_len + 1)
439 41035 : buf(buf_len + 1:buf_len + 1) = ch
440 41035 : buf_len = buf_len + 1
441 :
442 6598 : end subroutine append_char
443 :
444 : !> Ensure buffer has at least min_cap capacity.
445 47633 : subroutine ensure_capacity(buf, buf_cap, min_cap)
446 : character(len=:), allocatable, intent(inout) :: buf
447 : integer, intent(inout) :: buf_cap
448 : integer, intent(in) :: min_cap
449 :
450 47633 : character(len=:), allocatable :: tmp
451 47633 : integer :: new_cap
452 :
453 47625 : if (min_cap <= buf_cap) return
454 :
455 8 : new_cap = buf_cap
456 20 : do while (new_cap < min_cap)
457 12 : new_cap = new_cap * 2
458 : end do
459 :
460 8 : allocate(character(len=new_cap) :: tmp)
461 8 : tmp(1:buf_cap) = buf(1:buf_cap)
462 8 : call move_alloc(tmp, buf)
463 8 : buf_cap = new_cap
464 :
465 88668 : end subroutine ensure_capacity
466 :
467 : !> Replace newlines (and surrounding whitespace) with a single space.
468 : !>
469 : !> Used in compact mode to prevent multi-line text content from
470 : !> introducing line breaks in the XML output.
471 7 : pure function collapse_newlines(text) result(res)
472 : character(len=*), intent(in) :: text
473 : character(len=:), allocatable :: res
474 :
475 7 : integer :: i, tlen, out_len
476 7 : logical :: in_ws
477 :
478 7 : tlen = len(text)
479 7 : allocate(character(len=tlen) :: res)
480 7 : out_len = 0
481 7 : in_ws = .false.
482 :
483 71 : do i = 1, tlen
484 71 : if (text(i:i) == new_line("a") .or. text(i:i) == char(13)) then
485 : ! Replace newline sequence with single space (collapse adjacent ws)
486 1 : if (.not. in_ws .and. out_len > 0) then
487 1 : out_len = out_len + 1
488 1 : res(out_len:out_len) = " "
489 : end if
490 1 : in_ws = .true.
491 63 : else if (in_ws .and. (text(i:i) == " " .or. text(i:i) == char(9))) then
492 : ! Skip whitespace immediately after a newline
493 0 : cycle
494 : else
495 63 : in_ws = .false.
496 63 : out_len = out_len + 1
497 63 : res(out_len:out_len) = text(i:i)
498 : end if
499 : end do
500 :
501 7 : res = res(1:out_len)
502 :
503 47640 : end function collapse_newlines
504 :
505 8683 : end module hsd_data_xml_writer
|
