Line data Source code
1 : !> HSD query and navigation operations
2 : !>
3 : !> This module provides functionality for navigating HSD tree structures,
4 : !> introspecting node types, and performing tree operations like merging
5 : !> and cloning.
6 : module hsd_query
7 : use hsd_utils, only: to_lower
8 : use hsd_error, only: HSD_STAT_OK, HSD_STAT_NOT_FOUND, HSD_STAT_TYPE_ERROR
9 : use hsd_types, only: hsd_node, hsd_table, hsd_value, new_table, new_value, &
10 : VALUE_TYPE_NONE, VALUE_TYPE_ARRAY
11 : implicit none (type, external)
12 : private
13 :
14 : ! Public procedures
15 : public :: hsd_get_child, hsd_get_table
16 : public :: hsd_has_child
17 : public :: hsd_remove_child
18 : public :: hsd_get_type, hsd_is_table, hsd_is_value, hsd_is_array
19 : public :: hsd_child_count, hsd_get_keys
20 : public :: hsd_get_attrib, hsd_has_attrib
21 : public :: hsd_merge, hsd_clone
22 :
23 : contains
24 :
25 : !> Check if a table has a child with given name
26 15 : function hsd_has_child(table, name, case_insensitive) result(has)
27 : type(hsd_table), intent(in), target :: table
28 : character(len=*), intent(in) :: name
29 : logical, intent(in), optional :: case_insensitive
30 : logical :: has
31 :
32 15 : has = table%has_child(name, case_insensitive)
33 :
34 15 : end function hsd_has_child
35 :
36 : !> Remove a child from a table by name
37 : !>
38 : !> Supports path-based navigation with "/" separator for nested tables.
39 : !> The last component of the path is the child to remove.
40 7 : subroutine hsd_remove_child(table, path, stat, case_insensitive)
41 : type(hsd_table), intent(inout) :: table
42 : character(len=*), intent(in) :: path
43 : integer, intent(out), optional :: stat
44 : logical, intent(in), optional :: case_insensitive
45 :
46 : class(hsd_node), pointer :: parent_node
47 : type(hsd_table), pointer :: parent_table
48 7 : character(len=:), allocatable :: child_name, parent_path
49 7 : integer :: last_slash, local_stat
50 :
51 : ! Find the last slash to separate parent path from child name
52 7 : last_slash = index(path, "/", back=.true.)
53 :
54 7 : if (last_slash > 0) then
55 3 : parent_path = path(1:last_slash-1)
56 3 : child_name = path(last_slash+1:)
57 :
58 : ! Get the parent table
59 3 : call hsd_get_child(table, parent_path, parent_node, local_stat)
60 3 : if (local_stat /= HSD_STAT_OK .or. .not. associated(parent_node)) then
61 0 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
62 0 : return
63 : end if
64 :
65 3 : select type (parent_node)
66 : type is (hsd_table)
67 2 : parent_table => parent_node
68 2 : call parent_table%remove_child_by_name(child_name, local_stat, case_insensitive)
69 4 : if (present(stat)) stat = local_stat
70 : class default
71 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
72 : end select
73 : else
74 : ! No path separator - remove directly from the root table
75 4 : child_name = path
76 4 : call table%remove_child_by_name(child_name, local_stat, case_insensitive)
77 4 : if (present(stat)) stat = local_stat
78 : end if
79 :
80 22 : end subroutine hsd_remove_child
81 :
82 : !> Get the type of a value at the given path
83 : !>
84 : !> Returns one of: VALUE_TYPE_NONE (not found or is table), VALUE_TYPE_STRING,
85 : !> VALUE_TYPE_INTEGER, VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY,
86 : !> VALUE_TYPE_COMPLEX
87 12 : function hsd_get_type(table, path) result(val_type)
88 : type(hsd_table), intent(in), target :: table
89 : character(len=*), intent(in) :: path
90 : integer :: val_type
91 :
92 : class(hsd_node), pointer :: child
93 12 : integer :: local_stat
94 :
95 12 : val_type = VALUE_TYPE_NONE
96 12 : call hsd_get_child(table, path, child, local_stat)
97 :
98 12 : if (local_stat /= 0 .or. .not. associated(child)) return
99 :
100 : select type (child)
101 : type is (hsd_value)
102 7 : val_type = child%value_type
103 : end select
104 :
105 19 : end function hsd_get_type
106 :
107 : !> Check if the node at path is a table (container)
108 7 : function hsd_is_table(table, path) result(is_tbl)
109 : type(hsd_table), intent(in), target :: table
110 : character(len=*), intent(in) :: path
111 : logical :: is_tbl
112 :
113 : class(hsd_node), pointer :: child
114 7 : integer :: local_stat
115 :
116 7 : is_tbl = .false.
117 7 : call hsd_get_child(table, path, child, local_stat)
118 :
119 7 : if (local_stat /= 0 .or. .not. associated(child)) return
120 :
121 : select type (child)
122 : type is (hsd_table)
123 3 : is_tbl = .true.
124 : end select
125 :
126 19 : end function hsd_is_table
127 :
128 : !> Check if the node at path is a value (leaf)
129 7 : function hsd_is_value(table, path) result(is_val)
130 : type(hsd_table), intent(in), target :: table
131 : character(len=*), intent(in) :: path
132 : logical :: is_val
133 :
134 : class(hsd_node), pointer :: child
135 7 : integer :: local_stat
136 :
137 7 : is_val = .false.
138 7 : call hsd_get_child(table, path, child, local_stat)
139 :
140 7 : if (local_stat /= 0 .or. .not. associated(child)) return
141 :
142 : select type (child)
143 : type is (hsd_value)
144 4 : is_val = .true.
145 : end select
146 :
147 14 : end function hsd_is_value
148 :
149 : !> Check if the node at path contains array data
150 1 : function hsd_is_array(table, path) result(is_arr)
151 : type(hsd_table), intent(in), target :: table
152 : character(len=*), intent(in) :: path
153 : logical :: is_arr
154 :
155 2 : is_arr = (hsd_get_type(table, path) == VALUE_TYPE_ARRAY)
156 :
157 8 : end function hsd_is_array
158 :
159 : !> Get the number of children in a table at the given path
160 : !>
161 : !> Returns 0 if path not found or is not a table
162 10 : function hsd_child_count(table, path) result(count)
163 : type(hsd_table), intent(in), target :: table
164 : character(len=*), intent(in) :: path
165 : integer :: count
166 :
167 : class(hsd_node), pointer :: child
168 10 : integer :: local_stat
169 :
170 10 : count = 0
171 :
172 10 : if (len_trim(path) == 0) then
173 : ! Empty path means the root table itself
174 3 : count = table%num_children
175 3 : return
176 : end if
177 :
178 7 : call hsd_get_child(table, path, child, local_stat)
179 :
180 7 : if (local_stat /= 0 .or. .not. associated(child)) return
181 :
182 : select type (child)
183 : type is (hsd_table)
184 5 : count = child%num_children
185 : end select
186 :
187 18 : end function hsd_child_count
188 :
189 : !> Get the keys (child names) from a table at the given path
190 9 : subroutine hsd_get_keys(table, path, keys, stat)
191 : type(hsd_table), intent(in), target :: table
192 : character(len=*), intent(in) :: path
193 : character(len=:), allocatable, intent(out) :: keys(:)
194 : integer, intent(out), optional :: stat
195 :
196 : class(hsd_node), pointer :: child
197 9 : integer :: local_stat
198 :
199 9 : if (present(stat)) stat = HSD_STAT_OK
200 :
201 9 : if (len_trim(path) == 0) then
202 : ! Empty path means the root table itself
203 2 : call table%get_keys(keys)
204 3 : return
205 : end if
206 :
207 7 : call hsd_get_child(table, path, child, local_stat)
208 :
209 7 : if (local_stat /= 0 .or. .not. associated(child)) then
210 1 : allocate(character(len=1) :: keys(0))
211 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
212 1 : return
213 : end if
214 :
215 : select type (child)
216 : type is (hsd_table)
217 4 : call child%get_keys(keys)
218 : class default
219 2 : allocate(character(len=1) :: keys(0))
220 2 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
221 : end select
222 :
223 26 : end subroutine hsd_get_keys
224 :
225 : !> Get a child node by path (using / as separator)
226 100167 : subroutine hsd_get_child(table, path, child, stat)
227 : type(hsd_table), intent(in), target :: table
228 : character(len=*), intent(in) :: path
229 : class(hsd_node), pointer, intent(out) :: child
230 : integer, intent(out), optional :: stat
231 :
232 100167 : child => null()
233 : ! stat will be overriden by subroutine below.
234 167 : if (present(stat)) stat = HSD_STAT_OK
235 :
236 : ! Delegate to recursive helper
237 100167 : call get_first_child_table(table, path, child, stat)
238 :
239 9 : end subroutine hsd_get_child
240 :
241 : !> Helper to navigate path and get child
242 100184 : recursive subroutine get_first_child_table(table, path, child, stat)
243 : type(hsd_table), intent(in), target :: table
244 : character(len=*), intent(in) :: path
245 : class(hsd_node), pointer, intent(out) :: child
246 : integer, intent(out), optional :: stat
247 :
248 100184 : character(len=:), allocatable :: remaining, segment
249 : class(hsd_node), pointer :: current
250 100184 : integer :: sep_pos
251 :
252 100184 : child => null()
253 100184 : remaining = path
254 :
255 : ! Get first segment
256 100184 : sep_pos = index(remaining, "/")
257 100184 : if (sep_pos > 0) then
258 19 : segment = remaining(1:sep_pos-1)
259 19 : remaining = remaining(sep_pos+1:)
260 : else
261 100165 : segment = remaining
262 100165 : remaining = ""
263 : end if
264 :
265 : ! Find child with this name
266 100184 : call table%get_child_by_name(segment, current, case_insensitive=.true.)
267 :
268 100184 : if (.not. associated(current)) then
269 28 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
270 100165 : return
271 : end if
272 :
273 : ! If no more path, return this node
274 100156 : if (len_trim(remaining) == 0) then
275 100137 : child => current
276 100137 : if (present(stat)) stat = HSD_STAT_OK
277 100137 : return
278 : end if
279 :
280 : ! Otherwise, recurse into child table
281 : select type (current)
282 : type is (hsd_table)
283 17 : call get_first_child_table(current, remaining, child, stat)
284 : class default
285 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
286 : end select
287 :
288 300535 : end subroutine get_first_child_table
289 :
290 : !> Get a table child by path
291 4 : subroutine hsd_get_table(table, path, child_table, stat)
292 : type(hsd_table), intent(in), target :: table
293 : character(len=*), intent(in) :: path
294 : type(hsd_table), pointer, intent(out) :: child_table
295 : integer, intent(out), optional :: stat
296 :
297 : class(hsd_node), pointer :: child
298 :
299 4 : child_table => null()
300 4 : call hsd_get_child(table, path, child, stat)
301 :
302 4 : if (associated(child)) then
303 : select type (child)
304 : type is (hsd_table)
305 3 : child_table => child
306 : class default
307 0 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
308 : end select
309 : end if
310 :
311 8 : end subroutine hsd_get_table
312 :
313 : !> Get an attribute from a node at the given path
314 : !>
315 : !> Example: For `LatticeConstant [Angstrom] = 5.4`, the attribute is "Angstrom"
316 7 : subroutine hsd_get_attrib(table, path, attrib, stat)
317 : type(hsd_table), intent(in), target :: table
318 : character(len=*), intent(in) :: path
319 : character(len=:), allocatable, intent(out) :: attrib
320 : integer, intent(out), optional :: stat
321 :
322 : class(hsd_node), pointer :: child
323 7 : integer :: local_stat
324 :
325 7 : call hsd_get_child(table, path, child, local_stat)
326 :
327 7 : if (local_stat /= 0 .or. .not. associated(child)) then
328 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
329 1 : attrib = ""
330 1 : return
331 : end if
332 :
333 : ! Node exists - return OK regardless of whether attribute is set
334 6 : if (allocated(child%attrib)) then
335 4 : attrib = child%attrib
336 : else
337 2 : attrib = ""
338 : end if
339 6 : if (present(stat)) stat = HSD_STAT_OK
340 :
341 11 : end subroutine hsd_get_attrib
342 :
343 : !> Check if a node at the given path has an attribute
344 3 : function hsd_has_attrib(table, path) result(has)
345 : type(hsd_table), intent(in), target :: table
346 : character(len=*), intent(in) :: path
347 : logical :: has
348 :
349 : class(hsd_node), pointer :: child
350 3 : integer :: local_stat
351 :
352 3 : has = .false.
353 3 : call hsd_get_child(table, path, child, local_stat)
354 :
355 3 : if (local_stat /= 0 .or. .not. associated(child)) return
356 :
357 2 : has = allocated(child%attrib)
358 :
359 10 : end function hsd_has_attrib
360 :
361 : !> Merge two HSD tables (overlay pattern)
362 : !>
363 : !> Values from `overlay` are merged into `base`. If a key exists in both,
364 : !> the value from `overlay` takes precedence (unless it's a table,
365 : !> in which case they are merged recursively).
366 15 : recursive subroutine hsd_merge(base, overlay, stat)
367 : type(hsd_table), intent(inout) :: base
368 : type(hsd_table), intent(in) :: overlay
369 : integer, intent(out), optional :: stat
370 :
371 : class(hsd_node), pointer :: overlay_child, base_child
372 15 : type(hsd_table) :: cloned_table
373 15 : type(hsd_value) :: cloned_value
374 15 : integer :: i, local_stat
375 :
376 15 : if (present(stat)) stat = HSD_STAT_OK
377 :
378 : ! Iterate over overlay children
379 37 : do i = 1, overlay%num_children
380 22 : call overlay%get_child(i, overlay_child)
381 22 : if (.not. associated(overlay_child)) cycle
382 22 : if (.not. allocated(overlay_child%name)) cycle
383 :
384 : ! Check if base has this child
385 22 : call base%get_child_by_name(overlay_child%name, base_child, case_insensitive=.true.)
386 :
387 37 : if (.not. associated(base_child)) then
388 : ! Child doesn't exist in base - clone and add it
389 : select type (overlay_child)
390 : type is (hsd_table)
391 0 : call clone_table(overlay_child, cloned_table)
392 6 : call base%add_child(cloned_table)
393 : type is (hsd_value)
394 0 : call clone_value(overlay_child, cloned_value)
395 14 : call base%add_child(cloned_value)
396 : end select
397 : else
398 : ! Child exists - handle based on type
399 : select type (overlay_child)
400 : type is (hsd_table)
401 : ! If both are tables, merge recursively
402 6 : select type (base_child)
403 : type is (hsd_table)
404 4 : call hsd_merge(base_child, overlay_child, local_stat)
405 8 : if (present(stat) .and. local_stat /= HSD_STAT_OK) stat = local_stat
406 : class default
407 : ! Base is not a table but overlay is - skip (could log warning)
408 : end select
409 : type is (hsd_value)
410 : ! Overlay value replaces base value
411 6 : select type (base_child)
412 : type is (hsd_value)
413 0 : call clone_value(overlay_child, cloned_value)
414 : ! Replace the value content
415 5 : base_child%value_type = cloned_value%value_type
416 5 : if (allocated(cloned_value%string_value)) then
417 5 : base_child%string_value = cloned_value%string_value
418 : end if
419 5 : base_child%int_value = cloned_value%int_value
420 5 : base_child%real_value = cloned_value%real_value
421 5 : base_child%logical_value = cloned_value%logical_value
422 5 : base_child%complex_value = cloned_value%complex_value
423 5 : if (allocated(cloned_value%raw_text)) then
424 0 : base_child%raw_text = cloned_value%raw_text
425 : end if
426 5 : if (allocated(cloned_value%int_array)) then
427 0 : if (allocated(base_child%int_array)) deallocate(base_child%int_array)
428 0 : allocate(base_child%int_array, source=cloned_value%int_array)
429 : end if
430 10 : if (allocated(cloned_value%real_array)) then
431 0 : if (allocated(base_child%real_array)) deallocate(base_child%real_array)
432 0 : allocate(base_child%real_array, source=cloned_value%real_array)
433 : end if
434 : class default
435 : ! Type mismatch - skip
436 : end select
437 : end select
438 : end if
439 : end do
440 :
441 58 : end subroutine hsd_merge
442 :
443 : !> Clone a table (deep copy)
444 2100338 : recursive subroutine clone_table(source, dest)
445 : type(hsd_table), intent(in) :: source
446 : type(hsd_table), intent(out) :: dest
447 :
448 : class(hsd_node), pointer :: child
449 66811 : type(hsd_table) :: cloned_subtable
450 66811 : type(hsd_value) :: cloned_value
451 66811 : integer :: i
452 :
453 66811 : call new_table(dest, name=source%name)
454 66811 : if (allocated(source%attrib)) dest%attrib = source%attrib
455 66811 : dest%line = source%line
456 :
457 601223 : do i = 1, source%num_children
458 534412 : call source%get_child(i, child)
459 534412 : if (.not. associated(child)) cycle
460 :
461 66811 : select type (child)
462 : type is (hsd_table)
463 0 : call clone_table(child, cloned_subtable)
464 132808 : call dest%add_child(cloned_subtable)
465 : type is (hsd_value)
466 0 : call clone_value(child, cloned_value)
467 936016 : call dest%add_child(cloned_value)
468 : end select
469 : end do
470 :
471 332483 : end subroutine clone_table
472 :
473 : !> Clone a value (deep copy)
474 936040 : subroutine clone_value(source, dest)
475 : type(hsd_value), intent(in) :: source
476 : type(hsd_value), intent(out) :: dest
477 :
478 468020 : call new_value(dest, name=source%name)
479 468020 : if (allocated(source%attrib)) dest%attrib = source%attrib
480 468020 : dest%line = source%line
481 468020 : dest%value_type = source%value_type
482 :
483 468020 : if (allocated(source%string_value)) dest%string_value = source%string_value
484 468020 : dest%int_value = source%int_value
485 468020 : dest%real_value = source%real_value
486 468020 : dest%logical_value = source%logical_value
487 468020 : dest%complex_value = source%complex_value
488 :
489 468020 : if (allocated(source%raw_text)) dest%raw_text = source%raw_text
490 468020 : if (allocated(source%int_array)) allocate(dest%int_array, source=source%int_array)
491 468020 : if (allocated(source%real_array)) allocate(dest%real_array, source=source%real_array)
492 468020 : if (allocated(source%logical_array)) allocate(dest%logical_array, source=source%logical_array)
493 468020 : if (allocated(source%string_array)) allocate(dest%string_array, source=source%string_array)
494 468020 : if (allocated(source%complex_array)) allocate(dest%complex_array, source=source%complex_array)
495 468020 : if (allocated(source%int_matrix)) allocate(dest%int_matrix, source=source%int_matrix)
496 468020 : if (allocated(source%real_matrix)) allocate(dest%real_matrix, source=source%real_matrix)
497 468020 : dest%nrows = source%nrows
498 468020 : dest%ncols = source%ncols
499 :
500 468020 : end subroutine clone_value
501 :
502 : !> Deep clone an entire HSD table tree
503 404 : subroutine hsd_clone(source, dest, stat)
504 : type(hsd_table), intent(in) :: source
505 : type(hsd_table), intent(out) :: dest
506 : integer, intent(out), optional :: stat
507 :
508 404 : call clone_table(source, dest)
509 404 : if (present(stat)) stat = HSD_STAT_OK
510 :
511 468020 : end subroutine hsd_clone
512 :
513 1068957 : end module hsd_query
|
