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, sp, CHAR_NEWLINE, CHAR_DQUOTE, CHAR_SQUOTE, CHAR_BACKSLASH
7 : use hsd_types, only: hsd_node, hsd_table, hsd_value, hsd_iterator, &
8 : VALUE_TYPE_NONE, VALUE_TYPE_ARRAY, VALUE_TYPE_STRING, &
9 : VALUE_TYPE_INTEGER, VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_COMPLEX
10 : use hsd_error, only: hsd_error_t, HSD_STAT_OK, HSD_STAT_IO_ERROR, make_error
11 : implicit none (type, external)
12 : private
13 :
14 : public :: hsd_dump, hsd_dump_to_string
15 :
16 : !> Indentation string (2 spaces)
17 : character(len=*), parameter :: INDENT_STR = " "
18 :
19 : !> Characters that require quoting
20 : character(len=*), parameter :: QUOTE_TRIGGER_CHARS = "{}[]= " // char(9)
21 :
22 : contains
23 :
24 : !> Write HSD table to a file
25 27 : subroutine hsd_dump(root, filename, error)
26 : type(hsd_table), intent(in) :: root
27 : character(len=*), intent(in) :: filename
28 : type(hsd_error_t), allocatable, intent(out), optional :: error
29 :
30 27 : integer :: unit_num, io_stat
31 : character(len=256) :: io_msg
32 :
33 : open(newunit=unit_num, file=filename, status='replace', action='write', &
34 27 : iostat=io_stat, iomsg=io_msg)
35 27 : if (io_stat /= 0) then
36 1 : if (present(error)) then
37 : call make_error(error, HSD_STAT_IO_ERROR, &
38 1 : "Cannot open file for writing: " // trim(io_msg), filename)
39 : end if
40 1 : return
41 : end if
42 :
43 26 : call write_table_content(unit_num, root, 0)
44 :
45 26 : close(unit_num)
46 :
47 27 : end subroutine hsd_dump
48 :
49 : !> Write HSD table to a string (dynamically allocated)
50 1061 : subroutine hsd_dump_to_string(root, output)
51 : type(hsd_table), intent(in) :: root
52 : character(len=:), allocatable, intent(out) :: output
53 :
54 : ! Start with empty string and build up dynamically
55 1061 : output = ""
56 :
57 1061 : call write_table_to_string(root, 0, output)
58 :
59 27 : end subroutine hsd_dump_to_string
60 :
61 : !> Write table contents to unit
62 30 : recursive subroutine write_table_content(unit_num, table, indent_level)
63 : integer, intent(in) :: unit_num
64 : type(hsd_table), intent(in) :: table
65 : integer, intent(in) :: indent_level
66 :
67 30 : integer :: i
68 : class(hsd_node), pointer :: child
69 30 : character(len=:), allocatable :: indent
70 :
71 33 : indent = repeat(INDENT_STR, indent_level)
72 :
73 71 : do i = 1, table%num_children
74 41 : call table%get_child(i, child)
75 41 : if (.not. associated(child)) cycle
76 :
77 30 : select type (child)
78 : type is (hsd_table)
79 11 : call write_table_node(unit_num, child, indent_level)
80 : type is (hsd_value)
81 30 : call write_value_node(unit_num, child, indent_level)
82 : end select
83 : end do
84 :
85 1091 : end subroutine write_table_content
86 :
87 : !> Write a table node
88 11 : recursive subroutine write_table_node(unit_num, table, indent_level)
89 : integer, intent(in) :: unit_num
90 : type(hsd_table), intent(in) :: table
91 : integer, intent(in) :: indent_level
92 :
93 11 : character(len=:), allocatable :: indent, attrib_str
94 :
95 12 : indent = repeat(INDENT_STR, indent_level)
96 :
97 : ! Build attribute string
98 11 : if (table%has_attrib()) then
99 1 : attrib_str = " [" // table%get_attrib() // "]"
100 : else
101 10 : attrib_str = ""
102 : end if
103 :
104 : ! Check if table has single child (for = syntax)
105 11 : if (table%num_children == 1) then
106 : block
107 : class(hsd_node), pointer :: single_child
108 9 : call table%get_child(1, single_child)
109 :
110 : select type (single_child)
111 : type is (hsd_table)
112 : ! Tag = ChildTag { ... }
113 2 : if (allocated(table%name) .and. len_trim(table%name) > 0) then
114 : write(unit_num, '(A)') indent // trim(table%name) // attrib_str // &
115 1 : " = " // trim(single_child%name) // " {"
116 1 : call write_table_content(unit_num, single_child, indent_level + 1)
117 1 : write(unit_num, '(A)') indent // "}"
118 : else
119 : ! Unnamed table, just write children
120 1 : call write_table_content(unit_num, table, indent_level)
121 : end if
122 11 : return
123 :
124 : type is (hsd_value)
125 : ! Tag = value
126 7 : if (allocated(table%name) .and. len_trim(table%name) > 0) then
127 7 : call write_tag_value(unit_num, table%name, attrib_str, &
128 14 : single_child, indent_level)
129 : else
130 0 : call write_value_node(unit_num, single_child, indent_level)
131 : end if
132 14 : return
133 : end select
134 : end block
135 : end if
136 :
137 : ! Regular block: Tag { ... }
138 2 : if (allocated(table%name) .and. len_trim(table%name) > 0) then
139 2 : write(unit_num, '(A)') indent // trim(table%name) // attrib_str // " {"
140 2 : call write_table_content(unit_num, table, indent_level + 1)
141 2 : write(unit_num, '(A)') indent // "}"
142 : else
143 : ! Root or unnamed table - just write content
144 0 : call write_table_content(unit_num, table, indent_level)
145 : end if
146 :
147 11 : end subroutine write_table_node
148 :
149 : !> Write a value node
150 30 : subroutine write_value_node(unit_num, val, indent_level)
151 : integer, intent(in) :: unit_num
152 : type(hsd_value), intent(in) :: val
153 : integer, intent(in) :: indent_level
154 :
155 30 : character(len=:), allocatable :: indent, attrib_str, value_str
156 :
157 35 : indent = repeat(INDENT_STR, indent_level)
158 :
159 : ! Build attribute string
160 30 : if (val%has_attrib()) then
161 2 : attrib_str = " [" // val%get_attrib() // "]"
162 : else
163 28 : attrib_str = ""
164 : end if
165 :
166 : ! Get value string
167 30 : value_str = format_value(val)
168 :
169 : ! Write
170 30 : if (allocated(val%name) .and. len_trim(val%name) > 0) then
171 30 : if (index(value_str, CHAR_NEWLINE) > 0) then
172 : ! Multi-line value
173 6 : write(unit_num, '(A)') indent // trim(val%name) // attrib_str // " {"
174 6 : call write_multiline(unit_num, value_str, indent_level + 1)
175 6 : write(unit_num, '(A)') indent // "}"
176 : else
177 : ! Single-line value
178 24 : write(unit_num, '(A)') indent // trim(val%name) // attrib_str // " = " // value_str
179 : end if
180 : else
181 : ! Anonymous value (data content)
182 0 : if (index(value_str, CHAR_NEWLINE) > 0) then
183 0 : call write_multiline(unit_num, value_str, indent_level)
184 : else
185 0 : write(unit_num, '(A)') indent // value_str
186 : end if
187 : end if
188 :
189 30 : end subroutine write_value_node
190 :
191 : !> Write tag = value
192 7 : subroutine write_tag_value(unit_num, name, attrib_str, val, indent_level)
193 : integer, intent(in) :: unit_num
194 : character(len=*), intent(in) :: name
195 : character(len=*), intent(in) :: attrib_str
196 : type(hsd_value), intent(in) :: val
197 : integer, intent(in) :: indent_level
198 :
199 7 : character(len=:), allocatable :: indent, value_str, val_attrib
200 :
201 8 : indent = repeat(INDENT_STR, indent_level)
202 7 : value_str = format_value(val)
203 :
204 : ! Combine attributes
205 7 : if (val%has_attrib()) then
206 0 : val_attrib = " [" // val%get_attrib() // "]"
207 : else
208 7 : val_attrib = attrib_str
209 : end if
210 :
211 7 : if (index(value_str, CHAR_NEWLINE) > 0) then
212 : ! Multi-line value
213 1 : write(unit_num, '(A)') indent // trim(name) // val_attrib // " {"
214 1 : call write_multiline(unit_num, value_str, indent_level + 1)
215 1 : write(unit_num, '(A)') indent // "}"
216 : else
217 6 : write(unit_num, '(A)') indent // trim(name) // val_attrib // " = " // value_str
218 : end if
219 :
220 37 : end subroutine write_tag_value
221 :
222 : !> Write multi-line content
223 7 : subroutine write_multiline(unit_num, text, indent_level)
224 : integer, intent(in) :: unit_num
225 : character(len=*), intent(in) :: text
226 : integer, intent(in) :: indent_level
227 :
228 7 : character(len=:), allocatable :: indent
229 7 : integer :: pos, next_pos, text_len
230 :
231 14 : indent = repeat(INDENT_STR, indent_level)
232 7 : text_len = len(text)
233 7 : pos = 1
234 :
235 21 : do while (pos <= text_len)
236 21 : next_pos = index(text(pos:), CHAR_NEWLINE)
237 21 : if (next_pos > 0) then
238 14 : next_pos = pos + next_pos - 1
239 14 : if (next_pos > pos) then
240 11 : write(unit_num, '(A)') indent // text(pos:next_pos-1)
241 : else
242 3 : write(unit_num, '(A)') ""
243 : end if
244 14 : pos = next_pos + 1
245 : else
246 7 : write(unit_num, '(A)') indent // text(pos:)
247 7 : exit
248 : end if
249 : end do
250 :
251 14 : end subroutine write_multiline
252 :
253 : !> Format a value for output
254 12117 : function format_value(val) result(str)
255 : type(hsd_value), intent(in) :: val
256 : character(len=:), allocatable :: str
257 :
258 : character(len=64) :: buffer
259 :
260 12121 : select case (val%value_type)
261 : case (VALUE_TYPE_LOGICAL)
262 8 : if (val%logical_value) then
263 2 : str = "Yes"
264 : else
265 2 : str = "No"
266 : end if
267 :
268 : case (VALUE_TYPE_INTEGER)
269 1016 : write(buffer, '(I0)') val%int_value
270 1016 : str = trim(adjustl(buffer))
271 :
272 : case (VALUE_TYPE_REAL)
273 12 : write(buffer, '(G0)') val%real_value
274 12 : str = trim(adjustl(buffer))
275 : ! Ensure we have a decimal point for whole numbers
276 12 : if (index(str, ".") == 0 .and. index(str, "E") == 0 .and. index(str, "e") == 0) then
277 0 : str = str // ".0"
278 : end if
279 :
280 : case (VALUE_TYPE_STRING)
281 22160 : if (allocated(val%string_value)) then
282 11079 : str = quote_if_needed(val%string_value)
283 1 : else if (allocated(val%raw_text)) then
284 1 : str = val%raw_text
285 : else
286 0 : str = ""
287 : end if
288 :
289 : case default
290 5 : if (allocated(val%string_value)) then
291 0 : str = quote_if_needed(val%string_value)
292 5 : else if (allocated(val%raw_text)) then
293 0 : str = val%raw_text
294 : else
295 5 : str = ""
296 : end if
297 : end select
298 :
299 7 : end function format_value
300 :
301 : !> Quote a string if it contains special characters
302 11079 : function quote_if_needed(str) result(quoted)
303 : character(len=*), intent(in) :: str
304 : character(len=:), allocatable :: quoted
305 :
306 11079 : logical :: needs_quote, has_dquote, has_squote
307 11079 : integer :: i
308 :
309 11079 : needs_quote = .false.
310 11079 : has_dquote = .false.
311 11079 : has_squote = .false.
312 :
313 : ! Check for special characters
314 56700 : do i = 1, len(str)
315 45621 : if (index(QUOTE_TRIGGER_CHARS, str(i:i)) > 0) then
316 2049 : needs_quote = .true.
317 : end if
318 45621 : if (str(i:i) == CHAR_DQUOTE) has_dquote = .true.
319 56700 : if (str(i:i) == CHAR_SQUOTE) has_squote = .true.
320 : end do
321 :
322 11079 : if (.not. needs_quote) then
323 10054 : quoted = str
324 1025 : else if (.not. has_dquote) then
325 1022 : quoted = CHAR_DQUOTE // str // CHAR_DQUOTE
326 3 : else if (.not. has_squote) then
327 2 : quoted = CHAR_SQUOTE // str // CHAR_SQUOTE
328 : else
329 : ! Both quote types present - escape double quotes
330 1 : quoted = CHAR_DQUOTE // escape_quotes(str) // CHAR_DQUOTE
331 : end if
332 :
333 12117 : end function quote_if_needed
334 :
335 : !> Escape double quotes in a string
336 1 : function escape_quotes(str) result(escaped)
337 : character(len=*), intent(in) :: str
338 : character(len=:), allocatable :: escaped
339 :
340 1 : integer :: i
341 :
342 1 : escaped = ""
343 20 : do i = 1, len(str)
344 20 : if (str(i:i) == CHAR_DQUOTE) then
345 2 : escaped = escaped // CHAR_BACKSLASH // CHAR_DQUOTE
346 : else
347 17 : escaped = escaped // str(i:i)
348 : end if
349 : end do
350 :
351 11079 : end function escape_quotes
352 :
353 : !> Write table to dynamically allocated string (for string output)
354 221087 : recursive subroutine write_table_to_string(table, indent_level, output)
355 : type(hsd_table), intent(in) :: table
356 : integer, intent(in) :: indent_level
357 : character(len=:), allocatable, intent(inout) :: output
358 :
359 10093 : integer :: i
360 : class(hsd_node), pointer :: child
361 10093 : character(len=:), allocatable :: indent, attrib_str, line
362 :
363 28150 : indent = repeat(INDENT_STR, indent_level)
364 :
365 31205 : do i = 1, table%num_children
366 21112 : call table%get_child(i, child)
367 21112 : if (.not. associated(child)) cycle
368 :
369 10093 : select type (child)
370 : type is (hsd_table)
371 9032 : if (child%has_attrib()) then
372 1 : attrib_str = " [" // child%get_attrib() // "]"
373 : else
374 9031 : attrib_str = ""
375 : end if
376 :
377 18065 : if (allocated(child%name) .and. len_trim(child%name) > 0) then
378 9031 : line = indent // trim(child%name) // attrib_str // " {"
379 9031 : output = output // line // CHAR_NEWLINE
380 9031 : call write_table_to_string(child, indent_level + 1, output)
381 9031 : line = indent // "}"
382 9031 : output = output // line // CHAR_NEWLINE
383 : else
384 1 : call write_table_to_string(child, indent_level, output)
385 : end if
386 :
387 : type is (hsd_value)
388 12080 : if (child%has_attrib()) then
389 1004 : attrib_str = " [" // child%get_attrib() // "]"
390 : else
391 11076 : attrib_str = ""
392 : end if
393 :
394 12080 : if (allocated(child%name) .and. len_trim(child%name) > 0) then
395 11073 : line = indent // trim(child%name) // attrib_str // " = " // format_value(child)
396 : else
397 1007 : line = indent // format_value(child)
398 : end if
399 24160 : output = output // line // CHAR_NEWLINE
400 : end select
401 : end do
402 :
403 10094 : end subroutine write_table_to_string
404 :
405 51364 : end module hsd_formatter
|
