crp/OpenMC
1
0
Fork 0
mirror of https://github.com/openmc-dev/openmc.git synced 2026-07-26 21:25:36 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions

merged xml into source_interval

Browse source
This commit is contained in:
Bryan Herman 2013-10-22 13:25:28 -04:00
commit 80a31525d7
88 changed files with 40998 additions and 4526 deletions
Download patch file Download diff file Expand all files Collapse all files

3
.gitignore vendored
View file

@ -1,4 +1,5 @@
# Compiled objects and modules
*.a
*.o
*.mod
*.log
@ -26,4 +27,4 @@ src/xml-fortran/xmlreader
src/templates/*.f90
# Test results error file
results_error.dat
results_error.dat

25
docs/source/usersguide/input.rst
View file

@ -198,19 +198,26 @@ tally data, this option can significantly improve the parallel efficiency.
--------------------
The ``<output>`` element determines what output files should be written to disk
during the run. This element has no attributes or sub-elements and should be set
to a list of strings separated by spaces. Valid options are "summary",
"cross-sections", and "tallies". For example, if you want the summary and cross
sections summary file to be written, this element should be given as:
during the run. The sub-elements are described below, where "true" will write
out the file and "false" will not.
.. code-block:: xml
:cross_sections:
Writes out an ASCII summary file of the cross sections that were read in.
<output>summary cross_sections</output>
*Default*: false
.. note:: The tally results will be written to a binary/HDF5 state point file by
default.
:summary:
Writes out an ASCII summary file describing all of the user input files that
were read in.
*Default*: "tallies"
*Default*: false
:tallies:
Write out an ASCII file of tally results.
*Default*: true
.. note:: The tally results will always be written to a binary/HDF5 state point file.
``<output_path>`` Element
-------------------------

14
schemas.xml
View file

@ -1,10 +1,10 @@
<?xml version="1.0"?>
<locatingRules xmlns="http://thaiopensource.com/ns/locating-rules/1.0">
<documentElement localName="geometry" uri="src/templates/geometry.rnc"/>
<documentElement localName="materials" uri="src/templates/materials.rnc"/>
<documentElement localName="settings" uri="src/templates/settings.rnc"/>
<documentElement localName="tallies" uri="src/templates/tallies.rnc"/>
<documentElement localName="plots" uri="src/templates/plots.rnc"/>
<documentElement localName="cmfd" uri="src/templates/cmfd.rnc"/>
<documentElement localName="cross_sections" uri="src/templates/cross_sections.rnc"/>
<documentElement localName="geometry" uri="src/relaxng/geometry.rnc"/>
<documentElement localName="materials" uri="src/relaxng/materials.rnc"/>
<documentElement localName="settings" uri="src/relaxng/settings.rnc"/>
<documentElement localName="tallies" uri="src/relaxng/tallies.rnc"/>
<documentElement localName="plots" uri="src/relaxng/plots.rnc"/>
<documentElement localName="cmfd" uri="src/relaxng/cmfd.rnc"/>
<documentElement localName="cross_sections" uri="src/relaxng/cross_sections.rnc"/>
</locatingRules>

14
src/DEPENDENCIES
View file

@ -36,6 +36,7 @@ cmfd_execute.o: tally.o
cmfd_header.o: constants.o
cmfd_input.o: cmfd_header.o
cmfd_input.o: constants.o
cmfd_input.o: error.o
cmfd_input.o: global.o
cmfd_input.o: mesh_header.o
@ -44,7 +45,7 @@ cmfd_input.o: string.o
cmfd_input.o: tally.o
cmfd_input.o: tally_header.o
cmfd_input.o: tally_initialize.o
cmfd_input.o: templates/cmfd_t.o
cmfd_input.o: xml_interface.o
cmfd_jfnk_solver.o: cmfd_loss_operator.o
cmfd_jfnk_solver.o: cmfd_power_solver.o
@ -210,12 +211,7 @@ input_xml.o: random_lcg.o
input_xml.o: string.o
input_xml.o: tally_header.o
input_xml.o: tally_initialize.o
input_xml.o: templates/cross_sections_t.o
input_xml.o: templates/geometry_t.o
input_xml.o: templates/materials_t.o
input_xml.o: templates/plots_t.o
input_xml.o: templates/settings_t.o
input_xml.o: templates/tallies_t.o
input_xml.o: xml_interface.o
interpolation.o: constants.o
interpolation.o: endf_header.o
@ -388,3 +384,7 @@ tracking.o: tally.o
vector_header.o: constants.o
xml_interface.o: constants.o
xml_interface.o: error.o
xml_interface.o: global.o

22
src/Makefile
View file

@ -3,10 +3,7 @@ prefix = /usr/local
source = $(wildcard *.F90)
objects = $(source:.F90=.o)
templates = $(wildcard templates/*.o)
xml_fort = xml-fortran/xmlparse.o \
xml-fortran/read_xml_primitives.o \
xml-fortran/write_xml_primitives.o
xml_lib = -Lxml/lib -lxml
#===============================================================================
# User Options
@ -243,12 +240,11 @@ endif
# Targets
#===============================================================================
all: xml-fortran $(program)
xml-fortran:
cd xml-fortran; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)" LDFLAGS="$(LDFLAGS)"
cd templates; make F90=$(F90) F90FLAGS="$(F90FLAGS)" LDFLAGS="$(LDFLAGS)"
all: xml $(program)
xml:
cd xml; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)" LDFLAGS="$(LDFLAGS)"
$(program): $(objects)
$(F90) $(objects) $(templates) $(xml_fort) $(LDFLAGS) -o $@
$(F90) $(objects) $(xml_lib) $(LDFLAGS) -o $@
install:
@install -D $(program) $(DESTDIR)$(prefix)/bin/$(program)
@install -D utils/statepoint_cmp.py $(DESTDIR)$(prefix)/bin/statepoint_cmp
@ -264,8 +260,7 @@ uninstall:
@rm $(DESTDIR)$(prefix)/share/man/man1/openmc.1
@rm $(DESTDIR)$(prefix)/share/doc/$(program)/copyright
distclean: clean
cd xml-fortran; make clean
cd templates; make clean
cd xml; make clean
clean:
@rm -f *.o *.mod $(program)
neat:
@ -275,10 +270,11 @@ neat:
# Rules
#===============================================================================
.PHONY: all xml-fortran install uninstall clean neat distclean
.SUFFIXES: .F90 .o
.PHONY: all xml install uninstall clean neat distclean
%.o: %.F90
$(F90) $(F90FLAGS) -DGIT_SHA1="\"$(GIT_SHA1)\"" -Ixml-fortran -Itemplates -c $<
$(F90) $(F90FLAGS) -DGIT_SHA1="\"$(GIT_SHA1)\"" -Ixml/include -c $<
#===============================================================================
# Dependencies

342
src/cmfd_input.F90
View file

@ -61,16 +61,22 @@ contains
!===============================================================================
subroutine read_cmfd_xml()
use error, only: fatal_error, warning
use global
use output, only: write_message
use string, only: lower_case
use xml_data_cmfd_t
use xml_interface
use, intrinsic :: ISO_FORTRAN_ENV
integer :: ng ! number of energy groups
logical :: file_exists ! does cmfd.xml exist?
character(MAX_LINE_LEN) :: filename ! name of input file
integer :: ng
integer, allocatable :: iarray(:)
logical :: file_exists ! does cmfd.xml exist?
logical :: found
character(MAX_LINE_LEN) :: filename
character(MAX_LINE_LEN) :: temp_str
type(Node), pointer :: doc => null()
type(Node), pointer :: node_mesh => null()
! Read cmfd input file
filename = trim(path_input) // "cmfd.xml"
@ -91,16 +97,25 @@ contains
end if
! Parse cmfd.xml file
call read_xml_file_cmfd_t(filename)
call open_xmldoc(doc, filename)
! Set spatial dimensions in cmfd object (structed Cartesian mesh)
cmfd % indices(1:3) = mesh_ % dimension(1:3)
! Get pointer to mesh XML node
call get_node_ptr(doc, "mesh", node_mesh, found = found)
! Get number of energy groups or set to 1 group default
if (associated(mesh_ % energy)) then
ng = size(mesh_ % energy)
if(.not.allocated(cmfd % egrid)) allocate(cmfd % egrid(ng))
cmfd % egrid = mesh_ % energy
! Check if mesh is there
if (.not.found) then
message = "No CMFD mesh specified in CMFD XML file."
call fatal_error()
end if
! Set spatial dimensions in cmfd object
call get_node_array(node_mesh, "dimension", cmfd % indices(1:3))
! Get number of energy groups
if (check_for_node(node_mesh, "energy")) then
ng = get_arraysize_double(node_mesh, "energy")
if(.not.allocated(cmfd%egrid)) allocate(cmfd%egrid(ng))
call get_node_array(node_mesh, "energy", cmfd%egrid)
cmfd % indices(4) = ng - 1 ! sets energy group dimension
else
if(.not.allocated(cmfd % egrid)) allocate(cmfd % egrid(2))
@ -108,90 +123,115 @@ contains
cmfd % indices(4) = 1 ! one energy group
end if
! Set global albedo, these can be overwritten by coremap
if (associated(mesh_ % albedo)) then
cmfd % albedo = mesh_ % albedo
! Set global albedo
if (check_for_node(node_mesh, "albedo")) then
call get_node_array(node_mesh, "albedo", cmfd % albedo)
else
cmfd % albedo = (/1.0, 1.0, 1.0, 1.0, 1.0, 1.0/)
end if
! Get core map overlay for a subset mesh for CMFD
if (associated(mesh_ % map)) then
! Allocate a core map with appropriate dimensions
! Get acceleration map
if (check_for_node(node_mesh, "map")) then
allocate(cmfd % coremap(cmfd % indices(1), cmfd % indices(2), &
cmfd % indices(3)))
! Check and make sure it is of correct size
if (size(mesh_ % map) /= product(cmfd % indices(1:3))) then
message = 'CMFD coremap not to correct dimensions'
if (get_arraysize_integer(node_mesh, "map") /= &
product(cmfd % indices(1:3))) then
message = 'FATAL==>CMFD coremap not to correct dimensions'
call fatal_error()
end if
! Reshape core map vector into (x,y,z) array
cmfd % coremap = reshape(mesh_ % map,(cmfd % indices(1:3)))
! Indicate to cmfd that a core map overlay is active
allocate(iarray(get_arraysize_integer(node_mesh, "map")))
call get_node_array(node_mesh, "map", iarray)
cmfd % coremap = reshape(iarray,(cmfd % indices(1:3)))
cmfd_coremap = .true.
! Write to stdout that a core map overlay is active
message = "Core Map Overlay Activated"
call write_message(10)
deallocate(iarray)
end if
! Get normalization constant for source (default is 1.0 from XML)
cmfd % norm = norm_
! Check for normalization constant
if (check_for_node(doc, "norm")) then
call get_node_value(doc, "norm", cmfd % norm)
end if
! Set feedback logical
call lower_case(feedback_)
if (feedback_ == 'true' .or. feedback_ == '1') cmfd_feedback = .true.
if (check_for_node(doc, "feedback")) then
call get_node_value(doc, "feedback", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_feedback = .true.
end if
! Set downscatter logical
call lower_case(downscatter_)
if (downscatter_ == 'true' .or. downscatter_ == '1') &
cmfd_downscatter = .true.
if (check_for_node(doc, "downscatter")) then
call get_node_value(doc, "downscatter", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_downscatter = .true.
end if
! Set the solver type (default power from XML)
cmfd_solver_type = solver_(1:10)
! Set the solver type
if (check_for_node(doc, "solver")) &
call get_node_value(doc, "solver", cmfd_solver_type)
! Set convergence monitoring
call lower_case(snes_monitor_)
call lower_case(ksp_monitor_)
call lower_case(power_monitor_)
if (snes_monitor_ == 'true' .or. snes_monitor_ == '1') &
cmfd_snes_monitor = .true.
if (ksp_monitor_ == 'true' .or. ksp_monitor_ == '1') &
cmfd_ksp_monitor = .true.
if (power_monitor_ == 'true' .or. power_monitor_ == '1') &
cmfd_power_monitor = .true.
! Set monitoring
if (check_for_node(doc, "snes_monitor")) then
call get_node_value(doc, "snes_monitor", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_snes_monitor = .true.
end if
if (check_for_node(doc, "ksp_monitor")) then
call get_node_value(doc, "ksp_monitor", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_ksp_monitor = .true.
end if
if (check_for_node(doc, "power_monitor")) then
call get_node_value(doc, "power_monitor", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_power_monitor = .true.
end if
! Output logicals
call lower_case(write_matrices_)
if (write_matrices_ == 'true' .or. write_matrices_ == '1') &
cmfd_write_matrices = .true.
if (check_for_node(doc, "write_matrices")) then
call get_node_value(doc, "write_matices", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_write_matrices = .true.
end if
! Run an adjoint calc
call lower_case(run_adjoint_)
if (run_adjoint_ == 'true' .or. run_adjoint_ == '1') &
cmfd_run_adjoint = .true.
if (check_for_node(doc, "run_adjoint")) then
call get_node_value(doc, "run_adjoint", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_run_adjoint = .true.
end if
! Batch to begin cmfd (default is 1 from XML)
cmfd_begin = begin_
! Batch to begin cmfd
if (check_for_node(doc, "begin")) &
call get_node_value(doc, "begin", cmfd_begin)
! Tally during inactive batches (by default we will always tally from 1)
call lower_case(inactive_)
if (inactive_ == 'false' .or. inactive_ == '0') cmfd_tally_on = .false.
! Tally during inactive batches
if (check_for_node(doc, "inactive")) then
call get_node_value(doc, "inactive", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'false' .or. trim(temp_str) == '0') &
cmfd_tally_on = .false.
end if
! Inactive batch flush window
cmfd_inact_flush(1) = inactive_flush_ ! the interval of batches
cmfd_inact_flush(2) = num_flushes_ ! number of times to do this
if (check_for_node(doc, "inactive_flush")) &
call get_node_value(doc, "inactive_flush", cmfd_inact_flush(1))
if (check_for_node(doc, "num_flushes")) &
call get_node_value(doc, "num_flushes", cmfd_inact_flush(2))
! Last flush before active batches
cmfd_act_flush = active_flush_
if (check_for_node(doc, "active_flush")) &
call get_node_value(doc, "active_flush", cmfd_act_flush)
! Get display
cmfd_display = display_
if (check_for_node(doc, "display")) &
call get_node_value(doc, "display", cmfd_display)
if (trim(cmfd_display) == 'dominance' .and. &
trim(cmfd_solver_type) /= 'power') then
message = 'Dominance Ratio only aviable with power iteration solver'
@ -200,7 +240,10 @@ contains
end if
! Create tally objects
call create_cmfd_tally()
call create_cmfd_tally(doc)
! Close CMFD XML file
call close_xmldoc(doc)
end subroutine read_cmfd_xml
@ -213,29 +256,31 @@ contains
! 3: Surface current
!===============================================================================
subroutine create_cmfd_tally()
subroutine create_cmfd_tally(doc)
use constants, only: MAX_LINE_LEN
use error, only: fatal_error, warning
use mesh_header, only: StructuredMesh
use string
use tally, only: setup_active_cmfdtallies
use tally_header, only: TallyObject, TallyFilter
use tally_initialize, only: add_tallies
use xml_data_cmfd_t
use xml_interface
type(Node), pointer :: doc ! pointer to XML doc info
character(MAX_LINE_LEN) :: temp_str ! temp string
integer :: i ! loop counter
integer :: n ! size of arrays in mesh specification
integer :: ng ! number of energy groups (default 1)
integer :: n_filters ! number of filters
integer :: i_filter_mesh ! index for mesh filter
character(MAX_LINE_LEN) :: filename ! name of cmfd file
integer :: iarray3(3) ! temp integer array
real(8) :: rarray3(3) ! temp double array
type(TallyObject), pointer :: t => null()
type(StructuredMesh), pointer :: m => null()
type(TallyFilter) :: filters(N_FILTER_TYPES) ! temporary filters
! Parse cmfd.xml file
filename = trim(path_input) // "cmfd.xml"
call read_xml_file_cmfd_t(filename)
type(Node), pointer :: node_mesh => null()
! Set global variables if they are 0 (this can happen if there is no tally
! file)
@ -251,8 +296,11 @@ contains
! Set mesh type to rectangular
m % type = LATTICE_RECT
! Get pointer to mesh XML node
call get_node_ptr(doc, "mesh", node_mesh)
! Determine number of dimensions for mesh
n = size(mesh_ % dimension)
n = get_arraysize_integer(node_mesh, "dimension")
if (n /= 2 .and. n /= 3) then
message = "Mesh must be two or three dimensions."
call fatal_error()
@ -266,75 +314,80 @@ contains
allocate(m % upper_right(n))
! Check that dimensions are all greater than zero
if (any(mesh_ % dimension <= 0)) then
message = "All entries on the <dimension> element for a tally mesh &
&must be positive."
call fatal_error()
call get_node_array(node_mesh, "dimension", iarray3(1:n))
if (any(iarray3(1:n) <= 0)) then
message = "All entries on the <dimension> element for a tally mesh &
&must be positive."
call fatal_error()
end if
! Read dimensions in each direction
m % dimension = mesh_ % dimension
m % dimension = iarray3(1:n)
! Read mesh lower-left corner location
if (m % n_dimension /= size(mesh_ % lower_left)) then
message = "Number of entries on <lower_left> must be the same as &
&the number of entries on <dimension>."
call fatal_error()
if (m % n_dimension /= get_arraysize_double(node_mesh, "lower_left")) then
message = "Number of entries on <lower_left> must be the same as &
&the number of entries on <dimension>."
call fatal_error()
end if
m % lower_left = mesh_ % lower_left
call get_node_array(node_mesh, "lower_left", m % lower_left)
! Make sure either upper-right or width was specified
if (associated(mesh_ % upper_right) .and. &
associated(mesh_ % width)) then
message = "Cannot specify both <upper_right> and <width> on a &
&tally mesh."
call fatal_error()
! Make sure both upper-right or width were specified
if (check_for_node(node_mesh, "upper_right") .and. &
check_for_node(node_mesh, "width")) then
message = "Cannot specify both <upper_right> and <width> on a &
&tally mesh."
call fatal_error()
end if
! Make sure either upper-right or width was specified
if (.not. associated(mesh_ % upper_right) .and. &
.not. associated(mesh_ % width)) then
message = "Must specify either <upper_right> and <width> on a &
&tally mesh."
call fatal_error()
if (.not.check_for_node(node_mesh, "upper_right") .and. &
.not.check_for_node(node_mesh, "width")) then
message = "Must specify either <upper_right> and <width> on a &
&tally mesh."
call fatal_error()
end if
if (associated(mesh_ % width)) then
! Check to ensure width has same dimensions
if (size(mesh_ % width) /= size(mesh_ % lower_left)) then
message = "Number of entries on <width> must be the same as the &
&number of entries on <lower_left>."
call fatal_error()
end if
if (check_for_node(node_mesh, "width")) then
! Check to ensure width has same dimensions
if (get_arraysize_double(node_mesh, "width") /= &
get_arraysize_double(node_mesh, "lower_left")) then
message = "Number of entries on <width> must be the same as the &
&number of entries on <lower_left>."
call fatal_error()
end if
! Check for negative widths
if (any(mesh_ % width < ZERO)) then
message = "Cannot have a negative <width> on a tally mesh."
call fatal_error()
end if
! Check for negative widths
call get_node_array(node_mesh, "width", rarray3(1:n))
if (any(rarray3(1:n) < ZERO)) then
message = "Cannot have a negative <width> on a tally mesh."
call fatal_error()
end if
! Set width and upper right coordinate
m % width = mesh_ % width
m % upper_right = m % lower_left + m % dimension * m % width
! Set width and upper right coordinate
m % width = rarray3(1:n)
m % upper_right = m % lower_left + m % dimension * m % width
elseif (associated(mesh_ % upper_right)) then
! Check to ensure width has same dimensions
if (size(mesh_ % upper_right) /= size(mesh_ % lower_left)) then
message = "Number of entries on <upper_right> must be the same as &
&the number of entries on <lower_left>."
call fatal_error()
end if
elseif (check_for_node(node_mesh, "upper_right")) then
! Check to ensure width has same dimensions
if (get_arraysize_double(node_mesh, "upper_right") /= &
get_arraysize_double(node_mesh, "lower_left")) then
message = "Number of entries on <upper_right> must be the same as &
&the number of entries on <lower_left>."
call fatal_error()
end if
! Check that upper-right is above lower-left
if (any(mesh_ % upper_right < mesh_ % lower_left)) then
message = "The <upper_right> coordinates must be greater than the &
&<lower_left> coordinates on a tally mesh."
call fatal_error()
end if
! Check that upper-right is above lower-left
call get_node_array(node_mesh, "upper_right", rarray3(1:n))
if (any(rarray3(1:n) < m % lower_left)) then
message = "The <upper_right> coordinates must be greater than the &
&<lower_left> coordinates on a tally mesh."
call fatal_error()
end if
! Set width and upper right coordinate
m % upper_right = mesh_ % upper_right
m % width = (m % upper_right - m % lower_left) / m % dimension
! Set upper right coordinate and width
m % upper_right = rarray3(1:n)
m % width = (m % upper_right - m % lower_left) / real(m % dimension, 8)
end if
! Set volume fraction
@ -353,8 +406,12 @@ contains
t => cmfd_tallies(i)
! Set reset property
call lower_case(reset_)
if (reset_ == 'true' .or. reset_ == '1') t % reset = .true.
if (check_for_node(doc, "reset")) then
call get_node_value(doc, "reset", temp_str)
call lower_case(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
t % reset = .true.
end if
! Set up mesh filter
n_filters = 1
@ -365,13 +422,14 @@ contains
t % find_filter(FILTER_MESH) = n_filters
! Read and set incoming energy mesh filter
if (associated(mesh_ % energy)) then
if (check_for_node(node_mesh, "energy")) then
n_filters = n_filters + 1
filters(n_filters) % type = FILTER_ENERGYIN
ng = size(mesh_ % energy)
ng = get_arraysize_double(node_mesh, "energy")
filters(n_filters) % n_bins = ng - 1
allocate(filters(n_filters) % real_bins(ng))
filters(n_filters) % real_bins = mesh_ % energy
call get_node_array(node_mesh, "energy", &
filters(n_filters) % real_bins)
t % find_filter(FILTER_ENERGYIN) = n_filters
end if
@ -425,14 +483,15 @@ contains
! Set tally type to volume
t % type = TALLY_VOLUME
! Read and set outgoing energy mesh filter
if (associated(mesh_ % energy)) then
! read and set outgoing energy mesh filter
if (check_for_node(node_mesh, "energy")) then
n_filters = n_filters + 1
filters(n_filters) % type = FILTER_ENERGYOUT
ng = size(mesh_ % energy)
ng = get_arraysize_double(node_mesh, "energy")
filters(n_filters) % n_bins = ng - 1
allocate(filters(n_filters) % real_bins(ng))
filters(n_filters) % real_bins = mesh_ % energy
call get_node_array(node_mesh, "energy", &
filters(n_filters) % real_bins)
t % find_filter(FILTER_ENERGYOUT) = n_filters
end if
@ -441,8 +500,8 @@ contains
allocate(t % filters(n_filters))
t % filters = filters(1:n_filters)
! Deallocate filters bins array
if (associated(mesh_ % energy)) &
! deallocate filters bins array
if (check_for_node(node_mesh, "energy")) &
deallocate(filters(n_filters) % real_bins)
! Allocate macro reactions
@ -510,7 +569,8 @@ contains
! Deallocate filter bins
deallocate(filters(1) % int_bins)
if (associated(mesh_ % energy)) deallocate(filters(2) % real_bins)
if (check_for_node(node_mesh, "energy")) &
deallocate(filters(2) % real_bins)
end do

1285
src/input_xml.F90
View file

File diff suppressed because it is too large Load diff

0
src/templates/cmfd.rnc → src/relaxng/cmfd.rnc
View file

0
src/templates/cross_sections.rnc → src/relaxng/cross_sections.rnc
View file

0
src/templates/geometry.rnc → src/relaxng/geometry.rnc
View file

0
src/templates/materials.rnc → src/relaxng/materials.rnc
View file

0
src/templates/plots.rnc → src/relaxng/plots.rnc
View file

8
src/templates/settings.rnc → src/relaxng/settings.rnc
View file

@ -40,8 +40,12 @@ element settings {
element no_reduce { xsd:boolean }? &
element output { list {
( "summary" | "cross_sections" | "tallies" )+ } }? &
element output {
(element summary { xsd:boolean } | attribute summary { xsd:boolean })? &
(element cross_sections { xsd:boolean } |
attribute cross_sections { xsd:boolean })? &
(element tallies { xsd:boolean } | attribute tallies { xsd:boolean })?
}? &
element output_path { xsd:string { maxLength = "255" } }? &

0
src/templates/tallies.rnc → src/relaxng/tallies.rnc
View file

34
src/templates/cmfd_t.xml
View file

@ -1,34 +0,0 @@
<?xml version="1.0"?>
<template>
<options rootname="cmfd" />
<typedef name="mesh_xml">
<component name="dimension" type="integer-array" />
<component name="lower_left" type="double-array" />
<component name="upper_right" type="double-array" />
<component name="width" type="double-array" />
<component name="albedo" type="double-array" />
<component name="map" type="integer-array" />
<component name="energy" type="double-array" />
</typedef>
<variable name="mesh_" tag="mesh" type="mesh_xml" />
<variable name="norm_" tag="norm" type="double" default="1.0" />
<variable name="feedback_" tag="feedback" type="word" length="5" />
<variable name="reset_" tag="reset" type="word" length="5" />
<variable name="downscatter_" tag="downscatter" type="word" length="5" />
<variable name="solver_" tag="solver" type="word" default="'power'" length="25" />
<variable name="snes_monitor_" tag="snes_monitor" type="word" length="5" />
<variable name="ksp_monitor_" tag="ksp_monitor" type="word" length="5" />
<variable name="power_monitor_" tag="power_monitor" type="word" length="5" />
<variable name="write_matrices_" tag="write_matrices" type="word" length="5" />
<variable name="run_adjoint_" tag="run_adjoint" type="word" length="5" />
<variable name="begin_" tag="begin" type="integer" default="1" />
<variable name="inactive_" tag="inactive" type="word" length="5" />
<variable name="active_flush_" tag="active_flush" type="integer" default="0" />
<variable name="inactive_flush_" tag="inactive_flush" type="integer" default="9999" />
<variable name="num_flushes_" tag="num_flushes" type="integer" default="1" />
<variable name="display_" tag="display" type="word" default="''" length="25" />
</template>

26
src/templates/cross_sections_t.xml
View file

@ -1,26 +0,0 @@
<?xml version="1.0"?>
<template>
<!-- This is the template for reading cross section listings in OpenMC -->
<options rootname="cross_sections" />
<typedef name="ace_table_xml">
<component name="name" type="word" length="15" />
<component name="alias" type="word" length="15" default="''" />
<component name="type" type="word" length="10" default="'neutron'" />
<component name="zaid" type="integer" default="0" />
<component name="metastable" type="integer" default="0" />
<component name="awr" type="double" default="0.0" />
<component name="temperature" type="double" default="0.0" />
<component name="path" type="word" length="255" />
<component name="location" type="integer" default="0" />
</typedef>
<variable name="ace_tables_" tag="ace_table" type="ace_table_xml" dimension="1" />
<variable name="directory_" tag="directory" type="word" length="255" />
<variable name="filetype_" tag="filetype" type="word" length="255" />
<variable name="record_length_" tag="record_length" type="integer" />
<variable name="entries_" tag="entries" type="integer" />
</template>

39
src/templates/geometry_t.xml
View file

@ -1,39 +0,0 @@
<?xml version="1.0"?>
<template>
<!-- This is the template for reading geometry in OpenMC -->
<options rootname="geometry" />
<typedef name="cell_xml">
<component name="id" type="integer" />
<component name="universe" type="integer" default="0" />
<component name="material" type="word" length="12" default="''" />
<component name="fill" type="integer" default="0" />
<component name="surfaces" type="integer-array" />
<component name="rotation" type="double-array" />
<component name="translation" type="double-array" />
</typedef>
<typedef name="surface_xml">
<component name="id" type="integer" />
<component name="type" type="word" length="15" />
<component name="coeffs" type="double-array" />
<component name="boundary" type="word" length="12" default="'transmit'" />
</typedef>
<typedef name="lattice_xml">
<component name="id" type="integer" />
<component name="type" type="word" length="12" default="'rectangular'" />
<component name="dimension" type="integer-array" />
<component name="lower_left" type="double-array" />
<component name="width" type="double-array" />
<component name="universes" type="integer-array" />
<component name="outside" type="integer" default="0"/>
</typedef>
<variable name="cell_" tag="cell" type="cell_xml" dimension="1" />
<variable name="surface_" tag="surface" type="surface_xml" dimension="1" />
<variable name="lattice_" tag="lattice" type="lattice_xml" dimension="1" />
</template>

44
src/templates/materials_t.xml
View file

@ -1,44 +0,0 @@
<?xml version="1.0"?>
<template>
<!-- This is the template for reading materials in OpenMC -->
<options rootname="materials" />
<!-- Type for specifying density of a material -->
<typedef name="density_xml">
<component name="value" type="double" default="0.0" />
<component name="units" type="word" length="10" default="'atom/b-cm'" />
</typedef>
<!-- Type for specifying a nuclide -->
<typedef name="nuclide_xml">
<component name="name" type="word" length="7" default="''" />
<component name="xs" type="word" length="3" default="''" />
<component name="ao" type="double" default="0.0" />
<component name="wo" type="double" default="0.0" />
</typedef>
<!-- Type for specifying S(a,b) data -->
<typedef name="sab_xml">
<component name="name" type="word" length="10" />
<component name="xs" type="word" length="3" />
</typedef>
<!-- Type for specifying a material -->
<typedef name="material_xml">
<component name="id" type="integer" />
<component name="density" type="density_xml" />
<component name="nuclides" tag="nuclide" type="nuclide_xml" dimension="1" />
<component name="elements" tag="element" type="nuclide_xml" dimension="1" />
<component name="sab" type="sab_xml" dimension="1" />
</typedef>
<variable name="material_" tag="material" type="material_xml" dimension="1" />
<variable name="default_xs_" tag="default_xs" type="word" length="3" />
</template>

32
src/templates/plots_t.xml
View file

@ -1,32 +0,0 @@
<?xml version="1.0"?>
<template>
<options rootname="plots" />
<typedef name="col_spec_xml">
<component name="id" type="integer" />
<component name="rgb" type="integer-array" />
</typedef>
<typedef name="mask_xml">
<component name="components" type="integer-array" />
<component name="background" type="integer-array" />
</typedef>
<typedef name="plot_xml">
<component name="id" type="integer" />
<component name="filename" type="word" length="50" default="'plot'" />
<component name="type" type="word" length="10" default="'slice'"/>
<component name="color" type="word" length="10" default="'cell'"/>
<component name="origin" type="double-array" />
<component name="width" type="double-array" />
<component name="basis" type="word" length="3" default="'xy'" />
<component name="pixels" type="integer-array" />
<component name="background" type="integer-array"/>
<component name="col_spec_" tag="col_spec" type="col_spec_xml" dimension="1" />
<component name="mask_" tag="mask" type="mask_xml" dimension="1" />
</typedef>
<variable name="plot_" tag="plot" type="plot_xml" dimension="1" />
</template>

76
src/templates/settings_t.xml
View file

@ -1,76 +0,0 @@
<?xml version="1.0"?>
<template>
<options rootname="settings" />
<typedef name="run_parameters_xml">
<component name="batches" type="integer" default="0" />
<component name="inactive" type="integer" />
<component name="particles" type="word" length="25" default="''" />
<component name="generations_per_batch" type="integer" default="1" />
</typedef>
<typedef name="distribution_xml">
<component name="type" type="word" length="16" />
<component name="length" type="integer" />
<component name="interpolation" type="word" length="10" />
<component name="parameters" type="double-array" />
</typedef>
<typedef name="source_xml">
<component name="file" type="word" length="255" />
<component name="space" type="distribution_xml" />
<component name="angle" type="distribution_xml" />
<component name="energy" type="distribution_xml" />
</typedef>
<typedef name="cutoff_xml">
<component name="weight" type="double" default="0.25" />
<component name="weight_avg" type="double" default="1.0" />
</typedef>
<typedef name="mesh_xml">
<component name="dimension" type="integer-array" />
<component name="lower_left" type="double-array" />
<component name="upper_right" type="double-array" />
</typedef>
<typedef name="statepoint_xml">
<component name="batches" type="integer-array" />
<component name="interval" type="integer" default="0" />
</typedef>
<typedef name="sourcepoint_xml">
<component name="batches" type="integer-array" />
<component name="interval" type="integer" default="0" />
<component name="source_separate" type="word" length="5" default="''" />
<component name="source_write" type="word" length="5" default="''" />
<component name="overwrite_latest" type="word" length="5" default="''" />
</typedef>
<variable name="confidence_intervals_" tag="confidence_intervals" type="word" length="5" />
<variable name="cross_sections_" tag="cross_sections" type="word" length="255" />
<variable name="cutoff_" tag="cutoff" type="cutoff_xml" dimension="1" />
<variable name="eigenvalue_" tag="eigenvalue" type="run_parameters_xml" />
<variable name="energy_grid_" tag="energy_grid" type="word" length="7" />
<variable name="entropy_" tag="entropy" type="mesh_xml" dimension="1" />
<variable name="fixed_source_" tag="fixed_source" type="run_parameters_xml" />
<variable name="no_reduce_" tag="no_reduce" type="word" length="5" />
<variable name="output_" tag="output" type="word-array" length="20" />
<variable name="output_path_" tag="output_path" type="word" length="255" />
<variable name="ptables_" tag="ptables" type="word" length="5" />
<variable name="run_cmfd_" tag="run_cmfd" type="word" length="5" />
<variable name="seed_" tag="seed" type="integer" />
<variable name="source_" tag="source" type="source_xml" />
<variable name="state_point_" tag="state_point" type="statepoint_xml" dimension="1" />
<variable name="source_point_" tag="source_point" type="sourcepoint_xml" dimension="1" />
<variable name="survival_" tag="survival_biasing" type="word" length="5" />
<variable name="threads_" tag="threads" type="integer" />
<variable name="trace_" tag="trace" type="integer-array" />
<variable name="uniform_fs_" tag="uniform_fs" type="mesh_xml" dimension="1" />
<variable name="verbosity_" tag="verbosity" type="integer" />
<!-- Check for old criticality tag -->
<variable name="criticality_" tag="criticality" type="run_parameters_xml" />
</template>

37
src/templates/tallies_t.xml
View file

@ -1,37 +0,0 @@
<?xml version="1.0"?>
<template>
<options rootname="tallies" />
<typedef name="mesh_xml">
<component name="id" type="integer" />
<component name="type" type="word" length="12" />
<component name="dimension" type="integer-array" />
<component name="lower_left" type="double-array" />
<component name="upper_right" type="double-array" />
<component name="width" type="double-array" />
</typedef>
<typedef name="filter_xml">
<component name="type" type="word" length="20" default = "''" />
<component name="bins" type="word-array" length="20" />
<component name="groups" type="word" length="20" default = "''" />
</typedef>
<typedef name="tally_xml">
<component name="id" type="integer" />
<component name="label" type="word" length="52" default="''" />
<component name="estimator" type="word" length="12" default="''" />
<component name="filter" type="filter_xml" dimension="1" />
<component name="scores" type="word-array" length="20" />
<component name="nuclides" type="word-array" length="12" />
<!-- Check for old tally filter format -->
<component name="filters" type="filter_xml" dimension="1" />
</typedef>
<variable name="mesh_" tag="mesh" type="mesh_xml" dimension="1" />
<variable name="tally_" tag="tally" type="tally_xml" dimension="1" />
<variable name="separate_" tag="assume_separate" type="word" length="3" />
</template>

4
src/utils/build_dependencies.py
View file

@ -12,10 +12,8 @@ for src in glob.iglob('*.F90'):
open(src, 'r').read())
for name in d:
if name in ['mpi', 'hdf5', 'h5lt', 'petscsys', 'petscmat', 'petscksp',
'petscsnes', 'petscvec']:
'petscsnes', 'petscvec', 'omp_lib', 'fox_dom']:
continue
if name.startswith('xml_data_'):
name = name.replace('xml_data_', 'templates/')
deps.add(name)
if deps:
dependencies[module] = sorted(list(deps))

79
src/xml-fortran/read_from_buffer.inc
View file

@ -1,79 +0,0 @@
! Part of XML-Fortran library:
!
! $Id: read_from_buffer.inc,v 1.2 2006/03/26 19:05:48 arjenmarkus Exp $
!
character(len=*), intent(in) :: buffer
integer, intent(inout) :: ierror
integer :: n
integer :: i
integer :: step
integer :: ierr
!
! First allocate an array that is surely large enough
! Note:
! This is not completely failsafe: with list-directed
! input you can also use repeat counts (10000*1.0 for
! instance).
!
allocate( work(len(buffer)/2+1) )
!
! NOTE:
! This is not portable!!
!
! read( buffer, *, iostat = ierror ) (work(n), n=1,size(work))
!
! So, use a different strategy: a binary search
! First: establish that we have at least one item to read
! Second: do the binary search
!
! read( buffer, *, iostat = ierr ) work(1)
! if ( ierr /= 0 ) then
! n = 0
! else
n = 1
do while ( n <= size(work) )
n = 2 * n
enddo
n = n / 2
step = n / 2
! step = n / 2
do while ( step > 0 )
read( buffer, *, iostat = ierr ) (work(i), i = 1,n)
if ( ierr /= 0 ) then
ierror = ierr ! Store the error code for later use
n = n - step
else
n = n + step
endif
step = step / 2
enddo
! endif
!
! Then allocate an array of the actual size needed
! and copy the data
!
!
if ( associated( var ) ) then
deallocate( var )
endif
!
! One complication: we may have one too many
! (consequence of the binary search)
!
read( buffer, *, iostat = ierr ) (work(i), i = 1,n)
if ( ierr < 0 ) then
n = n - 1
endif
allocate( var(n) )
var(1:n) = work(1:n)
deallocate( work )
if ( ierror .lt. 0 ) then
ierror = 0
endif

54
src/xml-fortran/read_xml_array.inc
View file

@ -1,54 +0,0 @@
! Part of XML-Fortran library:
!
! $Id: read_xml_array.inc,v 1.3 2007/02/26 20:33:38 arjenmarkus Exp $
!
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
logical, intent(inout) :: has_var
character(len=len(attribs(1,1))) :: buffer
integer :: idx
integer :: ierr
!
! The big trick:
! A string long enough to hold all data strings
!
character(len=nodata*(len(data(1))+1)) :: bufferd
integer :: start
!
! The value can be stored in an attribute values="..." or in
! the data
!
has_var = .false.
idx = xml_find_attrib( attribs, noattribs, 'values', buffer )
if ( idx .gt. 0 ) then
call read_from_buffer( buffer, var, ierr )
if ( buffer .ne. ' ' ) then
has_var = .true.
endif
else
bufferd = ' '
start = 1
do idx = 1,nodata
if ( data(idx) .ne. ' ' ) then
bufferd(start:) = data(idx)
start = start + len(data(idx)) + 1
endif
enddo
call read_from_buffer( bufferd, var, ierr )
if ( bufferd .ne. ' ' ) then
has_var = .true.
endif
endif
if ( ierr .ne. 0 ) then
write(*,*) 'Error reading variable - tag = ', trim(tag)
has_var = .false.
endif

527
src/xml-fortran/read_xml_primitives.f90
View file

@ -1,527 +0,0 @@
! read_xml_prims.f90 - Read routines for primitive data
!
! $Id: read_xml_prims.f90,v 1.7 2007/12/07 10:38:41 arjenmarkus Exp $
!
! Arjen Markus
!
! General information:
! This module is part of the XML-Fortran library. Its
! purpose is to help read individual items from an XML
! file into the variables that have been connected to
! the various tags. It is used by the code generated
! by the make_xml_reader program.
!
! Because the routines differ mostly by the type of the
! output variable, the body is included, to prevent
! too much repeated blocks of code with all the maintenance
! issues that causes.
!
module read_xml_primitives
use xmlparse
implicit none
private :: read_from_buffer
private :: read_from_buffer_integers
private :: read_from_buffer_reals
private :: read_from_buffer_doubles
private :: read_from_buffer_logicals
private :: read_from_buffer_words
interface read_from_buffer
module procedure read_from_buffer_integers
module procedure read_from_buffer_reals
module procedure read_from_buffer_doubles
module procedure read_from_buffer_logicals
module procedure read_from_buffer_words
end interface
contains
! skip_until_endtag --
! Routine to read the XML file until the end tag is encountered
!
! Arguments:
! info The XML file data structure
! tag The tag in question
! attribs Array of attributes and their values
! data Array of strings, representing the data
! error Has an error occurred?
!
subroutine skip_until_endtag( info, tag, attribs, data, error )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
character(len=*), dimension(:,:), intent(inout) :: attribs
character(len=*), dimension(:), intent(inout) :: data
logical, intent(out) :: error
integer :: noattribs
integer :: nodata
integer :: ierr
logical :: endtag
character(len=len(tag)) :: newtag
error = .true.
do
call xml_get( info, newtag, endtag, attribs, noattribs, &
data, nodata )
if ( xml_error(info) ) then
error = .true.
exit
endif
if ( endtag .and. newtag == tag ) then
exit
endif
enddo
end subroutine skip_until_endtag
! read_xml_integer --
! Routine to read a single integer from the parsed data
!
! Arguments:
! info XML parser structure
! tag The tag in question (error message only)
! endtag End tag found? (Dummy argument, actually)
! attribs Array of attributes and their values
! noattribs Number of attributes found
! data Array of strings, representing the data
! nodata Number of data strings
! var Variable to be filled
! has_var Has the variable been set?
!
subroutine read_xml_integer( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
integer, intent(inout) :: var
include 'read_xml_scalar.inc'
end subroutine read_xml_integer
! read_xml_line --
! Routine to read a single line of text from the parsed data
!
! Arguments:
! info XML parser structure
! tag The tag in question (error message only)
! endtag End tag found? (Dummy argument, actually)
! attribs Array of attributes and their values
! noattribs Number of attributes found
! data Array of strings, representing the data
! nodata Number of data strings
! var Variable to be filled
! has_var Has the variable been set?
!
subroutine read_xml_line( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
character(len=*), intent(inout) :: var
logical, intent(inout) :: has_var
character(len=len(attribs(1,1))) :: buffer
integer :: idx
integer :: ierr
!
! The value can be stored in an attribute value="..." or in
! the data
!
has_var = .false.
idx = xml_find_attrib( attribs, noattribs, 'value', buffer )
if ( idx > 0 ) then
var = buffer
has_var = .true.
else
do idx = 1,nodata
if ( data(idx) /= ' ' ) then
var = data(idx)
has_var = .true.
exit
endif
enddo
endif
end subroutine read_xml_line
! read_xml_real, ... --
! See read_xml_integer for an explanation
!
subroutine read_xml_real( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
real, intent(inout) :: var
include 'read_xml_scalar.inc'
end subroutine read_xml_real
subroutine read_xml_double( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
real(kind=kind(1.0d00)), intent(inout) :: var
include 'read_xml_scalar.inc'
end subroutine read_xml_double
subroutine read_xml_logical( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
logical, intent(inout) :: var
include 'read_xml_scalar.inc'
end subroutine read_xml_logical
subroutine read_xml_word( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
character(len=*), intent(inout) :: var
include 'read_xml_word.inc'
end subroutine read_xml_word
! read_xml_integer_array --
! Routine to read a one-dimensional integer array from the parsed
! ata
!
! Arguments:
! info XML parser structure
! tag The tag in question (error message only)
! endtag End tag found? (Dummy argument, actually)
! attribs Array of attributes and their values
! noattribs Number of attributes found
! data Array of strings, representing the data
! nodata Number of data strings
! var Variable to be filled
! has_var Has the variable been set?
!
subroutine read_xml_integer_array( info, tag, endtag, attribs, noattribs, data, &
nodata, var, has_var )
integer, dimension(:), pointer :: var
include 'read_xml_array.inc'
end subroutine read_xml_integer_array
! read_xml_line_array --
! Routine to read an array of lines of text from the parsed data
!
! Arguments:
! info XML parser structure
! tag The tag in question (error message only)
! attribs Array of attributes and their values
! noattribs Number of attributes found
! data Array of strings, representing the data
! nodata Number of data strings
! var Variable to be filled
! has_var Has the variable been set?
!
subroutine read_xml_line_array( info, tag, endtag, attribs, noattribs, data, &
nodata, var, has_var )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
character(len=*), dimension(:), pointer :: var
logical, intent(inout) :: has_var
character(len=len(attribs(1,1))) :: buffer
integer :: idx
integer :: idxv
integer :: ierr
logical :: started
!
! The value can be stored in an attribute values="..." or in
! the data
!
has_var = .false.
idx = xml_find_attrib( attribs, noattribs, 'values', buffer )
if ( idx > 0 ) then
allocate( var(1:1) )
var(1) = buffer
if ( buffer /= ' ' ) then
has_var = .true.
endif
else
idxv = 0
started = .false.
do idx = 1,nodata
if ( data(idx) /= ' ' .or. started ) then
if ( .not. started ) then
allocate( var(1:nodata-idx+1) )
started = .true.
endif
idxv = idxv + 1
var(idxv) = data(idx)
endif
enddo
if ( started ) then
has_var = .true.
endif
endif
end subroutine read_xml_line_array
! read_xml_real_array, ... --
! See read_xml_integer_array for an explanation
!
subroutine read_xml_real_array( info, tag, endtag, attribs, noattribs, data, &
nodata, var, has_var )
real, dimension(:), pointer :: var
include 'read_xml_array.inc'
end subroutine read_xml_real_array
subroutine read_xml_double_array( info, tag, endtag, attribs, noattribs, data, &
nodata, var, has_var )
real(kind=kind(1.0d00)), dimension(:), pointer :: var
include 'read_xml_array.inc'
end subroutine read_xml_double_array
subroutine read_xml_logical_array( info, tag, endtag, attribs, noattribs, data, &
nodata, var, has_var )
logical, dimension(:), pointer :: var
include 'read_xml_array.inc'
end subroutine read_xml_logical_array
subroutine read_xml_word_array( info, tag, endtag, attribs, noattribs, data, &
nodata, var, has_var )
character(len=*), dimension(:), pointer :: var
include 'read_xml_array.inc'
end subroutine read_xml_word_array
! read_from_buffer_integers --
! Routine to read all integers from a long string
!
! Arguments:
! buffer String containing the data
! var Variable to be filled
! ierror Error flag
!
subroutine read_from_buffer_integers( buffer, var, ierror )
integer, dimension(:), pointer :: var
integer, dimension(:), pointer :: work
include 'read_from_buffer.inc'
end subroutine read_from_buffer_integers
! read_xml_from_buffer_reals, ... -
! See read_xml_from_buffer_integers for an explanation
!
subroutine read_from_buffer_reals( buffer, var, ierror )
real, dimension(:), pointer :: var
real, dimension(:), pointer :: work
include 'read_from_buffer.inc'
end subroutine read_from_buffer_reals
subroutine read_from_buffer_doubles( buffer, var, ierror )
real(kind=kind(1.0d00)), dimension(:), pointer :: var
real(kind=kind(1.0d00)), dimension(:), pointer :: work
include 'read_from_buffer.inc'
end subroutine read_from_buffer_doubles
subroutine read_from_buffer_logicals( buffer, var, ierror )
logical, dimension(:), pointer :: var
logical, dimension(:), pointer :: work
include 'read_from_buffer.inc'
end subroutine read_from_buffer_logicals
subroutine read_from_buffer_words( buffer, var, ierror )
character(len=*), dimension(:), pointer :: var
character(len=len(var)), dimension(:), pointer :: work
include 'read_from_buffer.inc'
end subroutine read_from_buffer_words
! read_xml_word_1dim, ... -
! Read an array of "words" (or ...) but from different elements
!
subroutine read_xml_integer_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
integer, dimension(:), pointer :: var
logical, intent(inout) :: has_var
integer,dimension(:), pointer :: newvar
character(len=len(attribs(1,1))) :: buffer
integer :: newsize
integer :: ierr
newsize = size(var) + 1
allocate( newvar(1:newsize) )
newvar(1:newsize-1) = var
deallocate( var )
var => newvar
call read_xml_integer( info, tag, endtag, attribs, noattribs, data, nodata, &
var(newsize), has_var )
end subroutine read_xml_integer_1dim
subroutine read_xml_real_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
real, dimension(:), pointer :: var
logical, intent(inout) :: has_var
real, dimension(:), pointer :: newvar
character(len=len(attribs(1,1))) :: buffer
integer :: newsize
integer :: ierr
newsize = size(var) + 1
allocate( newvar(1:newsize) )
newvar(1:newsize-1) = var
deallocate( var )
var => newvar
call read_xml_real( info, tag, endtag, attribs, noattribs, data, nodata, &
var(newsize), has_var )
end subroutine read_xml_real_1dim
subroutine read_xml_double_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
real(kind=kind(1.0d00)), dimension(:), pointer:: var
logical, intent(inout) :: has_var
real(kind=kind(1.0d00)), dimension(:), pointer:: newvar
character(len=len(attribs(1,1))) :: buffer
integer :: newsize
integer :: ierr
newsize = size(var) + 1
allocate( newvar(1:newsize) )
newvar(1:newsize-1) = var
deallocate( var )
var => newvar
call read_xml_double( info, tag, endtag, attribs, noattribs, data, nodata, &
var(newsize), has_var )
end subroutine read_xml_double_1dim
subroutine read_xml_logical_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
logical, dimension(:), pointer :: var
logical, intent(inout) :: has_var
logical, dimension(:), pointer :: newvar
character(len=len(attribs(1,1))) :: buffer
integer :: newsize
integer :: ierr
newsize = size(var) + 1
allocate( newvar(1:newsize) )
newvar(1:newsize-1) = var
deallocate( var )
var => newvar
call read_xml_logical( info, tag, endtag, attribs, noattribs, data, nodata, &
var(newsize), has_var )
end subroutine read_xml_logical_1dim
subroutine read_xml_word_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
character(len=*), dimension(:), pointer :: var
logical, intent(inout) :: has_var
character(len=len(var)),dimension(:), pointer :: newvar
character(len=len(attribs(1,1))) :: buffer
integer :: newsize
integer :: ierr
newsize = size(var) + 1
allocate( newvar(1:newsize) )
newvar(1:newsize-1) = var
deallocate( var )
var => newvar
call read_xml_word( info, tag, endtag, attribs, noattribs, data, nodata, &
var(newsize), has_var )
end subroutine read_xml_word_1dim
subroutine read_xml_line_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
var, has_var )
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
character(len=*), dimension(:), pointer :: var
logical, intent(inout) :: has_var
character(len=len(var)),dimension(:), pointer :: newvar
character(len=len(attribs(1,1))) :: buffer
integer :: newsize
integer :: ierr
newsize = size(var) + 1
allocate( newvar(1:newsize) )
newvar(1:newsize-1) = var
deallocate( var )
var => newvar
call read_xml_line( info, tag, endtag, attribs, noattribs, data, nodata, &
var(newsize), has_var )
end subroutine read_xml_line_1dim
end module read_xml_primitives

40
src/xml-fortran/read_xml_scalar.inc
View file

@ -1,40 +0,0 @@
! Part of XML-Fortran library:
!
! $Id: read_xml_scalar.inc,v 1.3 2007/02/26 20:33:38 arjenmarkus Exp $
!
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
logical, intent(inout) :: has_var
character(len=len(attribs(1,1))) :: buffer
integer :: idx
integer :: ierr
!
! The value can be stored in an attribute value="..." or in
! the data
!
has_var = .false.
idx = xml_find_attrib( attribs, noattribs, 'value', buffer )
if ( idx .gt. 0 ) then
read( buffer, *, iostat=ierr ) var
has_var = .true.
else
do idx = 1,nodata
if ( data(idx) .ne. ' ' ) then
read( data(idx), *, iostat=ierr ) var
has_var = .true.
exit
endif
enddo
endif
if ( ierr .ne. 0 ) then
write(*,*) 'Error reading variable - tag = ', trim(tag)
has_var = .false.
endif

38
src/xml-fortran/read_xml_word.inc
View file

@ -1,38 +0,0 @@
! Part of XML-Fortran library:
!
type(XML_PARSE), intent(inout) :: info
character(len=*), intent(in) :: tag
logical, intent(inout) :: endtag
character(len=*), dimension(:,:), intent(in) :: attribs
integer, intent(in) :: noattribs
character(len=*), dimension(:), intent(in) :: data
integer, intent(in) :: nodata
logical, intent(inout) :: has_var
character(len=len(attribs(1,1))) :: buffer
integer :: idx
integer :: ierr
!
! The value can be stored in an attribute value="..." or in
! the data
!
has_var = .false.
idx = xml_find_attrib( attribs, noattribs, 'value', buffer )
if ( idx .gt. 0 ) then
read( buffer, *, iostat=ierr ) var
has_var = .true.
else
do idx = 1,nodata
if ( data(idx) .ne. ' ' ) then
read( data(idx), '(A)', iostat=ierr ) var
has_var = .true.
exit
endif
enddo
endif
if ( ierr .ne. 0 ) then
write(*,*) 'Error reading variable - tag = ', trim(tag)
has_var = .false.
endif

489
src/xml-fortran/write_xml_primitives.f90
View file

@ -1,489 +0,0 @@
! write_xml_prims.f90 - Write routines for primitive data
!
! $Id: write_xml_prims.f90,v 1.2 2007/12/27 05:13:59 arjenmarkus Exp $
!
! Arjen Markus
!
! General information:
! This module is part of the XML-Fortran library. Its
! purpose is to write individual items to an XML
! file using the right tag. It is used by the code generated
! by the make_xml_reader program.
!
module write_xml_primitives
use xmlparse
implicit none
! interface write_to_xml
! module procedure write_to_xml_integers
! module procedure write_to_xml_reals
! module procedure write_to_xml_doubles
! module procedure write_to_xml_logicals
! module procedure write_to_xml_words
! end interface
interface write_to_xml_word
module procedure write_to_xml_string
end interface
interface write_to_xml_line
module procedure write_to_xml_string
end interface
contains
! write_to_xml_integer --
! Routine to write a single integer to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! value Value to be written
!
subroutine write_to_xml_integer( info, tag, indent, value )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
integer, intent(in) :: value
character(len=100) :: indentation
indentation = ' '
write( info%lun, '(4a,i0,3a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>', value, '</', trim(tag), '>'
end subroutine write_to_xml_integer
! write_to_xml_integer_1dim --
! Routine to write an array of integers to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! values Values to be written
!
subroutine write_to_xml_integer_1dim( info, tag, indent, values )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
integer, dimension(:), intent(in) :: values
integer :: i
do i = 1,size(values)
call write_to_xml_integer( info, tag, indent, values(i) )
enddo
end subroutine write_to_xml_integer_1dim
! write_to_xml_real --
! Routine to write a single real value (single precision) to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! value Value to be written
!
subroutine write_to_xml_real( info, tag, indent, value )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
real, intent(in) :: value
character(len=100) :: indentation
character(len=12) :: buffer
indentation = ' '
write( buffer, '(1pg12.4)' ) value
write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>', trim(adjustl(buffer)), '</', trim(tag), '>'
end subroutine write_to_xml_real
! write_to_xml_real_1dim --
! Routine to write an array of reals to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! values Values to be written
!
subroutine write_to_xml_real_1dim( info, tag, indent, values )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
real, dimension(:), intent(in) :: values
integer :: i
do i = 1,size(values)
call write_to_xml_real( info, tag, indent, values(i) )
enddo
end subroutine write_to_xml_real_1dim
! write_to_xml_double --
! Routine to write one real value (double precision) to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! value Value to be written
!
subroutine write_to_xml_double( info, tag, indent, value )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
real(kind=kind(1.0d0)), intent(in) :: value
character(len=100) :: indentation
character(len=16) :: buffer
indentation = ' '
write( buffer, '(1pg16.7)' ) value
write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>', trim(adjustl(buffer)), '</', trim(tag), '>'
end subroutine write_to_xml_double
! write_to_xml_double_1dim --
! Routine to write an array of double precision reals to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! values Values to be written
!
subroutine write_to_xml_double_1dim( info, tag, indent, values )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
real(kind=kind(1.0d00)), dimension(:), intent(in) :: values
integer :: i
do i = 1,size(values)
call write_to_xml_double( info, tag, indent, values(i) )
enddo
end subroutine write_to_xml_double_1dim
! write_to_xml_string --
! Routine to write one string to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! value Value to be written
!
subroutine write_to_xml_string( info, tag, indent, value )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
character(len=*), intent(in) :: value
character(len=100) :: indentation
!
! NOTE: No guards against <, >, & and " yet!
! NOTE: difference needed between words and lines?
!
indentation = ' '
write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>', trim(value), '</', trim(tag), '>'
end subroutine write_to_xml_string
! write_to_xml_word_1dim --
! Routine to write an array of single words to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! value Value to be written
!
subroutine write_to_xml_word_1dim( info, tag, indent, values )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
character(len=*), dimension(:), intent(in) :: values
integer :: i
do i = 1,size(values)
call write_to_xml_string( info, tag, indent, values(i) )
enddo
end subroutine write_to_xml_word_1dim
! write_to_xml_string_1dim --
! Routine to write an array of strings to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! values Values to be written
!
subroutine write_to_xml_string_1dim( info, tag, indent, values )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
character(len=*), dimension(:), intent(in) :: values
integer :: i
do i = 1,size(values)
call write_to_xml_string( info, tag, indent, values(i) )
enddo
end subroutine write_to_xml_string_1dim
! write_to_xml_logical --
! Routine to write one logical to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! value Value to be written
!
subroutine write_to_xml_logical( info, tag, indent, value )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
logical, intent(in) :: value
character(len=100) :: indentation
indentation = ' '
if ( value ) then
write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>true</', trim(tag), '>'
else
write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>false</', trim(tag), '>'
endif
end subroutine write_to_xml_logical
! write_to_xml_logical_1dim --
! Routine to write an array of logicals to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! values Values to be written
!
subroutine write_to_xml_logical_1dim( info, tag, indent, values )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
logical, dimension(:), intent(in) :: values
integer :: i
do i = 1,size(values)
call write_to_xml_logical( info, tag, indent, values(i) )
enddo
end subroutine write_to_xml_logical_1dim
! write_to_xml_integer_array --
! Routine to write an array of integers to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! array Values to be written
!
subroutine write_to_xml_integer_array( info, tag, indent, array )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
integer, dimension(:), intent(in) :: array
character(len=100) :: indentation
integer :: i, i2, j
indentation = ' '
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>'
do i = 1,size(array),10
i2 = min( i + 9, size(array) )
write( info%lun, '(a,10i12)' ) indentation(1:min(indent+4,100)), &
( array(j) ,j = i,i2 )
enddo
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'</', trim(tag), '>'
end subroutine write_to_xml_integer_array
! write_to_xml_real_array --
! Routine to write an array of single precision reals to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! array Values to be written
!
subroutine write_to_xml_real_array( info, tag, indent, array )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
real, dimension(:), intent(in) :: array
character(len=100) :: indentation
integer :: i, i2, j
indentation = ' '
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>'
do i = 1,size(array),10
i2 = min( i + 9, size(array) )
write( info%lun, '(a,10g12.4)' ) indentation(1:min(indent+4,100)), &
( array(j) ,j = i,i2 )
enddo
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'</', trim(tag), '>'
end subroutine write_to_xml_real_array
! write_to_xml_double_array --
! Routine to write an array of double precision reals to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! array Values to be written
!
subroutine write_to_xml_double_array( info, tag, indent, array )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
real(kind=kind(1.0d0)), dimension(:), intent(in) :: array
character(len=100) :: indentation
integer :: i, i2, j
indentation = ' '
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>'
do i = 1,size(array),5
i2 = min( i + 4, size(array) )
write( info%lun, '(a,5g20.7)' ) indentation(1:min(indent+4,100)), &
( array(j) ,j = i,i2 )
enddo
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'</', trim(tag), '>'
end subroutine write_to_xml_double_array
! write_to_xml_logical_array --
! Routine to write an array of logicals to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! array Values to be written
!
subroutine write_to_xml_logical_array( info, tag, indent, array )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
logical, dimension(:), intent(in) :: array
character(len=100) :: indentation
integer :: i, i2, j
indentation = ' '
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>'
do i = 1,size(array),10
i2 = min( i + 9, size(array) )
write( info%lun, '(a,10a)' ) indentation(1:min(indent+4,100)), &
( merge('true ', 'false ', array(j)) ,j = i,i2 )
enddo
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'</', trim(tag), '>'
end subroutine write_to_xml_logical_array
! write_to_xml_word_array --
! Routine to write an array of words to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! array Values to be written
!
subroutine write_to_xml_word_array( info, tag, indent, array )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
character(len=*), dimension(:), intent(in) :: array
character(len=100) :: indentation
integer :: i, i2, j
indentation = ' '
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>'
do i = 1,size(array),10
i2 = min( i + 9, size(array) )
write( info%lun, '(a,20a)' ) indentation(1:min(indent+4,100)), &
( trim(array(j)) , ' ' ,j = i,i2 )
enddo
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'</', trim(tag), '>'
end subroutine write_to_xml_word_array
! write_to_xml_line_array --
! Routine to write an array of lines to the XML file
!
! Arguments:
! info XML parser structure
! tag The tag in question
! indent Number of spaces for indentation
! array Values to be written
!
subroutine write_to_xml_line_array( info, tag, indent, array )
type(XML_PARSE), intent(in) :: info
character(len=*), intent(in) :: tag
integer, intent(in) :: indent
logical, dimension(:), intent(in) :: array
character(len=100) :: indentation
integer :: i
indentation = ' '
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'<', trim(tag), '>'
do i = 1,size(array)
write( info%lun, '(a)' ) indentation(1:min(indent+4,100)), &
array(i)
enddo
write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
'</', trim(tag), '>'
end subroutine write_to_xml_line_array
end module write_xml_primitives

37
src/xml-fortran/xml-fortran.LICENSE
View file

@ -1,37 +0,0 @@
Note: The official xml-fortran repository on sourceforge
<http://xml-fortran.sourceforge.net> only lists the license as "BSD License". It
is assumed that this refers to the 3-clause BSD license ("modified" or "new")
that is shown below.
The license for xml-fortran covers all source code in the xml-fortran/
directory.
================================================================================
Copyright (c) 2008 Arjen Markus
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* Neither the name of Arjen Markus nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL ARJEN MARKUS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

1076
src/xml-fortran/xmlparse.f90
View file

File diff suppressed because it is too large Load diff

1241
src/xml-fortran/xmlreader.f90
View file

File diff suppressed because it is too large Load diff

71
src/xml/LICENSE Normal file
View file

@ -0,0 +1,71 @@
FoX - Fortran XML library
FoX was originally derived from the xmlf90 codebase,
(c) Alberto Garcia & Jon Wakelin, 2003-2004.
FoX also includes externally-written code from
Scott Ladd <scott.ladd@coyotegulch.com>, which is licensed
as shown in the file utils/fox_m_utils_mtprng.f90
This version of FoX is:
(c) 2005-2009 Toby White <tow@uszla.me.uk>
(c) 2007-2009 Gen-Tao Chiang <gtc25@cam.ac.uk>
(c) 2008-2012 Andrew Walker <a.walker@ucl.ac.uk>
All rights reserved.
* Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of the copyright holder nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
This distribution also includes code wrtten by Scott Ladd
utils/,
! This computer program source file is supplied "AS IS". Scott Robert <br />
! Ladd (hereinafter referred to as "Author") disclaims all warranties, <br />
! expressed or implied, including, without limitation, the warranties <br />
! of merchantability and of fitness for any purpose. The Author <br />
! assumes no liability for direct, indirect, incidental, special, <br />
! exemplary, or consequential damages, which may result from the use <br />
! of this software, even if advised of the possibility of such damage. <br />
! <br />
! The Author hereby grants anyone permission to use, copy, modify, and <br />
! distribute this source code, or portions hereof, for any purpose, <br />
! without fee, subject to the following restrictions: <br />
! <br />
! 1. The origin of this source code must not be misrepresented. <br />
! <br />
! 2. Altered versions must be plainly marked as such and must not <br />
! be misrepresented as being the original source. <br />
! <br />
! 3. This Copyright notice may not be removed or altered from any <br />
! source or altered source distribution. <br />
! <br />
! The Author specifically permits (without fee) and encourages the use <br />
! of this source code for entertainment, education, or decoration. If <br />
! you use this source code in a product, acknowledgment is not required <br />
! but would be appreciated.

32
src/xml/Makefile Normal file
View file

@ -0,0 +1,32 @@
xml_lib = lib/libxml.a
#===============================================================================
# Targets
#===============================================================================
$(xml_lib):
mkdir -p include
mkdir -p lib
cd fsys; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
cd utils; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
cd common; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
cd wxml; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
cd sax; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
cd dom; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
cd lib; ar rcs libxml.a *.o; rm -f *.o
clean:
cd fsys; make clean
cd utils; make clean
cd common; make clean
cd wxml; make clean
cd sax; make clean
cd dom; make clean
@rm -r -f include
@rm -r -f lib
#===============================================================================
# Rules
#===============================================================================
.PHONY: clean

3
src/xml/README Normal file
View file

@ -0,0 +1,3 @@
This directory contains source code from FoX - A Fortran Library for XML
Current version is 4.1.2
www1.gly.bris.ac.uk/~walker/FoX/

55
src/xml/common/FoX_common.F90 Normal file
View file

@ -0,0 +1,55 @@
module FoX_common
use fox_m_fsys_array_str
use fox_m_fsys_format
use fox_m_fsys_parse_input
use fox_m_fsys_count_parse_input
use m_common_attrs
use m_common_error
implicit none
private
#ifdef DUMMYLIB
character(len=*), parameter :: FoX_version = '4.1.2-dummy'
#else
character(len=*), parameter :: FoX_version = '4.1.2'
#endif
public :: FoX_version
public :: rts
public :: countrts
public :: str
public :: operator(//)
public :: FoX_set_fatal_errors
public :: FoX_get_fatal_errors
public :: FoX_set_fatal_warnings
public :: FoX_get_fatal_warnings
#ifndef DUMMYLIB
public :: str_vs
public :: vs_str
public :: alloc
public :: concat
#endif
!These are all exported through SAX now
public :: dictionary_t
!SAX functions
public :: getIndex
public :: getLength
public :: getLocalName
public :: getQName
public :: getURI
public :: getValue
public :: getType
public :: isSpecified
public :: isDeclared
public :: setSpecified
public :: setDeclared
!For convenience
public :: hasKey
end module FoX_common

59
src/xml/common/Makefile Normal file
View file

@ -0,0 +1,59 @@
source = $(wildcard *.F90)
objects = $(source:.F90=.o)
#===============================================================================
# Compiler Options
#===============================================================================
# Ignore unusd variables
ifeq ($(MACHINE),bluegene)
override F90 = xlf2003
endif
ifeq ($(F90),ifort)
override F90FLAGS += -warn nounused
endif
#===============================================================================
# Targets
#===============================================================================
all: $(objects)
mv *.mod ../include
mv *.o ../lib
clean:
@rm -f *.o *.mod
neat:
@rm -f *.o *.mod
#===============================================================================
# Rules
#===============================================================================
.SUFFIXES: .F90 .o
.PHONY: clean neat
%.o: %.F90
$(F90) $(F90FLAGS) -c -I../include $<
#===============================================================================
# Dependencies
#===============================================================================
FoX_common.o: m_common_attrs.o
m_common_attrs.o: m_common_element.o m_common_error.o
m_common_buffer.o: m_common_charset.o m_common_error.o
m_common_element.o: m_common_charset.o m_common_content_model.o m_common_error.o m_common_namecheck.o
m_common_elstack.o: m_common_content_model.o m_common_error.o
m_common_entities.o: m_common_charset.o m_common_error.o
m_common_entity_expand.o: m_common_entities.o m_common_error.o
m_common_entity_expand.o: m_common_namecheck.o m_common_struct.o
m_common_io.o: m_common_error.o
m_common_namecheck.o: m_common_charset.o
m_common_namespaces.o: m_common_attrs.o m_common_charset.o m_common_error.o
m_common_namespaces.o: m_common_namecheck.o m_common_struct.o
m_common_notations.o: m_common_error.o
m_common_struct.o: m_common_charset.o m_common_element.o m_common_entities.o
m_common_struct.o: m_common_notations.o

1081
src/xml/common/m_common_attrs.F90 Normal file
View file

File diff suppressed because it is too large Load diff

261
src/xml/common/m_common_buffer.F90 Normal file
View file

@ -0,0 +1,261 @@
module m_common_buffer
#ifndef DUMMYLIB
use fox_m_fsys_format, only: str
use m_common_charset, only: XML1_0
use m_common_error, only: FoX_error, FoX_warning
implicit none
private
! At this point we use a fixed-size buffer.
! Note however that buffer overflows will only be
! triggered by overly long *unbroken* pcdata values, or
! by overly long attribute values. Hopefully
! element or attribute names are "short enough".
!
! In a forthcoming implementation it could be made dynamical...
! MAX_BUFF_SIZE cannot be bigger than the maximum available
! record length for a compiler. In practice, this means
! 1024 seems to be the biggest available size.
integer, parameter :: MAX_BUFF_SIZE = 1024
type buffer_t
private
integer :: size
character(len=MAX_BUFF_SIZE) :: str
integer :: unit
integer :: xml_version
end type buffer_t
public :: buffer_t
public :: add_to_buffer
public :: print_buffer, str, char, len
public :: buffer_to_chararray
public :: reset_buffer
public :: dump_buffer
interface str
module procedure buffer_to_str
end interface
interface char
module procedure buffer_to_str
end interface
interface len
module procedure buffer_length
end interface
contains
subroutine reset_buffer(buffer, unit, xml_version)
type(buffer_t), intent(inout) :: buffer
integer, intent(in), optional :: unit
integer, intent(in) :: xml_version
buffer%size = 0
if (present(unit)) then
buffer%unit = unit
else
buffer%unit = 6
endif
buffer%xml_version = xml_version
end subroutine reset_buffer
subroutine print_buffer(buffer)
type(buffer_t), intent(in) :: buffer
write(unit=6,fmt="(a)") buffer%str(:buffer%size)
end subroutine print_buffer
function buffer_to_str(buffer) result(str)
type(buffer_t), intent(in) :: buffer
character(len=buffer%size) :: str
str = buffer%str(:buffer%size)
end function buffer_to_str
function buffer_to_chararray(buffer) result(str)
type(buffer_t), intent(in) :: buffer
character(len=1), dimension(buffer%size) :: str
integer :: i
do i = 1, buffer%size
str(i) = buffer%str(i:i)
enddo
end function buffer_to_chararray
function buffer_length(buffer) result(length)
type(buffer_t), intent(in) :: buffer
integer :: length
length = buffer%size
end function buffer_length
subroutine dump_buffer(buffer, lf)
type(buffer_t), intent(inout) :: buffer
logical, intent(in), optional :: lf
integer :: i, n
logical :: lf_
if (present(lf)) then
lf_ = lf
else
lf_ = .true.
endif
i = scan(buffer%str(:buffer%size), achar(10)//achar(13))
n = 1
do while (i>0)
write(buffer%unit, '(a)', advance="yes") buffer%str(n:n+i-2)
n = n + i
if (n>buffer%size) exit
i = scan(buffer%str(n:), achar(10)//achar(13))
enddo
if (n<=buffer%size) then
if (lf_) then
write(buffer%unit, '(a)', advance="yes") buffer%str(n:buffer%size)
else
write(buffer%unit, '(a)', advance="no") buffer%str(n:buffer%size)
endif
endif
buffer%size = 0
end subroutine dump_buffer
subroutine check_buffer(s, version)
character(len=*), intent(in) :: s
integer, intent(in) :: version
integer :: i
!FIXME this is almost a duplicate of logic in wxml/m_wxml_escape.f90
! We have to do it this way (with achar etc) in case the native
! platform encoding is not ASCII
do i = 1, len(s)
select case (iachar(s(i:i)))
case (0)
call FoX_error("Tried to output a NUL character")
case (1:8,11:12,14:31)
if (version==XML1_0) then
call FoX_error("Tried to output a character invalid under XML 1.0: &#"//str(iachar(s(i:i)))//";")
endif
case (128:)
!TOHW we should maybe just disallow this ...
call FoX_warning("emitting non-ASCII character. Platform-dependent result!")
end select
enddo
end subroutine check_buffer
subroutine add_to_buffer(s, buffer, ws_significant)
character(len=*), intent(in) :: s
type(buffer_t), intent(inout) :: buffer
logical, intent(in), optional :: ws_significant
character(len=(buffer%size+len(s))) :: s2
integer :: i, n, len_b
logical :: warning, ws_
! Is whitespace significant in this context?
! We have to assume so unless told otherwise.
if (present(ws_significant)) then
ws_ = ws_significant
else
ws_ = .true.
endif
! FIXME The algorithm below unilaterally forces all
! line feeds and carriage returns to native EOL, regardless
! of input document. Thus it is impossible to output a
! document containing a literal non-native newline character
! Ideally we would put this under the control of the user.
! We check if whitespace is significant. If not, we can
! adjust the buffer without worrying about it.
! But if we are not told, we warn about it.
! And if we are told it definitely is - then we error out.
! If we overreach our buffer size, we will be unable to
! output any more characters without a newline.
! Go through new string, insert newlines
! at spaces just before MAX_BUFF_SIZE chars
! until we have less than MAX_BUFF_SIZE left to go,
! then put that in the buffer.
! If no whitespace is found in the newly-added string, then
! insert a new line immediately before it (at the end of the
! current buffer)
call check_buffer(s, buffer%xml_version)
s2 = buffer%str(:buffer%size)//s
! output as much of this using existing newlines as possible.
warning = .false.
n = 1
do while (n<=len(s2))
! Note this is an XML-1.0 only definition of newline
i = scan(s2(n:), achar(10)//achar(13))
if (i>0) then
! turn that newline into an output newline ...
write(buffer%unit, '(a)') s2(n:n+i-2)
n = n + i
elseif (n<=len(s2)-MAX_BUFF_SIZE) then
! We need to insert a newline, or we'll overrun the buffer
! No suitable newline, so convert a space or tab into a newline.
i = scan(s2(n:n+MAX_BUFF_SIZE-1), achar(9)//achar(32), back=.true.)
! If no space or tab is present, we fail.
if (i>0.and..not.present(ws_significant)) then
! We can insert a newline, but we don't know whether it is significant. Warn:
if (.not.warning) then
! We only output this warning once.
call FoX_warning( &
"Fortran made FoX insert a newline. "// &
"If whitespace might be significant, check your output.")
warning = .true.
endif
elseif (i==0) then
call FoX_error( &
"Fortran made FoX insert a newline but it can't. Stopping now.")
elseif (ws_) then
call FoX_error( &
"Fortran made FoX insert a newline but whitespace is significant. Stopping now.")
else
continue ! without error or warning, because whitespace is not significant
endif
write(buffer%unit, '(a)') s2(n:n+i-1)
n = n + i
else
! We don't need to do anything, just add the remainder to the buffer.
exit
endif
enddo
len_b = len(s2) - n + 1
buffer%str(:len_b) = s2(n:)
buffer%size = len_b
end subroutine add_to_buffer
#endif
end module m_common_buffer

447
src/xml/common/m_common_charset.F90 Normal file
View file

@ -0,0 +1,447 @@
module m_common_charset
#ifndef DUMMYLIB
! Written to use ASCII charset only. Full UNICODE would
! take much more work and need a proper unicode library.
use fox_m_fsys_string, only: toLower
implicit none
private
!!$ character(len=1), parameter :: ASCII = &
!!$achar(0)//achar(1)//achar(2)//achar(3)//achar(4)//achar(5)//achar(6)//achar(7)//achar(8)//achar(9)//&
!!$achar(10)//achar(11)//achar(12)//achar(13)//achar(14)//achar(15)//achar(16)//achar(17)//achar(18)//achar(19)//&
!!$achar(20)//achar(21)//achar(22)//achar(23)//achar(24)//achar(25)//achar(26)//achar(27)//achar(28)//achar(29)//&
!!$achar(30)//achar(31)//achar(32)//achar(33)//achar(34)//achar(35)//achar(36)//achar(37)//achar(38)//achar(39)//&
!!$achar(40)//achar(41)//achar(42)//achar(43)//achar(44)//achar(45)//achar(46)//achar(47)//achar(48)//achar(49)//&
!!$achar(50)//achar(51)//achar(52)//achar(53)//achar(54)//achar(55)//achar(56)//achar(57)//achar(58)//achar(59)//&
!!$achar(60)//achar(61)//achar(62)//achar(63)//achar(64)//achar(65)//achar(66)//achar(67)//achar(68)//achar(69)//&
!!$achar(70)//achar(71)//achar(72)//achar(73)//achar(74)//achar(75)//achar(76)//achar(77)//achar(78)//achar(79)//&
!!$achar(80)//achar(81)//achar(82)//achar(83)//achar(84)//achar(85)//achar(86)//achar(87)//achar(88)//achar(89)//&
!!$achar(90)//achar(91)//achar(92)//achar(93)//achar(94)//achar(95)//achar(96)//achar(97)//achar(98)//achar(99)//&
!!$achar(100)//achar(101)//achar(102)//achar(103)//achar(104)//achar(105)//achar(106)//achar(107)//achar(108)//achar(109)//&
!!$achar(110)//achar(111)//achar(112)//achar(113)//achar(114)//achar(115)//achar(116)//achar(117)//achar(118)//achar(119)//&
!!$achar(120)//achar(121)//achar(122)//achar(123)//achar(124)//achar(125)//achar(126)//achar(127)
character(len=1), parameter :: SPACE = achar(32)
character(len=1), parameter :: NEWLINE = achar(10)
character(len=1), parameter :: CARRIAGE_RETURN = achar(13)
character(len=1), parameter :: TAB = achar(9)
character(len=*), parameter :: whitespace = SPACE//NEWLINE//CARRIAGE_RETURN//TAB
character(len=*), parameter :: lowerCase = "abcdefghijklmnopqrstuvwxyz"
character(len=*), parameter :: upperCase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
character(len=*), parameter :: digits = "0123456789"
character(len=*), parameter :: hexdigits = "0123456789abcdefABCDEF"
character(len=*), parameter :: InitialNCNameChars = lowerCase//upperCase//"_"
character(len=*), parameter :: NCNameChars = InitialNCNameChars//digits//".-"
character(len=*), parameter :: InitialNameChars = InitialNCNameChars//":"
character(len=*), parameter :: NameChars = NCNameChars//":"
character(len=*), parameter :: PubIdChars = NameChars//whitespace//"'()+,/=?;!*#@$%"
character(len=*), parameter :: validchars = &
whitespace//"!""#$%&'()*+,-./"//digits// &
":;<=>?@"//upperCase//"[\]^_`"//lowerCase//"{|}~"
! these are all the standard ASCII printable characters: whitespace + (33-126)
! which are the only characters we can guarantee to know how to handle properly.
integer, parameter :: XML1_0 = 10 ! NB 0x7F was legal in XML-1.0, but illegal in XML-1.1
integer, parameter :: XML1_1 = 11
character(len=*), parameter :: XML1_0_ILLEGALCHARS = achar(0)
character(len=*), parameter :: XML1_1_ILLEGALCHARS = NameChars
character(len=*), parameter :: XML1_0_INITIALNAMECHARS = InitialNameChars
character(len=*), parameter :: XML1_1_INITIALNAMECHARS = InitialNameChars
character(len=*), parameter :: XML1_0_NAMECHARS = NameChars
character(len=*), parameter :: XML1_1_NAMECHARS = NameChars
character(len=*), parameter :: XML1_0_INITIALNCNAMECHARS = InitialNCNameChars
character(len=*), parameter :: XML1_1_INITIALNCNAMECHARS = InitialNCNameChars
character(len=*), parameter :: XML1_0_NCNAMECHARS = NCNameChars
character(len=*), parameter :: XML1_1_NCNAMECHARS = NCNameChars
character(len=*), parameter :: XML_WHITESPACE = whitespace
character(len=*), parameter :: XML_INITIALENCODINGCHARS = lowerCase//upperCase
character(len=*), parameter :: XML_ENCODINGCHARS = lowerCase//upperCase//digits//'._-'
public :: validchars
public :: whitespace
public :: uppercase
public :: digits
public :: hexdigits
public :: XML1_0
public :: XML1_1
public :: XML1_0_NAMECHARS
public :: XML1_1_NAMECHARS
public :: XML1_0_INITIALNAMECHARS
public :: XML1_1_INITIALNAMECHARS
public :: XML_WHITESPACE
public :: XML_INITIALENCODINGCHARS
public :: XML_ENCODINGCHARS
public :: isLegalChar
public :: isLegalCharRef
public :: isRepCharRef
public :: isInitialNameChar
public :: isNameChar
public :: isInitialNCNameChar
public :: isNCNameChar
public :: isXML1_0_NameChar
public :: isXML1_1_NameChar
public :: checkChars
public :: isUSASCII
public :: allowed_encoding
contains
pure function isLegalChar(c, ascii_p, xml_version) result(p)
character, intent(in) :: c
! really we should check the encoding here & be more intelligent
! for now we worry only about is it ascii or not.
logical, intent(in) :: ascii_p
integer, intent(in) :: xml_version
logical :: p
! Is this character legal as a source character in the document?
integer :: i
i = iachar(c)
if (i<0) then
p = .false.
return
elseif (i>127) then
p = .not.ascii_p
return
! ie if we are ASCII, then >127 is definitely illegal.
! otherwise maybe it's ok
endif
select case(xml_version)
case (XML1_0)
p = (i==9.or.i==10.or.i==13.or.(i>31.and.i<128))
case (XML1_1)
p = (i==9.or.i==10.or.i==13.or.(i>31.and.i<127))
! NB 0x7F was legal in XML-1.0, but illegal in XML-1.1
end select
end function isLegalChar
pure function isLegalCharRef(i, xml_version) result(p)
integer, intent(in) :: i
integer, intent(in) :: xml_version
logical :: p
! Is Unicode character #i legal as a character reference?
if (xml_version==XML1_0) then
p = (i==9).or.(i==10).or.(i==13).or.(i>31.and.i<55296).or.(i>57343.and.i<65534).or.(i>65535.and.i<1114112)
elseif (xml_version==XML1_1) then
p = (i>0.and.i<55296).or.(i>57343.and.i<65534).or.(i>65535.and.i<1114112)
! XML 1.1 made all control characters legal as character references.
end if
end function isLegalCharRef
pure function isRepCharRef(i, xml_version) result(p)
integer, intent(in) :: i
integer, intent(in) :: xml_version
logical :: p
! Is Unicode character #i legal and representable here?
if (xml_version==XML1_0) then
p = (i==9).or.(i==10).or.(i==13).or.(i>31.and.i<128)
elseif (xml_version==XML1_1) then
p = (i>0.and.i<128)
! XML 1.1 made all control characters legal as character references.
end if
end function isRepCharRef
pure function isInitialNameChar(c, xml_version) result(p)
character, intent(in) :: c
integer, intent(in) :: xml_version
logical :: p
select case(xml_version)
case (XML1_0)
p = (verify(c, XML1_0_INITIALNAMECHARS)==0)
case (XML1_1)
p = (verify(c, XML1_1_INITIALNAMECHARS)==0)
end select
end function isInitialNameChar
pure function isNameChar(c, xml_version) result(p)
character(len=*), intent(in) :: c
integer, intent(in) :: xml_version
logical :: p
select case(xml_version)
case (XML1_0)
p = (verify(c, XML1_0_NAMECHARS)==0)
case (XML1_1)
p = (verify(c, XML1_1_NAMECHARS)==0)
end select
end function isNameChar
pure function isInitialNCNameChar(c, xml_version) result(p)
character, intent(in) :: c
integer, intent(in) :: xml_version
logical :: p
select case(xml_version)
case (XML1_0)
p = (verify(c, XML1_0_INITIALNCNAMECHARS)==0)
case (XML1_1)
p = (verify(c, XML1_1_INITIALNCNAMECHARS)==0)
end select
end function isInitialNCNameChar
pure function isNCNameChar(c, xml_version) result(p)
character(len=*), intent(in) :: c
integer, intent(in) :: xml_version
logical :: p
select case(xml_version)
case (XML1_0)
p = (verify(c, XML1_0_NCNAMECHARS)==0)
case (XML1_1)
p = (verify(c, XML1_1_NCNAMECHARS)==0)
end select
end function isNCNameChar
function isXML1_0_NameChar(c) result(p)
character, intent(in) :: c
logical :: p
p = (verify(c, XML1_0_NAMECHARS)==0)
end function isXML1_0_NameChar
function isXML1_1_NameChar(c) result(p)
character, intent(in) :: c
logical :: p
p = (verify(c, XML1_1_NAMECHARS)==0)
end function isXML1_1_NameChar
pure function checkChars(value, xv) result(p)
character(len=*), intent(in) :: value
integer, intent(in) :: xv
logical :: p
! This checks if value only contains values
! legal to appear (escaped or unescaped)
! according to whichever XML version is in force.
integer :: i
p = .true.
do i = 1, len(value)
if (xv == XML1_0) then
select case(iachar(value(i:i)))
case (0,8)
p = .false.
case (11,12)
p = .false.
end select
else
if (iachar(value(i:i))==0) p =.false.
endif
enddo
end function checkChars
function isUSASCII(encoding) result(p)
character(len=*), intent(in) :: encoding
logical :: p
character(len=len(encoding)) :: enc
enc = toLower(encoding)
p = (enc=="ansi_x3.4-1968" &
.or. enc=="ansi_x3.4-1986" &
.or. enc=="iso_646.irv:1991" &
.or. enc=="ascii" &
.or. enc=="iso646-us" &
.or. enc=="us-ascii" &
.or. enc=="us" &
.or. enc=="ibm367" &
.or. enc=="cp367" &
.or. enc=="csascii")
end function isUSASCII
function allowed_encoding(encoding) result(p)
character(len=*), intent(in) :: encoding
logical :: p
character(len=len(encoding)) :: enc
logical :: utf8, usascii, iso88591, iso88592, iso88593, iso88594, &
iso88595, iso88596, iso88597, iso88598, iso88599, iso885910, &
iso885913, iso885914, iso885915, iso885916
enc = toLower(encoding)
! From http://www.iana.org/assignments/character-sets
! We can only reliably do US-ASCII (the below is mostly
! a list of synonyms for US-ASCII) but we also accept
! UTF-8 as a practicality. We bail out if any non-ASCII
! characters are used later on.
utf8 = (enc=="utf-8")
usascii = (enc=="ansi_x3.4-1968" &
.or. enc=="ansi_x3.4-1986" &
.or. enc=="iso_646.irv:1991" &
.or. enc=="ascii" &
.or. enc=="iso646-us" &
.or. enc=="us-ascii" &
.or. enc=="us" &
.or. enc=="ibm367" &
.or. enc=="cp367" &
.or. enc=="csascii")
! As of FoX 4.0, we accept ISO-8859-??, also as practicality
! since we know it is identical to ASCII as far as 0x7F
iso88591 = (enc =="iso_8859-1:1987" &
.or. enc=="iso-ir-100" &
.or. enc=="iso_8859-1" &
.or. enc=="iso-8859-1" &
.or. enc=="latin1" &
.or. enc=="l1" &
.or. enc=="ibm819" &
.or. enc=="cp819" &
.or. enc=="csisolatin1")
iso88592 = (enc=="iso_8859-2:1987" &
.or. enc=="iso-ir-101" &
.or. enc=="iso_8859-2" &
.or. enc=="iso-8859-2" &
.or. enc=="latin2" &
.or. enc=="l2" &
.or. enc=="csisolatin2")
iso88593 = (enc=="iso_8859-3:1988" &
.or. enc=="iso-ir-109" &
.or. enc=="iso_8859-3" &
.or. enc=="iso-8859-3" &
.or. enc=="latin3" &
.or. enc=="l3" &
.or. enc=="csisolatin3")
iso88594 = (enc=="iso_8859-4:1988" &
.or. enc=="iso-ir-110" &
.or. enc=="iso_8859-4" &
.or. enc=="iso-8859-4" &
.or. enc=="latin4" &
.or. enc=="l4" &
.or. enc=="csisolatin4")
iso88595 = (enc=="iso_8859-5:1988" &
.or. enc=="iso-ir-144" &
.or. enc=="iso_8859-5" &
.or. enc=="iso-8859-5" &
.or. enc=="cyrillic" &
.or. enc=="csisolatincyrillic")
iso88596 = (enc=="iso_8859-6:1987" &
.or. enc=="iso-ir-127" &
.or. enc=="iso_8859-6" &
.or. enc=="iso-8859-6" &
.or. enc=="ecma-114" &
.or. enc=="asmo-708" &
.or. enc=="arabic" &
.or. enc=="csisolatinarabic")
iso88597 = (enc=="iso_8859-7:1987" &
.or. enc=="iso-ir-126" &
.or. enc=="iso_8859-7" &
.or. enc=="iso-8859-7" &
.or. enc=="elot_928" &
.or. enc=="ecma-118" &
.or. enc=="greek" &
.or. enc=="greek8" &
.or. enc=="csisolatingreek")
iso88598 = (enc=="iso_8859-8:1988" &
.or. enc=="iso-ir-138" &
.or. enc=="iso_8859-8" &
.or. enc=="iso-8859-8" &
.or. enc=="hebrew" &
.or. enc=="csisolatinhebrew")
iso88599 = (enc=="iso_8859-9:1989" &
.or. enc=="iso-ir-148" &
.or. enc=="iso_8859-9" &
.or. enc=="iso-8859-9" &
.or. enc=="latin5" &
.or. enc=="l5" &
.or. enc=="csisolatin5")
iso885910 = (enc=="iso-8859-10" &
.or. enc=="iso-ir-157" &
.or. enc=="l6" &
.or. enc=="iso_8859-10:1992" &
.or. enc=="csisolatin6" &
.or. enc=="latin6")
! ISO 6937 replaces $ sign with currency sign.
! JIS-X0201 has Yen instead of backslash, macron instead of tilde
! 16, 17, 18, 19 - Japanese encoding we can't use.
! BS 4730 replaces hash with UK pound sign, and tilde to macron
! 21, 22, 23, 24, 25, 26 - other variants of iso646, similar but not identical
! iso10646utf1 = (enc=="iso-10646-utf-1") ! FIXME check
! iso656basic1983 = (enc=="iso_646.basic:1983" &
! .or. enc=="csiso646basic1983") ! FIXME check
! INVARIANT - almost but not quite a subset of ASCII
! iso646irv = (enc=="iso_646.irv:1983" &
! .or. enc=="iso-ir-2" &
! .or. enc=="irv")
! 31, 32, 33, 34 - NATS scandinavian, different from ASCII
! 35 - another iso646 variant
! 36, 37, 38 Korean shifted/multibyte
! 39, 40 Japanese shifted/multibyte
! 41, 42, JIS (iso646inv 7 bits)
! 43 another iso646 variantt
! 44, 45 greek variants
! 46 another iso646 variant
! 47 greek
! 48 cyrillic ascii relationship unknown
! 49 JIS again
! 50 similar not identical
! 51, 52, 53 not identical
! 54 see 48
! 55 see 47
! 56 another iso646 variant
! 57 chinese
! ... to be continued
iso885913 = (enc=="iso-8859-13")
iso885914 = (enc=="iso-8859-14" &
.or. enc=="iso-ir-199" &
.or. enc=="iso_8859-14:1998" &
.or. enc=="iso_8849-14" &
.or. enc=="iso_latin8" &
.or. enc=="iso-celtic" &
.or. enc=="l8")
iso885915 = (enc=="iso-8859-15" &
.or. enc=="iso-8859-15" &
.or. enc=="latin-9")
iso885916 = (enc=="iso-8859-16" &
.or. enc=="iso-ir226" &
.or. enc=="iso_8859-16:2001" &
.or. enc=="iso_8859-16" &
.or. enc=="latin10" &
.or. enc=="l10")
p = utf8.or.usascii.or.iso88591.or.iso88592.or.iso88593 &
.or.iso88594.or.iso88595.or.iso88596.or.iso88597 &
.or.iso88598.or.iso88599.or.iso885910.or.iso885913 &
.or.iso885914.or.iso885915.or.iso885916
end function allowed_encoding
#endif
end module m_common_charset

490
src/xml/common/m_common_content_model.F90 Normal file
View file

@ -0,0 +1,490 @@
module m_common_content_model
#ifndef DUMMYLIB
! Allow validating the content model of an XML document
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc
implicit none
private
integer, parameter :: OP_NULL = 0
integer, parameter :: OP_EMPTY = 1
integer, parameter :: OP_ANY = 2
integer, parameter :: OP_MIXED = 3
integer, parameter :: OP_NAME = 4
integer, parameter :: OP_CHOICE = 5
integer, parameter :: OP_SEQ = 6
integer, parameter :: REP_NULL = 0
integer, parameter :: REP_ONCE = 1
integer, parameter :: REP_QUESTION_MARK = 2
integer, parameter :: REP_ASTERISK = 3
type content_particle_t
character, pointer :: name(:) => null()
integer :: operator = OP_NULL
integer :: repeater = REP_NULL
type(content_particle_t), pointer :: nextSibling => null()
type(content_particle_t), pointer :: parent => null()
type(content_particle_t), pointer :: firstChild => null()
end type content_particle_t
public :: content_particle_t
public :: newCP
public :: transformCPPlus
public :: checkCP
public :: checkCPToEnd
public :: elementContentCP
public :: emptyContentCP
public :: destroyCPtree
public :: dumpCPtree
public :: OP_NULL, OP_NAME, OP_MIXED, OP_CHOICE, OP_SEQ
public :: REP_QUESTION_MARK, REP_ASTERISK
contains
function newCP(empty, any, name, repeat) result(cp)
logical, intent(in), optional :: empty
logical, intent(in), optional :: any
character(len=*), intent(in), optional :: name
character, intent(in), optional :: repeat
type(content_particle_t), pointer :: cp
allocate(cp)
if (present(empty)) then
cp%operator = OP_EMPTY
elseif (present(any)) then
cp%operator = OP_ANY
elseif (present(name)) then
cp%operator = OP_NAME
cp%name => vs_str_alloc(name)
else
cp%operator = OP_SEQ
endif
if (present(repeat)) then
select case (repeat)
case("?")
cp%repeater = REP_QUESTION_MARK
case("*")
cp%repeater = REP_ASTERISK
end select
endif
end function newCP
function copyCP(cp) result(cp_out)
type(content_particle_t), pointer :: cp
type(content_particle_t), pointer :: cp_out
allocate(cp_out)
if (associated(cp%name)) cp_out%name => vs_vs_alloc(cp%name)
cp_out%operator = cp%operator
cp_out%repeater = cp%repeater
end function copyCP
function copyCPtree(cp) result(cp_out)
type(content_particle_t), pointer :: cp
type(content_particle_t), pointer :: cp_out
type(content_particle_t), pointer :: tcp, tcp_out, tcpn_out, tcpp_out
logical :: done
tcp => cp
cp_out => copyCP(cp)
tcp_out => cp_out
done = .false.
do while (associated(tcp_out))
if (.not.done) then
do while (associated(tcp%firstChild))
tcp => tcp%firstChild
tcpn_out => copyCP(tcp)
tcp_out%firstChild => tcpn_out
tcpn_out%parent => tcp_out
tcp_out => tcpn_out
enddo
endif
tcpp_out => tcp_out%parent
if (associated(tcp%nextSibling)) then
done = .false.
tcp => tcp%nextSibling
tcpn_out => copyCP(tcp)
tcp_out%nextSibling => tcpn_out
tcpn_out%parent => tcpp_out
tcp_out => tcpn_out
else
done = .true.
tcp => tcp%parent
tcp_out => tcp_out%parent
endif
enddo
end function copyCPtree
subroutine transformCPPlus(cp)
type(content_particle_t), pointer :: cp
type(content_particle_t), pointer :: tcp, cp_new
! Make copy of cp, and graft children on
cp_new => copyCP(cp)
cp_new%firstChild => cp%firstChild
! Reset children's parents ...
tcp => cp%firstChild
do while (associated(tcp))
tcp%parent => cp_new
tcp => tcp%nextSibling
enddo
! Clear cp & make it an SEQ
if (associated(cp%name)) deallocate(cp%name)
cp%operator = OP_SEQ
! Append our copied cp to the now-an-SEQ
cp%firstChild => cp_new
cp_new%parent => cp
! Copy it for a sibling, and make the sibling a *
cp_new%nextSibling => copyCPtree(cp_new)
cp_new%nextSibling%parent => cp
cp_new%nextSibling%repeater = REP_ASTERISK
end subroutine transformCPPlus
function checkCP(cp, name) result(p)
type(content_particle_t), pointer :: cp
character(len=*), intent(in) :: name
logical :: p
type(content_particle_t), pointer :: tcp
! for EMPTY, ANY or MIXED, cp never moves.
! for element content, we move the pointer as we
! move through the regex.
! If the regex includes ambiguous content, we are
! a bit screwed. But the document is in error if so.
! (and we are not required to diagnose errors.)
p = .false.
if (.not.associated(cp)) return
select case(cp%operator)
case (OP_EMPTY)
continue ! anything fails
case (OP_ANY)
p = .true.
case (OP_MIXED)
tcp => cp%firstChild
do while (associated(tcp))
if (name==str_vs(tcp%name)) then
p = .true.
exit
endif
tcp => tcp%nextSibling
enddo
case default
do
if (.not.associated(cp)) exit
select case (cp%operator)
case (OP_NAME)
p = (name==str_vs(cp%name))
if (p) then
tcp => nextCPAfterMatch(cp)
cp => tcp
exit
else
tcp => nextCPAfterFail(cp)
cp => tcp
endif
case (OP_CHOICE, OP_SEQ)
cp => cp%firstChild
end select
end do
end select
end function checkCP
function nextCPaftermatch(cp) result(cp_next)
type (content_particle_t), pointer :: cp
type (content_particle_t), pointer :: cp_next
type (content_particle_t), pointer :: tcp
cp_next => cp
do
if (cp_next%repeater==REP_ASTERISK) exit
tcp => cp_next%parent
if (associated(tcp)) then
if (tcp%operator==OP_CHOICE) then
! siblings are uninteresting, we've matched this CHOICE
cp_next => tcp
! Move up & try the whole thing again on the parent CHOICE
elseif (tcp%operator==OP_SEQ) then
! we do care about siblings, move onto next one
if (associated(cp_next%nextSibling)) then
cp_next => cp_next%nextSibling
! thatll do, itll be the next thing to try
exit
else
! No sibling, move up a level
cp_next => tcp
! and try again
endif
endif
else
! We've got to the top already.
cp_next => tcp
exit
endif
enddo
end function nextCPaftermatch
function nextCPafterfail(cp) result(cp_next)
type(content_particle_t), pointer :: cp
type(content_particle_t), pointer :: cp_next
type(content_particle_t), pointer :: tcp
logical :: match
match = .false.
cp_next => cp
do
tcp => cp_next%parent
if (associated(tcp)) then
if (tcp%operator==OP_CHOICE) then
! we care about siblings, lets try the next one
if (associated(cp_next%nextSibling)) then
cp_next => cp_next%nextSibling
! super, lets go back and try that
exit
else ! weve failed to match any cp in this CHOICE ...
cp_next => tcp
! go up a level and see if theres another legitimate choice
endif
elseif (tcp%operator==OP_SEQ) then
if ((match.or.cp_next%repeater/=REP_NULL) &
.and.associated(cp_next%nextSibling)) then
! we were allowed to fail to match, try sibling
cp_next => cp_next%nextSibling
exit
elseif (cp_next%repeater/=REP_NULL) then
match = .true.
! The last item was optional, so weve matched at this level
cp_next => tcp
elseif (associated(tcp%firstChild, cp_next)) then
! we havent matched - but we hadnt started, Maybe it was ok
! not to match because we are nested inside an optional thingy
cp_next => tcp
else
! We were not allowed to fail there,
! there is no legitimate next choice.
cp_next => null()
exit
endif
endif
else
! weve got all the way to the top without
! finding a new cp to try. But if this top-level
! cp is ASTERISK'ed we can try it agin
cp_next => null()
exit
endif
enddo
end function nextCPafterfail
function checkCPToEnd(cp) result(p)
type(content_particle_t), pointer :: cp
logical :: p
type(content_particle_t), pointer :: tcp
if (associated(cp)) then
select case(cp%operator)
case (OP_EMPTY, OP_ANY, OP_MIXED)
p = .true.
case default
tcp => nextCPMustMatch(cp)
p = .not.associated(tcp)
end select
else
p = .true.
endif
end function checkCPToEnd
function nextCPMustMatch(cp) result(cp_next)
type(content_particle_t), pointer :: cp
type(content_particle_t), pointer :: cp_next
type(content_particle_t), pointer :: tcp
if (.not.associated(cp)) return
if (.not.associated(cp%parent)) then
! we havent started exploring this one.
! get the first starting position
cp_next => cp
do while (cp_next%repeater==REP_NULL)
if (associated(cp_next%firstChild)) then
cp_next => cp_next%firstChild
else
exit
endif
enddo
else
cp_next => cp
endif
if (cp_next%repeater==REP_NULL) return
do
tcp => cp_next%parent
if (associated(tcp)) then
if (tcp%operator==OP_CHOICE) then
! its matched by the optional one we are on, go up a level
cp_next => tcp
elseif (tcp%operator==OP_SEQ) then
! check all siblings for any compulsory ones
do while (associated(cp_next%nextSibling))
cp_next => cp_next%nextSibling
if (cp_next%repeater==REP_NULL) return
enddo
! all were optional, go up a level
cp_next => tcp
endif
else
! weve got all the way to the top without
! finding a new cp to try
cp_next => tcp
exit
endif
enddo
end function nextCPMustMatch
function elementContentCP(cp) result(p)
type(content_particle_t), pointer :: cp
logical :: p
if (associated(cp)) then
select case (cp%operator)
case (OP_EMPTY, OP_ANY, OP_MIXED)
p = .false.
case default
p = .true.
end select
else
p = .true.
endif
end function elementContentCP
function emptyContentCP(cp) result(p)
type(content_particle_t), pointer :: cp
logical :: p
if (associated(cp)) then
p = cp%operator==OP_EMPTY
else
p = .false.
endif
end function emptyContentCP
subroutine destroyCP(cp)
type(content_particle_t), pointer :: cp
if (associated(cp%name)) deallocate(cp%name)
deallocate(cp)
end subroutine destroyCP
subroutine destroyCPtree(cp)
type(content_particle_t), pointer :: cp
type(content_particle_t), pointer :: current, tcp
current => cp
do
do while (associated(current%firstChild))
current => current%firstChild
enddo
if (associated(current, cp)) exit
tcp => current
if (associated(current%nextSibling)) then
current => current%nextSibling
call destroyCP(tcp)
else
current => current%parent
call destroyCP(tcp)
current%firstChild => null()
endif
enddo
call destroyCP(cp)
end subroutine destroyCPtree
subroutine dumpCP(cp)
type(content_particle_t), pointer :: cp
select case(cp%operator)
case (OP_EMPTY)
write(*,'(a)', advance="no") "EMPTY"
case (OP_ANY)
write(*,'(a)', advance="no") "ANY"
case (OP_MIXED)
write(*,'(a)', advance="no") "MIXED"
case (OP_NAME)
write(*,'(a)', advance="no") str_vs(cp%name)
case (OP_CHOICE)
write(*,'(a)', advance="no") "CHOICE"
case (OP_SEQ)
write(*,'(a)', advance="no") "SEQ"
end select
select case(cp%repeater)
case (REP_QUESTION_MARK)
write(*,'(a)', advance="no") "?"
case (REP_ASTERISK)
write(*,'(a)', advance="no") "*"
end select
write(*,*)
end subroutine dumpCP
subroutine dumpCPtree(cp)
type(content_particle_t), pointer :: cp
type(content_particle_t), pointer :: current
integer :: i
logical :: done
i = 0
current => cp
done = .false.
call dumpCP(current)
do
if (.not.done) then
do while (associated(current%firstChild))
i = i + 2
current => current%firstChild
write(*,'(a)', advance="no") repeat(" ",i)
call dumpCP(current)
enddo
endif
if (associated(current, cp)) exit
if (associated(current%nextSibling)) then
done = .false.
current => current%nextSibling
write(*,'(a)', advance="no") repeat(" ",i)
call dumpCP(current)
else
done = .true.
i = i - 2
current => current%parent
endif
enddo
end subroutine dumpCPtree
#endif
end module m_common_content_model

1645
src/xml/common/m_common_element.F90 Normal file
View file

File diff suppressed because it is too large Load diff

236
src/xml/common/m_common_elstack.F90 Normal file
View file

@ -0,0 +1,236 @@
module m_common_elstack
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str
use m_common_error, only: FoX_fatal
use m_common_content_model, only: content_particle_t, checkCP, &
elementContentCP, emptyContentCP, checkCPToEnd
implicit none
private
! Element stack during parsing. Keeps track of element names
! and optionally tracks validity of content model
! Initial stack size:
integer, parameter :: STACK_SIZE_INIT = 10
! Multiplier when stack is exceeded:
real, parameter :: STACK_SIZE_MULT = 1.5
type :: elstack_item
character, dimension(:), pointer :: name => null()
type(content_particle_t), pointer :: cp => null()
end type elstack_item
type :: elstack_t
private
integer :: n_items
type(elstack_item), pointer, dimension(:) :: stack => null()
end type elstack_t
public :: elstack_t
public :: push_elstack, pop_elstack, init_elstack, destroy_elstack, reset_elstack, print_elstack
public :: get_top_elstack, is_empty
public :: checkContentModel
public :: checkContentModelToEnd
public :: elementContent
public :: emptyContent
public :: len
interface len
module procedure number_of_items
end interface
interface is_empty
module procedure is_empty_elstack
end interface
contains
subroutine init_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
! We go from 0 (and initialize the 0th string to "")
! in order that we can safely check the top of an
! empty stack
allocate(elstack%stack(0:STACK_SIZE_INIT))
elstack%n_items = 0
allocate(elstack%stack(0)%name(0))
end subroutine init_elstack
subroutine destroy_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
integer :: i
do i = 0, elstack % n_items
deallocate(elstack%stack(i)%name)
enddo
deallocate(elstack%stack)
end subroutine destroy_elstack
subroutine reset_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
call destroy_elstack(elstack)
call init_elstack(elstack)
end subroutine reset_elstack
subroutine resize_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
type(elstack_item), dimension(0:ubound(elstack%stack,1)) :: temp
integer :: i, s
s = ubound(elstack%stack, 1)
do i = 0, s
temp(i)%name => elstack%stack(i)%name
temp(i)%cp => elstack%stack(i)%cp
enddo
deallocate(elstack%stack)
allocate(elstack%stack(0:nint(s*STACK_SIZE_MULT)))
do i = 0, s
elstack%stack(i)%name => temp(i)%name
elstack%stack(i)%cp => temp(i)%cp
enddo
end subroutine resize_elstack
pure function is_empty_elstack(elstack) result(answer)
type(elstack_t), intent(in) :: elstack
logical :: answer
answer = (elstack%n_items == 0)
end function is_empty_elstack
function number_of_items(elstack) result(n)
type(elstack_t), intent(in) :: elstack
integer :: n
n = elstack%n_items
end function number_of_items
subroutine push_elstack(elstack, name, cp)
type(elstack_t), intent(inout) :: elstack
character(len=*), intent(in) :: name
type(content_particle_t), pointer, optional :: cp
integer :: n
n = elstack%n_items
n = n + 1
if (n == size(elstack%stack)) then
call resize_elstack(elstack)
endif
allocate(elstack%stack(n)%name(len(name)))
elstack%stack(n)%name = vs_str(name)
if (present(cp)) elstack%stack(n)%cp => cp
elstack%n_items = n
end subroutine push_elstack
function pop_elstack(elstack) result(item)
type(elstack_t), intent(inout) :: elstack
character(len=merge(size(elstack%stack(elstack%n_items)%name), 0, elstack%n_items > 0)) :: item
integer :: n
n = elstack%n_items
if (n == 0) then
call FoX_fatal("Element stack empty")
endif
item = str_vs(elstack%stack(n)%name)
deallocate(elstack%stack(n)%name)
elstack%n_items = n - 1
end function pop_elstack
pure function get_top_elstack(elstack) result(item)
! Get the top element of the stack, *without popping it*.
type(elstack_t), intent(in) :: elstack
character(len=merge(size(elstack%stack(elstack%n_items)%name), 0, elstack%n_items > 0)) :: item
integer :: n
n = elstack%n_items
if (n==0) then
item = ""
else
item = str_vs(elstack%stack(n)%name)
endif
end function get_top_elstack
function checkContentModel(elstack, name) result(p)
type(elstack_t), intent(inout) :: elstack
character(len=*), intent(in) :: name
logical :: p
type(content_particle_t), pointer :: cp
integer :: n
n = elstack%n_items
if (n==0) then
p = .true.
else
cp => elstack%stack(n)%cp
p = checkCP(cp, name)
elstack%stack(n)%cp => cp
endif
end function checkContentModel
function checkContentModelToEnd(elstack) result(p)
type(elstack_t), intent(inout) :: elstack
logical :: p
type(content_particle_t), pointer :: cp
integer :: n
n = elstack%n_items
cp => elstack%stack(n)%cp
p = checkCPToEnd(cp)
end function checkContentModelToEnd
function elementContent(elstack) result(p)
type(elstack_t), intent(in) :: elstack
logical :: p
integer :: n
n = elstack%n_items
if (n==0) then
p = .false.
else
p = elementContentCP(elstack%stack(n)%cp)
endif
end function elementContent
function emptyContent(elstack) result(p)
type(elstack_t), intent(in) :: elstack
logical :: p
integer :: n
n = elstack%n_items
if (n==0) then
p = .false.
else
p = emptyContentCP(elstack%stack(n)%cp)
endif
end function emptyContent
subroutine print_elstack(elstack,unit)
type(elstack_t), intent(in) :: elstack
integer, intent(in) :: unit
integer :: i
do i = elstack%n_items, 1, -1
write(unit=unit,fmt=*) elstack%stack(i)%name
enddo
end subroutine print_elstack
#endif
end module m_common_elstack

475
src/xml/common/m_common_entities.F90 Normal file
View file

@ -0,0 +1,475 @@
module m_common_entities
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc
use fox_m_fsys_format, only: str_to_int_10, str_to_int_16
use fox_m_utils_uri, only: URI, destroyURI
use m_common_charset, only: digits, hexdigits
use m_common_error, only: FoX_error
implicit none
private
type entity_t
logical :: external
logical :: wfc ! Was this entity declared externally or in a PE, where
! a non-validating processor might not see it?
character(len=1), dimension(:), pointer :: name => null()
character(len=1), dimension(:), pointer :: text => null()
character(len=1), dimension(:), pointer :: publicId => null()
character(len=1), dimension(:), pointer :: systemId => null()
character(len=1), dimension(:), pointer :: notation => null()
type(URI), pointer :: baseURI => null()
end type entity_t
type entity_list
private
type(entity_t), dimension(:), pointer :: list => null()
end type entity_list
public :: is_unparsed_entity
public :: is_external_entity
public :: expand_entity_text
public :: expand_entity_text_len
public :: existing_entity
public :: expand_char_entity
public :: expand_entity
public :: expand_entity_len
public :: entity_t
public :: entity_list
public :: init_entity_list
public :: reset_entity_list
public :: destroy_entity_list
public :: print_entity_list
public :: add_internal_entity
public :: add_external_entity
public :: pop_entity_list
interface size
module procedure size_el
end interface
interface is_unparsed_entity
module procedure is_unparsed_entity_
module procedure is_unparsed_entity_from_list
end interface
public :: getEntityByIndex
public :: getEntityByName
public :: size
contains
function size_el(el) result(n)
type(entity_list), intent(in) :: el
integer :: n
n = ubound(el%list, 1)
end function size_el
function shallow_copy_entity(ent1) result(ent2)
type(entity_t), intent(in) :: ent1
type(entity_t) :: ent2
ent2%external = ent1%external
ent2%wfc = ent1%wfc
ent2%name => ent1%name
ent2%text => ent1%text
ent2%publicId => ent1%publicId
ent2%systemId => ent1%systemId
ent2%notation => ent1%notation
ent2%baseURI => ent1%baseURI
end function shallow_copy_entity
function getEntityByIndex(el, i) result(e)
type(entity_list), intent(in) :: el
integer, intent(in) :: i
type(entity_t), pointer :: e
e => el%list(i)
end function getEntityByIndex
function getEntityNameByIndex(el, i) result(c)
type(entity_list), intent(in) :: el
integer, intent(in) :: i
character(len=size(el%list(i)%name)) :: c
c = str_vs(el%list(i)%name)
end function getEntityNameByIndex
function getEntityByName(el, name) result(e)
type(entity_list), intent(in) :: el
character(len=*), intent(in) :: name
type(entity_t), pointer :: e
integer :: i
e => null()
do i = 1, size(el%list)
if (str_vs(el%list(i)%name)==name) then
e => el%list(i)
exit
endif
enddo
end function getEntityByName
subroutine destroy_entity(ent)
type(entity_t), intent(inout) :: ent
deallocate(ent%name)
deallocate(ent%text)
deallocate(ent%publicId)
deallocate(ent%systemId)
deallocate(ent%notation)
if (associated(ent%baseURI)) call destroyURI(ent%baseURI)
end subroutine destroy_entity
subroutine init_entity_list(ents)
type(entity_list), intent(inout) :: ents
if (associated(ents%list)) deallocate(ents%list)
allocate(ents%list(0))
end subroutine init_entity_list
subroutine reset_entity_list(ents)
type(entity_list), intent(inout) :: ents
call destroy_entity_list(ents)
call init_entity_list(ents)
end subroutine reset_entity_list
subroutine destroy_entity_list(ents)
type(entity_list), intent(inout) :: ents
integer :: i, n
n = size(ents%list)
do i = 1, n
call destroy_entity(ents%list(i))
enddo
deallocate(ents%list)
end subroutine destroy_entity_list
function pop_entity_list(ents) result(name)
type(entity_list), intent(inout) :: ents
character(len=size(ents%list(size(ents%list))%name)) :: name
type(entity_t), pointer :: ents_tmp(:)
integer :: i, n
n = size(ents%list)
ents_tmp => ents%list
allocate(ents%list(n-1))
do i = 1, n - 1
ents%list(i) = shallow_copy_entity(ents_tmp(i))
enddo
name = str_vs(ents_tmp(i)%name)
call destroy_entity(ents_tmp(i))
deallocate(ents_tmp)
end function pop_entity_list
subroutine print_entity_list(ents)
type(entity_list), intent(in) :: ents
integer :: i, n
n = size(ents%list)
write(*,'(a)') '>ENTITYLIST'
do i = 1, n
write(*,'(a)') str_vs(ents%list(i)%name)
write(*,'(a)') str_vs(ents%list(i)%text)
write(*,'(a)') str_vs(ents%list(i)%publicId)
write(*,'(a)') str_vs(ents%list(i)%systemId)
write(*,'(a)') str_vs(ents%list(i)%notation)
enddo
write(*,'(a)') '<ENTITYLIST'
end subroutine print_entity_list
subroutine add_entity(ents, name, text, publicId, systemId, notation, baseURI, wfc)
type(entity_list), intent(inout) :: ents
character(len=*), intent(in) :: name
character(len=*), intent(in) :: text
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
character(len=*), intent(in) :: notation
type(URI), pointer :: baseURI
logical, intent(in) :: wfc
type(entity_t), pointer :: ents_tmp(:)
integer :: i, n
! This should only ever be called by add_internal_entity or add_external_entity
! below, so we don't bother sanity-checking input. Note especially we don't
! check for duplication of entities, so this will happily add another entity
! of the same name if you ask it to. This should't matter though, since the
! first defined will always be picked up first, which is what the XML spec
! requires.
n = size(ents%list)
ents_tmp => ents%list
allocate(ents%list(n+1))
do i = 1, n
ents%list(i) = shallow_copy_entity(ents_tmp(i))
enddo
deallocate(ents_tmp)
ents%list(i)%external = len(systemId)>0
ents%list(i)%wfc = wfc
ents%list(i)%name => vs_str_alloc(name)
ents%list(i)%text => vs_str_alloc(text)
ents%list(i)%publicId => vs_str_alloc(publicId)
ents%list(i)%systemId => vs_str_alloc(systemId)
ents%list(i)%notation => vs_str_alloc(notation)
ents%list(i)%baseURI => baseURI
end subroutine add_entity
subroutine add_internal_entity(ents, name, text, baseURI, wfc)
type(entity_list), intent(inout) :: ents
character(len=*), intent(in) :: name
character(len=*), intent(in) :: text
type(URI), pointer :: baseURI
logical, intent(in) :: wfc
call add_entity(ents, name=name, text=text, &
publicId="", systemId="", notation="", baseURI=baseURI, wfc=wfc)
end subroutine add_internal_entity
subroutine add_external_entity(ents, name, systemId, baseURI, wfc, publicId, notation)
type(entity_list), intent(inout) :: ents
character(len=*), intent(in) :: name
character(len=*), intent(in) :: systemId
character(len=*), intent(in), optional :: publicId
character(len=*), intent(in), optional :: notation
type(URI), pointer :: baseURI
logical, intent(in) :: wfc
if (present(publicId) .and. present(notation)) then
call add_entity(ents, name=name, text="", &
publicId=publicId, systemId=systemId, notation=notation, &
wfc=wfc, baseURI=baseURI)
elseif (present(publicId)) then
call add_entity(ents, name=name, text="", &
publicId=publicId, systemId=systemId, notation="", &
wfc=wfc, baseURI=baseURI)
elseif (present(notation)) then
call add_entity(ents, name=name, text="", &
publicId="", systemId=systemId, notation=notation, &
wfc=wfc, baseURI=baseURI)
else
call add_entity(ents, name=name, text="", &
publicId="", systemId=systemId, notation="", &
wfc=wfc, baseURI=baseURI)
endif
end subroutine add_external_entity
function is_unparsed_entity_from_list(ents, name) result(p)
type(entity_list), intent(in) :: ents
character(len=*), intent(in) :: name
logical :: p
integer :: i
p = .false.
do i = 1, size(ents%list)
if (name == str_vs(ents%list(i)%name)) then
p = (size(ents%list(i)%notation)>0)
exit
endif
enddo
end function is_unparsed_entity_from_list
function is_unparsed_entity_(ent) result(p)
type(entity_t), intent(in) :: ent
logical :: p
p = (size(ent%notation)>0)
end function is_unparsed_entity_
function is_external_entity(ents, name) result(p)
type(entity_list), intent(in) :: ents
character(len=*), intent(in) :: name
logical :: p
integer :: i
p = .false.
do i = 1, size(ents%list)
if (name == str_vs(ents%list(i)%name)) then
p = ents%list(i)%external
exit
endif
enddo
end function is_external_entity
pure function expand_char_entity_len(name) result(n)
character(len=*), intent(in) :: name
integer :: n
integer :: number
if (name(1:1) == "#") then
if (name(2:2) == "x") then ! hex character reference
if (verify(name(3:), hexdigits) == 0) then
number = str_to_int_16(name(3:))
if (0 <= number .and. number <= 128) then
n = 1
else
n = len(name) + 2
endif
else
n = 0
endif
else ! decimal character reference
if (verify(name(3:), digits) == 0) then
number = str_to_int_10(name(2:))
if (0 <= number .and. number <= 128) then
n = 1
else
n = len(name) + 2
endif
else
n = 0
endif
endif
else
n = 0
endif
end function expand_char_entity_len
function expand_char_entity(name) result(text)
character(len=*), intent(in) :: name
character(len=expand_char_entity_len(name)) :: text
integer :: number
select case (len(text))
case (0)
call FoX_error("Invalid character entity reference")
case (1)
if (name(2:2) == "x") then ! hex character reference
number = str_to_int_16(name(3:))
else ! decimal character reference
number = str_to_int_10(name(2:))
endif
text = achar(number)
! FIXME what about > 127 ...
case default
text = "&"//name//";"
end select
end function expand_char_entity
pure function existing_entity(ents, name) result(p)
type(entity_list), intent(in) :: ents
character(len=*), intent(in) :: name
logical :: p
integer :: i
p = .false.
!FIXME the following test is not entirely in accordance with the valid chars check we do elsewhere...
do i = 1, size(ents%list)
if (name == str_vs(ents%list(i)%name)) then
p = .true.
return
endif
enddo
end function existing_entity
pure function expand_entity_text_len(ents, name) result(n)
type(entity_list), intent(in) :: ents
character(len=*), intent(in) :: name
integer :: n
integer :: i
do i = 1, size(ents%list)
if (name == str_vs(ents%list(i)%name)) then
n = size(ents%list(i)%text)
endif
enddo
end function expand_entity_text_len
function expand_entity_text(ents, name) result(text)
type(entity_list), intent(in) :: ents
character(len=*), intent(in) :: name
character(len=expand_entity_text_len(ents, name)) :: text
integer :: i
! No error checking - make sure entity exists before calling it.
do i = 1, size(ents%list)
if (name == str_vs(ents%list(i)%name)) then
text = str_vs(ents%list(i)%text)
exit
endif
enddo
end function expand_entity_text
pure function expand_entity_len(ents, name) result(n)
type(entity_list), intent(in) :: ents
character(len=*), intent(in) :: name
integer :: n
integer :: i
do i = 1, size(ents%list)
if (name == str_vs(ents%list(i)%name)) then
n = size(ents%list(i)%text)
endif
enddo
end function expand_entity_len
function expand_entity(ents, name) result(text)
type(entity_list), intent(in) :: ents
character(len=*), intent(in) :: name
character(len=expand_entity_len(ents, name)) :: text
integer :: i
do i = 1, size(ents%list)
if (name == str_vs(ents%list(i)%name)) then
text = str_vs(ents%list(i)%text)
endif
enddo
end function expand_entity
#endif
end module m_common_entities

86
src/xml/common/m_common_entity_expand.F90 Normal file
View file

@ -0,0 +1,86 @@
module m_common_entity_expand
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str
use m_common_entities, only: expand_char_entity
use m_common_error, only: error_stack, add_error
use m_common_namecheck, only: checkName, checkCharacterEntityReference, &
checkRepCharEntityReference
use m_common_struct, only: xml_doc_state
implicit none
private
public :: expand_entity_value_alloc
! This does the first level of expansion of the contents of an entity
! reference, for storage during processing. Only character references
! are expanded.
contains
function expand_entity_value_alloc(repl, xds, stack) result(repl_new)
!perform expansion of character entity references
! check that no parameter entities are present
! and check that all general entity references are well-formed.
!before storing it.
!
! This is only ever called from the SAX parser
! (might it be called from WXML?)
! so input & output is with character arrays, not strings.
character, dimension(:), intent(in) :: repl
type(xml_doc_state), intent(in) :: xds
type(error_stack), intent(inout) :: stack
character, dimension(:), pointer :: repl_new
character, dimension(size(repl)) :: repl_temp
integer :: i, i2, j
allocate(repl_new(0))
if (index(str_vs(repl),'%')/=0) then
call add_error(stack, "Not allowed % in internal subset general entity value")
return
endif
i = 1
i2 = 1
do
if (i>size(repl)) exit
if (repl(i)=='&') then
j = index(str_vs(repl(i+1:)),';')
if (j==0) then
call add_error(stack, "Not allowed bare & in entity value")
return
elseif (checkName(str_vs(repl(i+1:i+j-1)), xds%xml_version)) then
repl_temp(i2:i2+j) = repl(i:i+j)
i = i + j + 1
i2 = i2 + j + 1
! For SAX, we need to be able to represent the character:
elseif (checkRepCharEntityReference(str_vs(repl(i+1:i+j-1)), xds%xml_version)) then
!if it is ascii then
repl_temp(i2:i2) = vs_str(expand_char_entity(str_vs(repl(i+1:i+j-1))))
i = i + j + 1
i2 = i2 + 1
elseif (checkCharacterEntityReference(str_vs(repl(i+1:i+j-1)), xds%xml_version)) then
! We can't represent it. Issue an error and stop.
call add_error(stack, "Unable to digest character entity reference in entity value, sorry.")
return
else
call add_error(stack, "Invalid entity reference in entity value")
return
endif
else
repl_temp(i2) = repl(i)
i = i + 1
i2 = i2 + 1
endif
enddo
deallocate(repl_new)
allocate(repl_new(i2-1))
repl_new = repl_temp(:i2-1)
end function expand_entity_value_alloc
#endif
end module m_common_entity_expand

211
src/xml/common/m_common_error.F90 Normal file
View file

@ -0,0 +1,211 @@
module m_common_error
#ifndef DUMMYLIB
use fox_m_fsys_abort_flush, only: pxfabort, pxfflush
use fox_m_fsys_array_str, only: vs_str_alloc
implicit none
private
integer, parameter :: ERR_NULL = 0
integer, parameter :: ERR_WARNING = 1
integer, parameter :: ERR_ERROR = 2
integer, parameter :: ERR_FATAL = 3
#endif
logical, save :: errors_are_fatal = .false.
logical, save :: warnings_are_fatal = .false.
#ifndef DUMMYLIB
type error_t
integer :: severity = ERR_NULL
integer :: error_code = 0
character, dimension(:), pointer :: msg => null()
end type error_t
type error_stack
type(error_t), dimension(:), pointer :: stack => null()
end type error_stack
interface FoX_warning
module procedure FoX_warning_base
end interface
interface FoX_error
module procedure FoX_error_base
end interface
interface FoX_fatal
module procedure FoX_fatal_base
end interface
public :: ERR_NULL
public :: ERR_WARNING
public :: ERR_ERROR
public :: ERR_FATAL
public :: error_t
public :: error_stack
public :: init_error_stack
public :: destroy_error_stack
public :: FoX_warning
public :: FoX_error
public :: FoX_fatal
public :: FoX_warning_base
public :: FoX_error_base
public :: FoX_fatal_base
public :: add_error
public :: in_error
#endif
public :: FoX_set_fatal_errors
public :: FoX_get_fatal_errors
public :: FoX_set_fatal_warnings
public :: FoX_get_fatal_warnings
contains
#ifndef DUMMYLIB
subroutine FoX_warning_base(msg)
! Emit warning, but carry on.
character(len=*), intent(in) :: msg
if (warnings_are_fatal) then
write(0,'(a)') 'FoX warning made fatal'
call FoX_fatal_base(msg)
endif
write(0,'(a)') 'WARNING(FoX)'
write(0,'(a)') msg
call pxfflush(0)
end subroutine FoX_warning_base
subroutine FoX_error_base(msg)
! Emit error message and stop.
! No clean up is done here, but this can
! be overridden to include clean-up routines
character(len=*), intent(in) :: msg
if (errors_are_fatal) then
write(0,'(a)') 'FoX error made fatal'
call FoX_fatal_base(msg)
endif
write(0,'(a)') 'ERROR(FoX)'
write(0,'(a)') msg
call pxfflush(0)
stop
end subroutine FoX_error_base
subroutine FoX_fatal_base(msg)
!Emit error message and abort with coredump.
!No clean-up occurs
character(len=*), intent(in) :: msg
write(0,'(a)') 'ABORT(FOX)'
write(0,'(a)') msg
call pxfflush(0)
call pxfabort()
end subroutine FoX_fatal_base
subroutine init_error_stack(stack)
type(error_stack), intent(inout) :: stack
allocate(stack%stack(0))
end subroutine init_error_stack
subroutine destroy_error_stack(stack)
type(error_stack), intent(inout) :: stack
integer :: i
do i = 1, size(stack%stack)
deallocate(stack%stack(i)%msg)
enddo
deallocate(stack%stack)
end subroutine destroy_error_stack
subroutine add_error(stack, msg, severity, error_code)
type(error_stack), intent(inout) :: stack
character(len=*), intent(in) :: msg
integer, intent(in), optional :: severity
integer, intent(in), optional :: error_code
integer :: i, n
type(error_t), dimension(:), pointer :: temp_stack
if (.not.associated(stack%stack)) &
call init_error_stack(stack)
n = size(stack%stack)
temp_stack => stack%stack
allocate(stack%stack(n+1))
do i = 1, size(temp_stack)
stack%stack(i)%msg => temp_stack(i)%msg
stack%stack(i)%severity = temp_stack(i)%severity
stack%stack(i)%error_code = temp_stack(i)%error_code
enddo
deallocate(temp_stack)
stack%stack(n+1)%msg => vs_str_alloc(msg)
if (present(severity)) then
stack%stack(n+1)%severity = severity
else
stack%stack(n+1)%severity = ERR_ERROR
endif
if (present(error_code)) then
stack%stack(n+1)%error_code = error_code
else
stack%stack(n+1)%error_code = -1
endif
end subroutine add_error
function in_error(stack) result(p)
type(error_stack), intent(in) :: stack
logical :: p
if (associated(stack%stack)) then
p = (size(stack%stack) > 0)
else
p = .false.
endif
end function in_error
#endif
subroutine FoX_set_fatal_errors(newvalue)
logical, intent(in) :: newvalue
errors_are_fatal = newvalue
end subroutine FoX_set_fatal_errors
function FoX_get_fatal_errors()
logical :: FoX_get_fatal_errors
FoX_get_fatal_errors = errors_are_fatal
end function FoX_get_fatal_errors
subroutine FoX_set_fatal_warnings(newvalue)
logical, intent(in) :: newvalue
warnings_are_fatal = newvalue
end subroutine FoX_set_fatal_warnings
function FoX_get_fatal_warnings()
logical :: FoX_get_fatal_warnings
FoX_get_fatal_warnings = warnings_are_fatal
end function FoX_get_fatal_warnings
end module m_common_error

102
src/xml/common/m_common_io.F90 Normal file
View file

@ -0,0 +1,102 @@
module m_common_io
#ifndef DUMMYLIB
use m_common_error, only : FoX_error
implicit none
private
! Basic I/O tools
integer, save :: io_eor
integer, save :: io_eof
integer, save :: io_err
public :: io_eor
public :: io_eof
public :: io_err
public :: get_unit
public :: setup_io
contains
subroutine setup_io()
call find_eor_eof(io_eor, io_eof)
end subroutine setup_io
subroutine get_unit(lun,iostat)
! Get an available Fortran unit number
integer, intent(out) :: lun
integer, intent(out) :: iostat
integer :: i
logical :: unit_used
do i = 10, 99
lun = i
inquire(unit=lun,opened=unit_used)
if (.not. unit_used) then
iostat = 0
return
endif
enddo
iostat = -1
lun = -1
end subroutine get_unit
subroutine find_eor_eof(io_eor,io_eof)
! Determines the values of the iostat values for End of File and
! End of Record (in non-advancing I/O)
#ifdef __NAG__
use f90_iostat
#endif
integer, intent(out) :: io_eor
integer, intent(out) :: io_eof
#ifdef __NAG__
io_eor = ioerr_eor
io_eof = ioerr_eof
#else
integer :: lun, iostat
character(len=1) :: c
call get_unit(lun,iostat)
if (iostat /= 0) call FoX_error("Out of unit numbers")
open(unit=lun,status="scratch",form="formatted", &
action="readwrite",position="rewind",iostat=iostat)
if (iostat /= 0) call FoX_error("Cannot open test file")
write(unit=lun,fmt=*) "a"
write(unit=lun,fmt=*) "b"
rewind(unit=lun)
io_eor = 0
do
read(unit=lun,fmt="(a1)",advance="no",iostat=io_eor) c
if (io_eor /= 0) exit
enddo
io_eof = 0
do
read(unit=lun,fmt=*,iostat=io_eof)
if (io_eof /= 0) exit
enddo
close(unit=lun,status="delete")
#endif
! Invent an io_err ...
io_err = 1
do
if (io_err/=0.and.io_err/=io_eor.and.io_err/=io_eof) exit
io_err = io_err + 1
end do
end subroutine find_eor_eof
#endif
end module m_common_io

501
src/xml/common/m_common_namecheck.F90 Normal file
View file

@ -0,0 +1,501 @@
module m_common_namecheck
#ifndef DUMMYLIB
! These are basically a collection of what would be regular
! expressions in a more sensible language.
! The only external dependency should be knowing how these
! regular expressions may differ between XML-1.0 and 1.1 (which
! is only in the areas of
! 1: allowing character entity references to control characters
! 2: More characters allowed in Names (but this only affects
! unicode-aware programs, so is only skeleton here)
use fox_m_fsys_format, only: str_to_int_10, str_to_int_16, operator(//)
use fox_m_fsys_string, only: toLower
use m_common_charset, only: isLegalCharRef, isNCNameChar, &
isInitialNCNameChar, isInitialNameChar, isNameChar, isRepCharRef
implicit none
private
character(len=*), parameter :: lowerCase = "abcdefghijklmnopqrstuvwxyz"
character(len=*), parameter :: upperCase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
character(len=*), parameter :: letters = lowerCase//upperCase
character(len=*), parameter :: digits = "0123456789"
character(len=*), parameter :: hexdigits = "0123456789abcdefABCDEF"
character(len=*), parameter :: NameChars = lowerCase//upperCase//digits//".-_:"
public :: checkName
public :: checkNames
public :: checkQName
public :: checkQNames
public :: checkNmtoken
public :: checkNmtokens
public :: checkNCName
public :: checkNCNames
public :: checkEncName
public :: checkPITarget
public :: checkPublicId
public :: checkPEDef
public :: checkPseudoAttValue
public :: checkAttValue
public :: checkCharacterEntityReference
public :: checkRepCharEntityReference
public :: likeCharacterEntityReference
public :: prefixOfQName
public :: localpartOfQName
contains
pure function checkEncName(name) result(good)
![81] EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')*
character(len=*), intent(in) :: name
logical :: good
integer :: n
n = len(name)
good = (n > 0)
if (good) good = (scan(name(1:1), letters) /= 0)
if (good .and. n > 1) &
good = (verify(name(2:), letters//digits//'.-_') == 0)
end function checkEncName
function checkPITarget(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for a NAME
! Is not fully compliant; ignores UTF issues.
good = checkName(name, xv) &
.and.toLower(name)/="xml"
end function checkPITarget
pure function checkName(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for a NAME
! Is not fully compliant; ignores UTF issues.
good = (len(name) > 0)
if (.not.good) return
if (good) good = isInitialNameChar(name(1:1), xv)
if (.not.good.or.len(name)==1) return
good = isNameChar(name(2:), xv)
end function checkName
pure function checkNames(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the production for NAMES
integer :: i, j
good = (len(name) > 0)
if (.not.good) return
i = verify(name, " ")
if (i==0) then
good = .false.
return
endif
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
do
good = checkName(name(i:j), xv)
if (.not.good) return
i = j + 1
j = verify(name(i:), " ")
if (j==0) exit
i = i + j - 1
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
enddo
end function checkNames
pure function checkQName(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for a NAME
! Is not fully compliant; ignores UTF issues.
integer :: n
n = index(name, ':')
if (n == 0) then
good = checkNCName(name, xv)
else
good = (checkNCName(name(:n-1), xv) .and. checkNCName(name(n+1:), xv))
endif
end function checkQName
pure function checkQNames(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the production for NAMES
integer :: i, j
good = (len(name) > 0)
if (.not.good) return
i = verify(name, " ")
if (i==0) then
good = .false.
return
endif
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
do
good = checkQName(name(i:j), xv)
if (.not.good) return
i = j + 1
j = verify(name(i:), " ")
if (j==0) exit
i = i + j - 1
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
enddo
end function checkQNames
pure function checkNCName(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for an NCNAME
! Is not fully compliant; ignores UTF issues.
good = (len(name)/=0)
if (.not.good) return
good = isInitialNCNameChar(name(1:1), xv)
if (.not.good.or.len(name)==1) return
good = isNCNameChar(name(2:), xv)
end function checkNCName
pure function checkNCNames(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the production for NAMES
integer :: i, j
good = (len(name) > 0)
if (.not.good) return
i = verify(name, " ")
if (i==0) then
good = .false.
return
endif
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
do
good = checkNCName(name(i:j), xv)
if (.not.good) return
i = j + 1
j = verify(name(i:), " ")
if (j==0) exit
i = i + j - 1
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
enddo
end function checkNCNames
pure function checkNmtoken(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for an NCNAME
! Is not fully compliant; ignores UTF issues.
good = isNameChar(name, xv)
end function checkNmtoken
pure function checkNmtokens(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for an NCNAME
! Is not fully compliant; ignores UTF issues.
integer :: i, j
good = (len(name) > 0)
if (.not.good) return
i = verify(name, " ")
if (i==0) then
good = .false.
return
endif
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
do
good = isNameChar(name(i:j), xv)
if (.not.good) return
i = j + 1
j = verify(name(i:), " ")
if (j==0) exit
i = i + j - 1
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
enddo
end function checkNmtokens
function checkPublicId(value) result(good)
character(len=*), intent(in) :: value
logical :: good
character(len=*), parameter :: PubIdChars = &
" "//achar(10)//achar(13)//lowerCase//upperCase//digits//"-'()+,./:=?;!*#@$_%"
good = (verify(value, PubIdChars)==0)
end function checkPublicId
function checkPEDef(value, xv) result(p)
character(len=*), intent(in) :: value
integer, intent(in) :: xv
logical :: p
integer :: i1, i2
p = .false.
if (scan(value, '%&')==0) then
p = .true.
elseif (scan(value, '"')==0) then
i1 = scan(value, '%&')
i2 = 0
do while (i1>0)
i1 = i2 + i1
i2 = index(value(i1+1:),';')
if (i2==0) return
i2 = i1 + i2
if (value(i1:i1)=='&') then
if (.not.checkName(value(i1+1:i2-1), xv) .and. &
.not.checkCharacterEntityReference(value(i1+1:i2-1), xv)) return
else
if (.not.checkName(value(i1+1:i2-1), xv)) &
return
endif
i1 = scan(value(i2+1:), '%&')
enddo
p = .true.
endif
end function checkPEDef
function checkPseudoAttValue(value, xv) result(p)
character(len=*), intent(in) :: value
integer, intent(in) :: xv
logical :: p
integer :: i1, i2
!fixme can we have entrefs in PIs?
p = .false.
if (scan(value, '"<&')==0) then
p = .true.
elseif (index(value, '&') > 0) then
i1 = index(value, '&')
i2 = 0
do while (i1 > 0)
i1 = i2 + i1
i2 = index(value(i1+1:),';')
if (i2==0) return
i2 = i1 + i2
if (value(i1+1:i2-1) /= 'amp' .and. &
value(i1+1:i2-1) /= 'lt' .and. &
value(i1+1:i2-1) /= 'gt' .and. &
value(i1+1:i2-1) /= 'quot' .and. &
value(i1+1:i2-1) /= 'apos' .and. &
.not.checkCharacterEntityReference(value(i1+1:i2-1), xv)) &
return
i1 = index(value(i2+1:), '&')
enddo
p = .true.
endif
end function checkPseudoAttValue
function checkAttValue(value, xv) result(p)
character(len=*), intent(in) :: value
integer, intent(in) :: xv
logical :: p
! This function is called basically to make sure
! that any attribute value looks like one. It will
! not flag up out-of-range character entities, and
! is a very weak check. Only used from xml_AddAttribute
! when escaping is off.
integer :: i1, i2
p = .false.
if (scan(value, '"<&'//"'")==0) then
p = .true.
elseif (index(value, '&') > 0) then
i1 = index(value, '&')
i2 = 0
do while (i1 > 0)
i1 = i1 + i2 + 1
i2 = scan(value(i1+1:),';')
if (i2 == 0) return
i2 = i1 + i2
if (.not.checkName(value(i1+1:i2-1), xv) .and. &
.not.likeCharacterEntityReference(value(i1+1:i2-1))) then
print*, value(i1+1:i2-1), " ", &
likeCharacterEntityReference(value(i1+1:i2-1))
return
endif
i1 = index(value(i2+1:), '&')
enddo
p = .true.
endif
end function checkAttValue
function likeCharacterEntityReference(code) result(good)
character(len=*), intent(in) :: code
logical :: good
good = .false.
if (len(code) > 0) then
if (code(1:1) == "#") then
if (code(2:2) == "x") then
if (len(code) > 2) then
good = (verify(code(3:), hexdigits) == 0)
endif
else
good = (verify(code(2:), digits) == 0)
endif
endif
endif
end function likeCharacterEntityReference
function checkCharacterEntityReference(code, xv) result(good)
character(len=*), intent(in) :: code
integer, intent(in) :: xv
logical :: good
integer :: i
good = .false.
if (len(code) > 0) then
if (code(1:1) == "#") then
if (code(2:2) == "x") then
if (len(code) > 2) then
good = (verify(code(3:), hexdigits) == 0)
if (good) then
i = str_to_int_16(code(3:))
endif
endif
else
good = (verify(code(2:), digits) == 0)
if (good) then
i = str_to_int_10(code(2:))
endif
endif
endif
endif
if (good) good = isLegalCharRef(i, xv)
end function checkCharacterEntityReference
function checkRepCharEntityReference(code, xv) result(good)
character(len=*), intent(in) :: code
integer, intent(in) :: xv
logical :: good
! Is this a reference to a character we can actually represent
! in memory? ie without unicode, US-ASCII only.
integer :: i
good = .false.
if (len(code) > 0) then
if (code(1:1) == "#") then
if (code(2:2) == "x") then
if (len(code) > 2) then
good = (verify(code(3:), hexdigits) == 0)
if (good) then
i = str_to_int_16(code(3:))
endif
endif
else
good = (verify(code(2:), digits) == 0)
if (good) then
i = str_to_int_10(code(2:))
endif
endif
endif
endif
if (good) good = isRepCharRef(i, xv)
end function checkRepCharEntityReference
pure function prefixOfQName(qname) result(prefix)
character(len=*), intent(in) :: qname
character(len=max(index(qname, ':')-1,0)) :: prefix
prefix = qname ! automatic truncation
end function prefixOfQName
pure function localpartOfQname(qname) result(localpart)
character(len=*), intent(in) :: qname
character(len=max(len(qname)-index(qname,':'),0)) ::localpart
localpart = qname(index(qname,':')+1:)
end function localpartOfQname
#endif
end module m_common_namecheck

830
src/xml/common/m_common_namespaces.F90 Normal file
View file

@ -0,0 +1,830 @@
module m_common_namespaces
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc
use fox_m_utils_uri, only: URI, parseURI, destroyURI, hasScheme
use m_common_attrs, only: dictionary_t, get_key, get_value, remove_key, getLength, hasKey
use m_common_attrs, only: set_nsURI, set_localName, get_prefix, add_item_to_dict
use m_common_charset, only: XML1_0, XML1_1
use m_common_error, only: FoX_error, FoX_warning, error_stack, add_error, in_error
use m_common_namecheck, only: checkNCName
use m_common_struct, only: xml_doc_state
implicit none
private
character(len=*), parameter :: invalidNS = '::INVALID::'
! an invalid URI name to indicate a namespace error.
type URIMapping
character, dimension(:), pointer :: URI
integer :: ix ! link back to node depth
end type URIMapping
!This is a single URI, and the node depth under which
!its namespace applies.
type prefixMapping
character, dimension(:), pointer :: prefix
type(URIMapping), dimension(:), pointer :: urilist
end type prefixMapping
!This is the mapping for a single prefix; with the
!list of namespaces which are in force at various
!depths
type namespaceDictionary
private
type(URIMapping), dimension(:), pointer :: defaults
type(prefixMapping), dimension(:), pointer :: prefixes
end type namespaceDictionary
!This is the full namespace dictionary; defaults is
!the list of default namespaces in force; prefix a
!list of all prefixes in force.
public :: invalidNS
public :: initNamespaceDictionary
public :: destroyNamespaceDictionary
public :: namespaceDictionary
public :: checkNamespaces
public :: checkNamespacesWriting
public :: checkEndNamespaces
public :: getnamespaceURI
interface getnamespaceURI
module procedure getURIofDefaultNS, getURIofPrefixedNS
end interface
public :: isPrefixInForce
public :: isDefaultNSInForce
public :: getNumberOfPrefixes
public :: getPrefixByIndex
public :: dumpnsdict !FIXME
public :: addDefaultNS
public :: removeDefaultNS
public :: addPrefixedNS
public :: removePrefixedNS
contains
subroutine initNamespaceDictionary(nsDict)
type(namespaceDictionary), intent(inout) :: nsDict
!We need to properly initialize 0th elements
!(which are never used) in order to provide
!sensible behaviour when trying to manipulate
!an empty dictionary.
allocate(nsDict%defaults(0:0))
allocate(nsDict%defaults(0)%URI(0))
!The 0th element of the defaults NS is the empty namespace
nsDict%defaults(0)%ix = -1
allocate(nsDict%prefixes(0:0))
allocate(nsDict%prefixes(0)%prefix(0))
allocate(nsDict%prefixes(0)%urilist(0:0))
allocate(nsDict%prefixes(0)%urilist(0)%URI(len(invalidNS)))
nsDict%prefixes(0)%urilist(0)%URI = vs_str(invalidNS)
nsDict%prefixes(0)%urilist(0)%ix = -1
end subroutine initNamespaceDictionary
subroutine destroyNamespaceDictionary(nsDict)
type(namespaceDictionary), intent(inout) :: nsDict
integer :: i, j
do i = 0, ubound(nsDict%defaults,1)
deallocate(nsDict%defaults(i)%URI)
enddo
deallocate(nsDict%defaults)
do i = 0, ubound(nsDict%prefixes,1)
do j = 0, ubound(nsDict%prefixes(i)%urilist,1)
deallocate(nsDict%prefixes(i)%urilist(j)%URI)
enddo
deallocate(nsDict%prefixes(i)%prefix)
deallocate(nsDict%prefixes(i)%urilist)
enddo
deallocate(nsDict%prefixes)
end subroutine destroyNamespaceDictionary
subroutine copyURIMapping(urilist1, urilist2, l_m)
type(URIMapping), dimension(0:), intent(inout) :: urilist1
type(URIMapping), dimension(0:), intent(inout) :: urilist2
integer, intent(in):: l_m
integer :: i
if (ubound(urilist1,1) < l_m .or. ubound(urilist2,1) < l_m) then
call FoX_error('Internal error in m_sax_namespaces:copyURIMapping')
endif
! Now copy all defaults across (or rather - add pointers to them)
do i = 0, l_m
urilist2(i)%ix = urilist1(i)%ix
urilist2(i)%URI => urilist1(i)%URI
enddo
end subroutine copyURIMapping
subroutine addDefaultNS(nsDict, uri, ix, es)
type(namespaceDictionary), intent(inout) :: nsDict
character(len=*), intent(in) :: uri
integer, intent(in) :: ix
type(error_stack), intent(inout), optional :: es
type(URIMapping), dimension(:), allocatable :: tempMap
integer :: l_m, l_s
if (uri=="http://www.w3.org/XML/1998/namespace") then
if (present(es)) then
call add_error(es, "Attempt to assign incorrect URI to prefix 'xml'")
else
call FoX_error("Attempt to assign incorrect URI to prefix 'xml'")
endif
elseif (uri=="http://www.w3.org/2000/xmlns/") then
if (present(es)) then
call add_error(es, "Attempt to assign prefix to xmlns namespace")
else
call FoX_error("Attempt to assign prefix to xmlns namespace")
endif
endif
! FIXME check URI is valid ...
l_m = ubound(nsDict%defaults,1)
allocate(tempMap(0:l_m))
! Now copy all defaults across ...
call copyURIMapping(nsDict%defaults, tempMap, l_m)
deallocate(nsDict%defaults)
l_m = l_m + 1
allocate(nsDict%defaults(0:l_m))
!Now copy everything back ...
call copyURIMapping(tempMap, nsDict%defaults, l_m-1)
deallocate(tempMap)
! And finally, add the new default NS
nsDict%defaults(l_m)%ix = ix
l_s = len(uri)
allocate(nsDict%defaults(l_m)%URI(l_s))
nsDict%defaults(l_m)%URI = vs_str(uri)
end subroutine addDefaultNS
subroutine addPrefixedURI(nsPrefix, uri, ix)
type(PrefixMapping), intent(inout) :: nsPrefix
character, dimension(:), intent(in) :: uri
integer, intent(in) :: ix
type(URIMapping), dimension(:), allocatable :: tempMap
integer :: l_m, l_s
l_m = ubound(nsPrefix%urilist,1)
allocate(tempMap(0:l_m))
! Now copy all across ...
call copyURIMapping(nsPrefix%urilist, tempMap, l_m)
deallocate(nsPrefix%urilist)
l_m = l_m + 1
allocate(nsPrefix%urilist(0:l_m))
!Now copy everything back ...
call copyURIMapping(tempMap, nsPrefix%urilist, l_m-1)
deallocate(tempMap)
! And finally, add the new default NS
nsPrefix%urilist(l_m)%ix = ix
l_s = size(uri)
allocate(nsPrefix%urilist(l_m)%URI(l_s))
nsPrefix%urilist(l_m)%URI = uri
end subroutine addPrefixedURI
subroutine removeDefaultNS(nsDict)
type(namespaceDictionary), intent(inout) :: nsDict
type(URIMapping), dimension(:), allocatable :: tempMap
integer :: l_m
l_m = ubound(nsDict%defaults,1)
allocate(tempMap(0:l_m-1))
! Now copy all defaults across ...
call copyURIMapping(nsDict%defaults, tempMap, l_m-1)
!And remove tail-end charlie
deallocate(nsDict%defaults(l_m)%URI)
deallocate(nsDict%defaults)
l_m = l_m - 1
allocate(nsDict%defaults(0:l_m))
!Now copy everything back ...
call copyURIMapping(tempMap, nsDict%defaults, l_m)
deallocate(tempMap)
end subroutine removeDefaultNS
subroutine removePrefixedURI(nsPrefix)
type(PrefixMapping), intent(inout) :: nsPrefix
type(URIMapping), dimension(:), allocatable :: tempMap
integer :: l_m
l_m = ubound(nsPrefix%urilist,1)
allocate(tempMap(0:l_m-1))
! Now copy all defaults across ...
call copyURIMapping(nsPrefix%urilist, tempMap, l_m-1)
!And remove tail-end charlie
deallocate(nsPrefix%urilist(l_m)%URI)
deallocate(nsPrefix%urilist)
l_m = l_m - 1
allocate(nsPrefix%urilist(0:l_m))
!Now copy everything back ...
call copyURIMapping(tempMap, nsPrefix%urilist, l_m)
deallocate(tempMap)
end subroutine removePrefixedURI
subroutine addPrefixedNS(nsDict, prefix, URI, ix, xds, xml, es)
type(namespaceDictionary), intent(inout) :: nsDict
character(len=*), intent(in) :: prefix
character(len=*), intent(in) :: uri
integer, intent(in) :: ix
type(xml_doc_state), intent(in) :: xds
logical, intent(in), optional :: xml
type(error_stack), intent(inout), optional :: es
integer :: l_p, p_i, i
logical :: xml_
if (present(xml)) then
xml_ = xml
else
xml_ = .false.
endif
if (prefix=='xml' .and. &
URI/='http://www.w3.org/XML/1998/namespace') then
if (present(es)) then
call add_error(es, "Attempt to assign incorrect URI to prefix 'xml'")
else
call FoX_error("Attempt to assign incorrect URI to prefix 'xml'")
endif
elseif (prefix/='xml' .and. &
URI=='http://www.w3.org/XML/1998/namespace') then
if (present(es)) then
call add_error(es, "Attempt to assign incorrect prefix to XML namespace")
else
call FoX_error("Attempt to assign incorrect prefix to XML namespace")
endif
elseif (prefix == 'xmlns') then
if (present(es)) then
call add_error(es, "Attempt to declare 'xmlns' prefix")
else
call FoX_error("Attempt to declare 'xmlns' prefix")
endif
elseif (URI=="http://www.w3.org/2000/xmlns/") then
if (present(es)) then
call add_error(es, "Attempt to assign prefix to xmlns namespace")
else
call FoX_error("Attempt to assign prefix to xmlns namespace")
endif
elseif (len(prefix) > 2) then
if ((verify(prefix(1:1), 'xX') == 0) &
.and. (verify(prefix(2:2), 'mM') == 0) &
.and. (verify(prefix(3:3), 'lL') == 0)) then
if (.not.xml_) then
! FIXME need working warning infrastructure
!if (present(es)) then
! call add_error(es, "Attempt to declare reserved prefix: "//prefix)
!else
call FoX_warning("Attempt to declare reserved prefix: "//prefix)
!endif
endif
endif
endif
if (.not.checkNCName(prefix, xds%xml_version)) &
call FoX_error("Attempt to declare invalid prefix: "//prefix)
! FIXME check URI is valid
l_p = ubound(nsDict%prefixes, 1)
p_i = 0
do i = 1, l_p
if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then
p_i = i
exit
endif
enddo
if (p_i == 0) then
call addPrefix(nsDict, vs_str(prefix))
p_i = l_p + 1
endif
call addPrefixedURI(nsDict%prefixes(p_i), vs_str(URI), ix)
end subroutine addPrefixedNS
subroutine removePrefixedNS(nsDict, prefix)
type(namespaceDictionary), intent(inout) :: nsDict
character, dimension(:), intent(in) :: prefix
integer :: l_p, p_i, i
l_p = ubound(nsDict%prefixes, 1)
p_i = 0
do i = 1, l_p
if (str_vs(nsDict%prefixes(i)%prefix) == str_vs(prefix)) then
p_i = i
exit
endif
enddo
if (p_i /= 0) then
call removePrefixedURI(nsDict%prefixes(p_i))
if (ubound(nsDict%prefixes(p_i)%urilist,1) == 0) then
!that was the last mapping for that prefix
call removePrefix(nsDict, p_i)
endif
else
call FoX_error('Internal error in m_sax_namespaces:removePrefixedNS')
endif
end subroutine removePrefixedNS
subroutine addPrefix(nsDict, prefix)
type(namespaceDictionary), intent(inout) :: nsDict
character, dimension(:), intent(in) :: prefix
integer :: l_p
type(prefixMapping), dimension(:), pointer :: tempPrefixMap
integer :: i
!Add a new prefix to the namespace dictionary.
!Unfortunately this involves copying the entire
!prefixes dictionary to a temporary structure, then
!reallocating the prefixes dictionary to be one
!longer, then copying everything back:
l_p = ubound(nsDict%prefixes, 1)
allocate(tempPrefixMap(0:l_p))
!for each current prefix, append everything to temporary structure
do i = 0, l_p
tempPrefixMap(i)%prefix => nsDict%prefixes(i)%prefix
tempPrefixMap(i)%urilist => nsDict%prefixes(i)%urilist
enddo
deallocate(nsDict%prefixes)
!extend prefix dictionary by one ...
l_p = l_p + 1
allocate(nsDict%prefixes(0:l_p))
!and copy back ...
do i = 0, l_p-1
nsDict%prefixes(i)%prefix => tempPrefixMap(i)%prefix
nsDict%prefixes(i)%urilist => tempPrefixMap(i)%urilist
enddo
deallocate(tempPrefixMap)
allocate(nsDict%prefixes(l_p)%prefix(size(prefix)))
nsDict%prefixes(l_p)%prefix = prefix
allocate(nsDict%prefixes(l_p)%urilist(0:0))
allocate(nsDict%prefixes(l_p)%urilist(0)%URI(len(invalidNS)))
nsDict%prefixes(l_p)%urilist(0)%URI = vs_str(invalidNS)
nsDict%prefixes(l_p)%urilist(0)%ix = -1
end subroutine addPrefix
subroutine removePrefix(nsDict, i_p)
type(namespaceDictionary), intent(inout) :: nsDict
integer, intent(in) :: i_p
integer :: l_p
type(prefixMapping), dimension(:), pointer :: tempPrefixMap
integer :: i
!Remove a prefix from the namespace dictionary.
!Unfortunately this involves copying the entire
!prefixes dictionary to a temporary structure, then
!reallocating the prefixes dictionary to be one
!shorter, then copying everything back:
l_p = ubound(nsDict%prefixes, 1)
allocate(tempPrefixMap(0:l_p-1))
!for each current prefix, append everything to temporary structure
do i = 0, i_p-1
tempPrefixMap(i)%prefix => nsDict%prefixes(i)%prefix
tempPrefixMap(i)%urilist => nsDict%prefixes(i)%urilist
enddo
deallocate(nsDict%prefixes(i_p)%urilist(0)%URI)
deallocate(nsDict%prefixes(i_p)%urilist)
deallocate(nsDict%prefixes(i_p)%prefix)
!this subroutine will only get called if the urilist is already
!empty, so no need to deallocate it.
do i = i_p+1, l_p
tempPrefixMap(i-1)%prefix => nsDict%prefixes(i)%prefix
tempPrefixMap(i-1)%urilist => nsDict%prefixes(i)%urilist
enddo
deallocate(nsDict%prefixes)
!shorten prefix dictionary by one ...
l_p = l_p - 1
allocate(nsDict%prefixes(0:l_p))
!and copy back ...
do i = 0, l_p
nsDict%prefixes(i)%prefix => tempPrefixMap(i)%prefix
nsDict%prefixes(i)%urilist => tempPrefixMap(i)%urilist
enddo
deallocate(tempPrefixMap)
end subroutine removePrefix
subroutine checkNamespaces(atts, nsDict, ix, xds, namespace_prefixes, xmlns_uris, es, &
partial, start_prefix_handler, end_prefix_handler)
type(dictionary_t), intent(inout) :: atts
type(namespaceDictionary), intent(inout) :: nsDict
integer, intent(in) :: ix ! depth of nesting of current element.
type(xml_doc_state), intent(in) :: xds
logical, intent(in) :: namespace_prefixes, xmlns_uris
type(error_stack), intent(inout) :: es
logical, intent(in) :: partial ! if so, don't try and resolve anything except xml & xmlns
optional :: start_prefix_handler, end_prefix_handler
interface
subroutine start_prefix_handler(namespaceURI, prefix)
character(len=*), intent(in) :: namespaceURI
character(len=*), intent(in) :: prefix
end subroutine start_prefix_handler
subroutine end_prefix_handler(prefix)
character(len=*), intent(in) :: prefix
end subroutine end_prefix_handler
end interface
character(len=6) :: xmlns
character, dimension(:), pointer :: QName, URIstring
integer :: i, n
type(URI), pointer :: URIref
!Check for namespaces; *and* remove xmlns references from
!the attributes dictionary.
! we can't do a simple loop across the attributes,
! because we need to remove some as we go along ...
i = 1
do while (i <= getLength(atts))
xmlns = get_key(atts, i)
if (xmlns == 'xmlns ') then
!Default namespace is being set
URIstring => vs_str_alloc(get_value(atts, i))
if (str_vs(URIstring)=="") then
! Empty nsURI on default namespace has same effect in 1.0 and 1.1
if (present(end_prefix_handler)) &
call end_prefix_handler("")
call addDefaultNS(nsDict, invalidNS, ix)
deallocate(URIstring)
else
URIref => parseURI(str_vs(URIstring))
if (.not.associated(URIref)) then
call add_error(es, "Invalid URI: "//str_vs(URIstring))
deallocate(URIstring)
return
elseif (.not.hasScheme(URIref)) then
call add_error(es, "Relative namespace in URI deprecated: "//str_vs(URIstring))
deallocate(URIstring)
call destroyURI(URIref)
return
endif
call destroyURI(URIref)
if (present(start_prefix_handler)) &
call start_prefix_handler(str_vs(URIstring), "")
call addDefaultNS(nsDict, str_vs(URIstring), ix)
deallocate(URIstring)
endif
if (namespace_prefixes) then
i = i + 1
else
call remove_key(atts, i)
endif
elseif (xmlns == 'xmlns:') then
!Prefixed namespace is being set
QName => vs_str_alloc(get_key(atts, i))
URIstring => vs_str_alloc(get_value(atts, i))
if (str_vs(URIstring)=="") then
if (xds%xml_version==XML1_0) then
call add_error(es, "Empty nsURI is invalid in XML 1.0")
deallocate(URIstring)
deallocate(QName)
return
elseif (xds%xml_version==XML1_1) then
call addPrefixedNS(nsDict, str_vs(QName(7:)), invalidNS, ix, xds, es=es)
if (in_error(es)) then
deallocate(URIstring)
deallocate(QName)
return
elseif (present(end_prefix_handler)) then
call end_prefix_handler(str_vs(QName(7:)))
endif
deallocate(URIstring)
deallocate(QName)
endif
else
URIref => parseURI(str_vs(URIstring))
if (.not.associated(URIref)) then
call add_error(es, "Invalid URI: "//str_vs(URIstring))
deallocate(URIstring)
deallocate(QName)
return
elseif (.not.hasScheme(URIref)) then
call add_error(es, "Relative namespace in URI deprecated: "//str_vs(URIstring))
deallocate(URIstring)
deallocate(QName)
call destroyURI(URIref)
return
endif
call destroyURI(URIref)
call addPrefixedNS(nsDict, str_vs(QName(7:)), str_vs(URIstring), ix, xds, es=es)
if (in_error(es)) then
deallocate(URIstring)
deallocate(QName)
return
elseif (present(start_prefix_handler)) then
call start_prefix_handler(str_vs(URIstring), str_vs(QName(7:)))
endif
deallocate(URIstring)
deallocate(QName)
endif
if (namespace_prefixes) then
i = i + 1
else
call remove_key(atts, i)
endif
else
! we only increment if we haven't removed a key
i = i + 1
endif
enddo
! having done that, now resolve all attribute namespaces:
do i = 1, getLength(atts)
QName => vs_str_alloc(get_key(atts,i))
n = index(str_vs(QName), ":")
if (n > 0) then
if (str_vs(QName(1:n-1))=="xmlns") then
! FIXME but this can be controlled by SAX configuration xmlns-uris
if (xmlns_uris) then
call set_nsURI(atts, i, "http://www.w3.org/2000/xmlns/")
else
call set_nsURI(atts, i, "")
endif
else
if (str_vs(QName(1:n-1))=="xml") then
call set_nsURI(atts, i, "http://www.w3.org/XML/1998/namespace")
elseif (getnamespaceURI(nsDict, str_vs(QName(1:n-1)))==invalidNS) then
! Sometimes we don't want to worry about unbound prefixes,
! eg if we are in the middle of parsing an entity.
if (.not.partial) then
call add_error(es, "Unbound namespace prefix")
deallocate(QName)
return
else
call set_nsURI(atts, i, "")
endif
else
call set_nsURI(atts, i, getnamespaceURI(nsDict, str_vs(QName(1:n-1))))
endif
endif
else
if (xmlns_uris.and.str_vs(QName)=="xmlns") then
call set_nsURI(atts, i, "http://www.w3.org/2000/xmlns/")
else
call set_nsURI(atts, i, "") ! no such thing as a default namespace on attributes
endif
endif
! Check for duplicates
if (hasKey(atts, getnamespaceURI(nsDict, str_vs(QName(1:n-1))), str_vs(QName(n+1:)))) then
call add_error(es, "Duplicate attribute names after namespace processing")
deallocate(QName)
return
endif
call set_localName(atts, i, QName(n+1:))
deallocate(QName)
enddo
end subroutine checkNamespaces
subroutine checkNamespacesWriting(atts, nsdict, ix)
type(dictionary_t), intent(inout) :: atts
type(namespaceDictionary), intent(inout) :: nsDict
integer, intent(in) :: ix
! Read through a list of attributes, check with currently
! active namespaces & add any necessary declarations
integer :: i, i_p, l_d, l_ps, n
n = getLength(atts) ! we need the length before we fiddle with it
!Does the default NS need added?
l_d = ubound(nsDict%defaults,1)
if (nsDict%defaults(l_d)%ix == ix) then
!It's not been registered yet:
call add_item_to_dict(atts, "xmlns", &
str_vs(nsDict%defaults(l_d)%URI), type="CDATA")
endif
!next, add any overdue prefixed NS's in the same way:
! there should only ever be one. More would be an error,
! but the check should have been done earlier.
do i_p = 0, ubound(nsDict%prefixes, 1)
l_ps = ubound(nsDict%prefixes(i_p)%urilist,1)
if (nsDict%prefixes(i_p)%urilist(l_ps)%ix == ix) then
call add_item_to_dict(atts, &
"xmlns:"//str_vs(nsDict%prefixes(i_p)%prefix), &
str_vs(nsDict%prefixes(i_p)%urilist(l_ps)%URI), &
type="CDATA")
endif
enddo
!Finally, we may have some we've added for attribute QNames
! have to get those too:
do i = 1, getLength(atts)
! get prefix, and identify the relevant NS mapping
i_p = getPrefixIndex(nsDict, get_prefix(atts, i))
l_ps = ubound(nsDict%prefixes(i_p)%urilist,1)
!If the index is greater than what it should be:
if (nsDict%prefixes(i_p)%urilist(l_ps)%ix > ix) then
!we only just added this, so we need to declare it
call add_item_to_dict(atts, "xmlns:"//get_prefix(atts, i), &
str_vs(nsDict%prefixes(i_p)%urilist(l_ps)%URI), &
type="CDATA")
!Reset the index to the right value:
nsDict%prefixes(i_p)%urilist(l_ps)%ix = ix
endif
enddo
end subroutine checkNamespacesWriting
subroutine checkEndNamespaces(nsDict, ix, end_prefix_handler)
type(namespaceDictionary), intent(inout) :: nsDict
integer, intent(in) :: ix
optional :: end_prefix_handler
interface
subroutine end_prefix_handler(prefix)
character(len=*), intent(in) :: prefix
end subroutine end_prefix_handler
end interface
integer :: l_d, l_p, l_ps, i
character, pointer :: prefix(:)
!It will only ever be the final elements in the list which
! might have expired.
l_d = ubound(nsDict%defaults,1)
do while (nsDict%defaults(l_d)%ix == ix)
if (present(end_prefix_handler)) &
call end_prefix_handler("")
call removeDefaultNS(nsDict)
l_d = ubound(nsDict%defaults,1)
enddo
l_p = ubound(nsDict%prefixes, 1)
i = 1
do while (i <= l_p)
l_ps = ubound(nsDict%prefixes(l_p)%urilist,1)
if (nsDict%prefixes(i)%urilist(l_ps)%ix == ix) then
if (present(end_prefix_handler)) &
call end_prefix_handler(str_vs(nsDict%prefixes(i)%prefix))
! We have to assign this pointer explicitly, otherwise the next call
! aliases its arguments illegally.
prefix => nsDict%prefixes(i)%prefix
call removePrefixedNS(nsDict, prefix)
if (l_p > ubound(nsDict%prefixes, 1)) then
! we just removed the last reference to that prefix,
! so our list of prefixes has shrunk - update the running total.
! and go to the next prefix, which is at the same index
l_p = l_p - 1
cycle
endif
endif
i = i + 1
enddo
end subroutine checkEndNamespaces
subroutine dumpnsdict(nsdict)
type(namespaceDictionary), intent(in) :: nsdict
integer :: i, j
write(*,'(a)')'* default namespaces *'
do i = 1, ubound(nsdict%defaults, 1)
write(*,'(i0,a)') nsdict%defaults(i)%ix, str_vs(nsdict%defaults(i)%URI)
enddo
write(*,'(a)') '* Prefixed namespaces *'
do i = 1, ubound(nsdict%prefixes, 1)
write(*,'(2a)') '* prefix: ', str_vs(nsdict%prefixes(i)%prefix)
do j = 1, ubound(nsdict%prefixes(i)%urilist, 1)
write(*,'(i0,a)') nsdict%prefixes(i)%urilist(j)%ix, str_vs(nsdict%prefixes(i)%urilist(j)%URI)
enddo
enddo
end subroutine dumpnsdict
pure function getURIofDefaultNS(nsDict) result(uri)
type(namespaceDictionary), intent(in) :: nsDict
character(len=size(nsDict%defaults(ubound(nsDict%defaults,1))%URI)) :: URI
integer :: l_d
l_d = ubound(nsDict%defaults,1)
uri = str_vs(nsDict%defaults(l_d)%URI)
end function getURIofDefaultNS
pure function isPrefixInForce(nsDict, prefix) result(force)
type(namespaceDictionary), intent(in) :: nsDict
character(len=*), intent(in) :: prefix
logical :: force
integer :: i, l_s
force = .false.
do i = 1, ubound(nsDict%prefixes, 1)
if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then
l_s = ubound(nsDict%prefixes(i)%urilist, 1)
force = (size(nsdict%prefixes(i)%urilist(l_s)%URI) > 0)
exit
endif
enddo
end function isPrefixInForce
pure function isDefaultNSInForce(nsDict) result(force)
type(namespaceDictionary), intent(in) :: nsDict
logical :: force
integer :: l_s
force = .false.
l_s = ubound(nsDict%defaults, 1)
if (l_s > 0) &
force = (size(nsdict%defaults(l_s)%URI) > 0)
end function isDefaultNSInForce
pure function getPrefixIndex(nsDict, prefix) result(p)
type(namespaceDictionary), intent(in) :: nsDict
character(len=*), intent(in) :: prefix
integer :: p
integer :: i
p = 0
do i = 1, ubound(nsDict%prefixes, 1)
if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then
p = i
exit
endif
enddo
end function getPrefixIndex
function getNumberOfPrefixes(nsDict) result(n)
type(namespaceDictionary), intent(in) :: nsDict
integer :: n
n = ubound(nsDict%prefixes, 1)
end function getNumberOfPrefixes
function getPrefixByIndex(nsDict, i) result(c)
type(namespaceDictionary), intent(in) :: nsDict
integer, intent(in) :: i
character(len=size(nsDict%prefixes(i)%prefix)) :: c
c = str_vs(nsDict%prefixes(i)%prefix)
end function getPrefixByIndex
pure function getURIofPrefixedNS(nsDict, prefix) result(uri)
type(namespaceDictionary), intent(in) :: nsDict
character(len=*), intent(in) :: prefix
character(len=size( &
nsDict%prefixes( &
getPrefixIndex(nsDict,prefix) &
) &
%urilist( &
ubound(nsDict%prefixes(getPrefixIndex(nsDict,prefix))%urilist, 1) &
) &
%uri)) :: URI
integer :: p_i, l_m
p_i = getPrefixIndex(nsDict, prefix)
l_m = ubound(nsDict%prefixes(p_i)%urilist, 1)
uri = str_vs(nsDict%prefixes(p_i)%urilist(l_m)%URI)
end function getURIofPrefixedNS
#endif
end module m_common_namespaces

120
src/xml/common/m_common_notations.F90 Normal file
View file

@ -0,0 +1,120 @@
module m_common_notations
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: vs_str, str_vs
use m_common_error, only: FoX_error
implicit none
private
type notation
character(len=1), dimension(:), pointer :: name
character(len=1), dimension(:), pointer :: systemID
character(len=1), dimension(:), pointer :: publicId
end type notation
type notation_list
type(notation), dimension(:), pointer :: list
end type notation_list
public :: notation
public :: notation_list
public :: init_notation_list
public :: destroy_notation_list
public :: add_notation
public :: notation_exists
contains
subroutine init_notation_list(nlist)
! It is not clear how we should specify the
! intent of this argument - different
! compilers seem to have different semantics
type(notation_list), intent(inout) :: nlist
allocate(nlist%list(0:0))
allocate(nlist%list(0)%name(0))
allocate(nlist%list(0)%systemId(0))
allocate(nlist%list(0)%publicId(0))
end subroutine init_notation_list
subroutine destroy_notation_list(nlist)
type(notation_list), intent(inout) :: nlist
integer :: i
do i = 0, ubound(nlist%list, 1)
deallocate(nlist%list(i)%name)
deallocate(nlist%list(i)%systemId)
deallocate(nlist%list(i)%publicId)
enddo
deallocate(nlist%list)
end subroutine destroy_notation_list
subroutine add_notation(nlist, name, systemId, publicId)
type(notation_list), intent(inout) :: nlist
character(len=*), intent(in) :: name
character(len=*), intent(in), optional :: systemId
character(len=*), intent(in), optional :: publicId
integer :: i
type(notation), dimension(:), pointer :: temp
! pointer not allocatable to avoid bug on Lahey
if (.not.present(systemId) .and. .not.present(publicId)) &
call FoX_error("Neither System nor Public Id specified for notation: "//name)
allocate(temp(0:ubound(nlist%list,1)))
do i = 0, ubound(nlist%list, 1)
temp(i)%name => nlist%list(i)%name
temp(i)%systemId => nlist%list(i)%systemId
temp(i)%publicId => nlist%list(i)%publicId
enddo
deallocate(nlist%list)
allocate(nlist%list(0:ubound(temp, 1)+1))
do i = 0, ubound(temp, 1)
nlist%list(i)%name => temp(i)%name
nlist%list(i)%systemId => temp(i)%systemId
nlist%list(i)%publicId => temp(i)%publicId
enddo
deallocate(temp)
allocate(nlist%list(i)%name(len(name)))
nlist%list(i)%name = vs_str(name)
if (present(systemId)) then
allocate(nlist%list(i)%systemId(len(systemId)))
nlist%list(i)%systemId = vs_str(systemId)
else
allocate(nlist%list(i)%systemId(0))
endif
if (present(publicId)) then
allocate(nlist%list(i)%publicId(len(publicId)))
nlist%list(i)%publicId = vs_str(publicId)
else
allocate(nlist%list(i)%publicId(0))
endif
end subroutine add_notation
function notation_exists(nlist, name) result(p)
type(notation_list), intent(in) :: nlist
character(len=*), intent(in) :: name
logical :: p
integer :: i
p = .false.
do i = 1, ubound(nlist%list, 1)
if (str_vs(nlist%list(i)%name) == name) then
p = .true.
exit
endif
enddo
end function notation_exists
#endif
end module m_common_notations

121
src/xml/common/m_common_struct.F90 Normal file
View file

@ -0,0 +1,121 @@
module m_common_struct
#ifndef DUMMYLIB
! Common parts of an XML document. Shared by both SAX & WXML.
use FoX_utils, only: URI
use m_common_charset, only: XML1_0
use m_common_entities, only: entity_list, init_entity_list, destroy_entity_list, &
add_internal_entity, add_external_entity
use m_common_element, only: element_list, init_element_list, destroy_element_list
use m_common_notations, only: notation_list, init_notation_list, destroy_notation_list
implicit none
private
type xml_doc_state
logical :: building = .false. ! Are we in the middle of building this doc?
integer :: xml_version = XML1_0
logical :: standalone_declared = .false.
logical :: standalone = .false.
type(entity_list) :: entityList
type(entity_list) :: PEList
type(notation_list) :: nList
type(element_list) :: element_list
logical :: warning = .false. ! Do we care about warnings?
logical :: valid = .true. ! Do we care about validity?
logical :: liveNodeLists = .true. ! Do we want live nodelists?
character, pointer :: encoding(:) => null()
character, pointer :: inputEncoding(:) => null()
character, pointer :: documentURI(:) => null()
character, pointer :: intSubset(:) => null()
end type xml_doc_state
public :: xml_doc_state
public :: init_xml_doc_state
public :: destroy_xml_doc_state
public :: register_internal_PE
public :: register_external_PE
public :: register_internal_GE
public :: register_external_GE
contains
subroutine init_xml_doc_state(xds)
type(xml_doc_state), intent(inout) :: xds
call init_entity_list(xds%entityList)
call init_entity_list(xds%PEList)
call init_notation_list(xds%nList)
call init_element_list(xds%element_list)
allocate(xds%inputEncoding(0))
allocate(xds%intSubset(0))
end subroutine init_xml_doc_state
subroutine destroy_xml_doc_state(xds)
type(xml_doc_state), intent(inout) :: xds
call destroy_entity_list(xds%entityList)
call destroy_entity_list(xds%PEList)
call destroy_notation_list(xds%nList)
call destroy_element_list(xds%element_list)
if (associated(xds%encoding)) deallocate(xds%encoding)
if (associated(xds%inputEncoding)) deallocate(xds%inputEncoding)
if (associated(xds%documentURI)) deallocate(xds%documentURI)
deallocate(xds%intSubset)
end subroutine destroy_xml_doc_state
subroutine register_internal_PE(xds, name, text, wfc, baseURI)
type(xml_doc_state), intent(inout) :: xds
character(len=*), intent(in) :: name
character(len=*), intent(in) :: text
logical, intent(in) :: wfc
type(URI), pointer :: baseURI
call add_internal_entity(xds%PEList, name=name, text=text, &
wfc=wfc, baseURI=baseURI)
end subroutine register_internal_PE
subroutine register_external_PE(xds, name, systemId, wfc, baseURI, publicId)
type(xml_doc_state), intent(inout) :: xds
character(len=*), intent(in) :: name
character(len=*), intent(in) :: systemId
logical, intent(in) :: wfc
character(len=*), intent(in), optional :: publicId
type(URI), pointer :: baseURI
call add_external_entity(xds%PEList, name=name, &
publicId=publicId, systemId=systemId, &
wfc=wfc, baseURI=baseURI)
end subroutine register_external_PE
subroutine register_internal_GE(xds, name, text, wfc, baseURI)
type(xml_doc_state), intent(inout) :: xds
character(len=*), intent(in) :: name
character(len=*), intent(in) :: text
logical, intent(in) :: wfc
type(URI), pointer :: baseURI
call add_internal_entity(xds%entityList, name=name, text=text, &
wfc=wfc, baseURI=baseURI)
end subroutine register_internal_GE
subroutine register_external_GE(xds, name, systemId, wfc, baseURI, publicId, notation)
type(xml_doc_state), intent(inout) :: xds
character(len=*), intent(in) :: name
character(len=*), intent(in) :: systemId
logical, intent(in) :: wfc
character(len=*), intent(in), optional :: publicId
character(len=*), intent(in), optional :: notation
type(URI), pointer :: baseURI
call add_external_entity(xds%entityList, name=name, &
systemId=systemId, publicId=publicId, notation=notation, &
wfc=wfc, baseURI=baseURI)
end subroutine register_external_GE
#endif
end module m_common_struct

265
src/xml/dom/FoX_dom.F90 Normal file
View file

@ -0,0 +1,265 @@
module FoX_dom
use fox_common, only: countrts
use fox_m_fsys_array_str
use fox_m_fsys_format
use m_dom_dom
use m_dom_error
use m_dom_extras
use m_dom_parse
use m_dom_utils
implicit none
private
public :: str_vs, vs_vs_alloc, vs_str_alloc
public :: str, operator(//)
public :: DOMImplementation
public :: Node
public :: NodeList
public :: NamedNodeMap
! DOM DOMString
! no
! DOM DOMTimestamp
! public :: DOMTimestamp
! DOM Exceptions
public :: DOMException
public :: inException
public :: getExceptionCode
public :: INDEX_SIZE_ERR
public :: DOMSTRING_SIZE_ERR
public :: HIERARCHY_REQUEST_ERR
public :: WRONG_DOCUMENT_ERR
public :: INVALID_CHARACTER_ERR
public :: NO_DATA_ALLOWED_ERR
public :: NO_MODIFICATION_ALLOWED_ERR
public :: NOT_FOUND_ERR
public :: NOT_SUPPORTED_ERR
public :: INUSE_ATTRIBUTE_ERR
public :: INVALID_STATE_ERR
public :: SYNTAX_ERR
public :: INVALID_MODIFICATION_ERR
public :: NAMESPACE_ERR
public :: INVALID_ACCESS_ERR
public :: VALIDATION_ERR
public :: TYPE_MISMATCH_ERR
! XPath
public :: INVALID_EXPRESSION_ERR
public :: TYPE_ERR
! LS
public :: PARSE_ERR
public :: SERIALIZE_ERR
! DOM Implementation
public :: hasFeature
public :: createDocumentType
public :: createDocument
! DOM Document
public :: getDocumentElement
public :: getDocType
public :: getImplementation
public :: createDocumentFragment
public :: createElement
public :: createTextNode
public :: createComment
public :: createCDATASection
public :: createProcessingInstruction
public :: createAttribute
public :: createEntityReference
public :: getElementsByTagName
public :: getElementById
public :: importNode
public :: createElementNS
public :: createAttributeNS
public :: getElementsByTagNameNS
public :: getXmlStandalone
public :: setXmlStandalone
public :: getXmlVersion
public :: setXmlVersion
public :: getXmlEncoding
public :: getInputEncoding
public :: getDocumentURI
public :: setDocumentURI
public :: getStrictErrorChecking
public :: setStrictErrorChecking
public :: getDomConfig
public :: normalizeDocument
public :: renameNode
public :: adoptNode
! DOM Node
public :: ELEMENT_NODE
public :: ATTRIBUTE_NODE
public :: TEXT_NODE
public :: CDATA_SECTION_NODE
public :: ENTITY_REFERENCE_NODE
public :: ENTITY_NODE
public :: PROCESSING_INSTRUCTION_NODE
public :: COMMENT_NODE
public :: DOCUMENT_NODE
public :: DOCUMENT_TYPE_NODE
public :: DOCUMENT_FRAGMENT_NODE
public :: NOTATION_NODE
public :: getNodeName
public :: getNodeValue
public :: setNodeValue
public :: getNodeType
public :: getFirstChild
public :: getLastChild
public :: getAttributes
public :: getNextSibling
public :: getPreviousSibling
public :: getParentNode
public :: getChildNodes
public :: getOwnerDocument
public :: insertBefore
public :: replaceChild
public :: removeChild
public :: appendChild
public :: hasChildNodes
public :: cloneNode
public :: normalize
public :: isSupported
public :: getNamespaceURI
public :: getPrefix
public :: setPrefix
public :: getLocalName
public :: hasAttributes
public :: getTextContent
public :: setTextContent
public :: isEqualNode
public :: isSameNode
public :: isDefaultNamespace
public :: lookupNamespaceURI
public :: lookupPrefix
! DOM NodeList
public :: item
public :: append
! DOM NamedNodeMap
public :: getLength
public :: getNamedItem
public :: setNamedItem
public :: removeNamedItem
! public :: item
public :: getNamedItemNS
public :: setNamedItemNS
public :: removeNamedItemNS
! DOM CharacterData
! NB We use the native Fortran string type here
! rather than inventing a DOM String, thus no
! string type to make public
! public :: getData
! public :: setData
public :: substringData
public :: appendData
public :: insertData
public :: deleteData
public :: replaceData
! DOM Attr
! public :: getName
public :: getSpecified
public :: getValue
public :: setValue
public :: getOwnerElement
public :: getIsId
! DOM Element
public :: getTagName
public :: getAttribute
public :: setAttribute
public :: removeAttribute
public :: getAttributeNode
public :: setAttributeNode
public :: removeAttributeNode
! public :: getElementsByTagName
public :: getAttributeNS
public :: setAttributeNS
public :: removeAttributeNS
public :: getAttributeNodeNS
public :: setAttributeNodeNS
! public :: getElementsByTagNameNS
public :: hasAttribute
public :: hasAttributeNS
public :: setIdAttribute
public :: setIdAttributeNS
public :: setIdAttributeNode
!DOM Text
public :: splitText
public :: getIsElementContentWhitespace
!DOM CData
! public :: getData
! public :: setData
!DOM DocumentType
public :: getEntities
public :: getNotations
public :: getInternalSubset
!DOM Notation
!DOM Entity
public :: getNotationName
!DOM EntityReference
!DOM ProcessingInstruction
! public :: getData
! public :: setData
public :: getTarget
!DOM common
public :: getData
public :: setData
public :: getName
public :: getPublicId
public :: getSystemId
!DOM Configuration
public :: DOMConfiguration
public :: getParameter
public :: setParameter
public :: canSetParameter
public :: getParameterNames
! FoX-only interfaces
public :: newDOMConfig
public :: getNodePath
public :: extractDataContent
public :: extractDataAttribute
public :: extractDataAttributeNS
public :: parseFile
public :: parseString
public :: serialize
public :: destroy
public :: getFoX_checks
public :: setFoX_checks
public :: getLiveNodeLists
public :: setLiveNodeLists
public :: getNamespaceNodes
! Length of array
public :: countrts
end module FoX_dom

49
src/xml/dom/Makefile Normal file
View file

@ -0,0 +1,49 @@
source = $(wildcard *.F90)
objects = $(source:.F90=.o)
#===============================================================================
# Compiler Options
#===============================================================================
# Ignore unusd variables
ifeq ($(MACHINE),bluegene)
override F90 = xlf2003
endif
ifeq ($(F90),ifort)
override F90FLAGS += -warn nounused
endif
#===============================================================================
# Targets
#===============================================================================
all: $(objects)
mv *.mod ../include
mv *.o ../lib
clean:
@rm -f *.o *.mod
neat:
@rm -f *.o *.mod
#===============================================================================
# Rules
#===============================================================================
.SUFFIXES: .F90 .o
.PHONY: clean neat
%.o: %.F90
$(F90) $(F90FLAGS) -c -I../include $<
#===============================================================================
# Dependencies
#===============================================================================
FoX_dom.o: m_dom_dom.o m_dom_error.o m_dom_extras.o m_dom_parse.o m_dom_utils.o
m_dom_dom.o: m_dom_error.o
m_dom_extras.o: m_dom_dom.o m_dom_error.o
m_dom_parse.o: m_dom_dom.o m_dom_error.o
m_dom_utils.o: m_dom_dom.o m_dom_error.o

12323
src/xml/dom/m_dom_dom.F90 Normal file
View file

File diff suppressed because it is too large Load diff

211
src/xml/dom/m_dom_error.F90 Normal file
View file

@ -0,0 +1,211 @@
module m_dom_error
use fox_m_fsys_abort_flush, only: pxfabort
use m_common_error, only: error_stack, add_error, in_error, destroy_error_stack
implicit none
private
type DOMException
private
type(error_stack) :: stack
end type DOMException
integer, parameter, public :: INDEX_SIZE_ERR = 1
integer, parameter, public :: DOMSTRING_SIZE_ERR = 2
integer, parameter, public :: HIERARCHY_REQUEST_ERR = 3
integer, parameter, public :: WRONG_DOCUMENT_ERR = 4
integer, parameter, public :: INVALID_CHARACTER_ERR = 5
integer, parameter, public :: NO_DATA_ALLOWED_ERR = 6
integer, parameter, public :: NO_MODIFICATION_ALLOWED_ERR = 7
integer, parameter, public :: NOT_FOUND_ERR = 8
integer, parameter, public :: NOT_SUPPORTED_ERR = 9
integer, parameter, public :: INUSE_ATTRIBUTE_ERR = 10
integer, parameter, public :: INVALID_STATE_ERR = 11
integer, parameter, public :: SYNTAX_ERR = 12
integer, parameter, public :: INVALID_MODIFICATION_ERR = 13
integer, parameter, public :: NAMESPACE_ERR = 14
integer, parameter, public :: INVALID_ACCESS_ERR = 15
integer, parameter, public :: VALIDATION_ERR = 16
integer, parameter, public :: TYPE_MISMATCH_ERR = 17
integer, parameter, public :: INVALID_EXPRESSION_ERR = 51
integer, parameter, public :: TYPE_ERR = 52
integer, parameter, public :: PARSE_ERR = 81
integer, parameter, public :: SERIALIZE_ERR = 82
integer, parameter, public :: FoX_INVALID_NODE = 201
integer, parameter, public :: FoX_INVALID_CHARACTER = 202
integer, parameter, public :: FoX_NO_SUCH_ENTITY = 203
integer, parameter, public :: FoX_INVALID_PI_DATA = 204
integer, parameter, public :: FoX_INVALID_CDATA_SECTION = 205
integer, parameter, public :: FoX_HIERARCHY_REQUEST_ERR = 206
integer, parameter, public :: FoX_INVALID_PUBLIC_ID = 207
integer, parameter, public :: FoX_INVALID_SYSTEM_ID = 208
integer, parameter, public :: FoX_INVALID_COMMENT = 209
integer, parameter, public :: FoX_NODE_IS_NULL = 210
integer, parameter, public :: FoX_INVALID_ENTITY = 211
integer, parameter, public :: FoX_INVALID_URI = 212
integer, parameter, public :: FoX_IMPL_IS_NULL = 213
integer, parameter, public :: FoX_MAP_IS_NULL = 214
integer, parameter, public :: FoX_LIST_IS_NULL = 215
integer, parameter, public :: FoX_INTERNAL_ERROR = 999
public :: DOMException
public :: getExceptionCode
public :: throw_exception
public :: inException
public :: dom_error
public :: internal_error
contains
pure function errorString(code) result(s)
integer, intent(in) :: code
character(len=27) :: s
select case(code)
case(1)
s = "INDEX_SIZE_ERR"
case(2)
s = "DOMSTRING_SIZE_ERR"
case(3)
s = "HIERARCHY_REQUEST_ERR"
case(4)
s = "WRONG_DOCUMENT_ERR"
case(5)
s = "INVALID_CHARACTER_ERR"
case(6)
s = "NO_DATA_ALLOWED_ERR"
case(7)
s = "NO_MODIFICATION_ALLOWED_ERR"
case(8)
s = "NOT_FOUND_ERR"
case(9)
s = "NOT_SUPPORTED_ERR"
case(10)
s = "INUSE_ATTRIBUTE_ERR"
case(11)
s = "INVALID_STATE_ERR"
case(12)
s = "SYNTAX_ERR"
case(13)
s = "INVALID_MODIFICATION_ERR"
case(14)
s = "NAMESPACE_ERR"
case(15)
s = "INVALID_ACCESS_ERR"
case(16)
s = "VALIDATION_ERR"
case(18)
s = "TYPE_MISMATCH_ERR"
case(51)
s = "INVALID_EXPRESSION_ERR"
case(52)
s = "TYPE_ERR"
case(81)
s = "PARSE_ERR"
case(82)
s = "SERIALIZE_ERR"
case(201)
s = "FoX_INVALID_NODE"
case(202)
s = "FoX_INVALID_CHARACTER"
case(203)
s = "FoX_NO_SUCH_ENTITY"
case(204)
s = "FoX_INVALID_PI_DATA"
case(205)
s = "FoX_INVALID_CDATA_SECTION"
case(206)
s = "FoX_HIERARCHY_REQUEST_ERR"
case(207)
s = "FoX_INVALID_PUBLIC_ID"
case(208)
s = "FoX_INVALID_SYSTEM_ID"
case(209)
s = "FoX_INVALID_COMMENT"
case(210)
s = "FoX_NODE_IS_NULL"
case(211)
s = "FoX_INVALID_ENTITY"
case(212)
s = "FoX_NO_DOCTYPE"
case(213)
s = "FoX_IMPL_IS_NULL"
case(214)
s = "FoX_MAP_IS_NULL"
case(215)
s = "FoX_LIST_IS_NULL"
case default
s = "INTERNAL ERROR!!!!"
end select
end function errorString
function getExceptionCode(ex) result(n)
type(DOMException), intent(inout) :: ex
integer :: n
if (in_error(ex%stack)) then
n = ex%stack%stack(size(ex%stack%stack))%error_code
call destroy_error_stack(ex%stack)
else
n = 0
endif
end function getExceptionCode
subroutine throw_exception(code, msg, ex)
integer, intent(in) :: code
character(len=*), intent(in) :: msg
type(DOMException), intent(inout), optional :: ex
if (present(ex)) then
call add_error(ex%stack, msg, error_code=code) ! FIXME
else
write(0,'(a)') errorString(code)
write(0,'(i0,a)') code, " "//msg
call pxfabort()
endif
end subroutine throw_exception
subroutine dom_error(name,code,msg)
character(len=*), intent(in) :: name, msg
integer, intent(in) :: code
write(0,'(4a)') "Routine ", name, ":", msg
write(0,'(a)') errorString(code)
call pxfabort()
end subroutine dom_error
subroutine destroyDOMException(ex)
type(DOMException), intent(inout) :: ex
call destroy_error_stack(ex%stack)
end subroutine destroyDOMException
subroutine internal_error(name,msg)
character(len=*), intent(in) :: name, msg
write(0,'(4a)') "Internal error in ", name, ":", msg
call pxfabort()
end subroutine internal_error
function inException(ex) result(p)
type(DOMException), intent(in) :: ex
logical :: p
p = in_error(ex%stack)
end function inException
end module m_dom_error

2444
src/xml/dom/m_dom_extras.F90 Normal file
View file

File diff suppressed because it is too large Load diff

577
src/xml/dom/m_dom_parse.F90 Normal file
View file

@ -0,0 +1,577 @@
module m_dom_parse
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc
use fox_m_utils_uri, only: URI, parseURI, rebaseURI, expressURI, destroyURI
use m_common_attrs, only: hasKey, getValue, getIndex, getIsId, getBase, &
add_item_to_dict
use m_common_entities, only: entity_t, size, getEntityByIndex
use m_common_error, only: FoX_error, in_error
use m_common_struct, only: xml_doc_state
use FoX_common, only: dictionary_t, getLength
use FoX_common, only: getQName, getValue, getURI, isSpecified
use m_sax_parser, only: sax_parse
use FoX_sax, only: xml_t
use FoX_sax, only: open_xml_file, open_xml_string, close_xml_t
! Public interfaces
use m_dom_dom, only: DOMConfiguration, Node, NamedNodeMap, &
TEXT_NODE, &
getAttributes, getData, getDocType, getEntities, getImplementation, &
getLastChild, getNodeType, &
getNotations, getParameter, getParentNode, getXmlVersion, &
setAttribute, setAttributeNS, setData, setValue, &
appendChild, createAttribute, createAttributeNS, createCdataSection, &
createComment, createDocumentType, createElement, createElementNS, &
createEntityReference, createProcessingInstruction, createTextNode, &
getNamedItem, setAttributeNode, setAttributeNodeNS, setNamedItem, &
getFoX_checks
! Private interfaces
use m_dom_dom, only: copyDOMConfig, createEmptyDocument, setDocumentElement, &
createEmptyEntityReference, createEntity, createNotation, &
getReadOnly, getStringValue, getXds, destroy, destroyAllNodesRecursively, &
namespaceFixup, setDocType, setDomConfig, setGCstate, setIllFormed, &
setIsElementContentWhitespace, setIsId, setReadOnlyMap, setReadonlyNode, &
setSpecified, setXds, setStringValue
use m_dom_error, only: DOMException, inException, throw_exception, &
getExceptionCode, PARSE_ERR
implicit none
private
public :: parsefile
public :: parsestring
type(xml_t), target, save :: fxml
type(Node), pointer, save :: mainDoc => null()
type(Node), pointer, save :: current => null()
type(DOMConfiguration), pointer :: domConfig
logical :: cdata
character, pointer :: error(:) => null()
character, pointer :: inEntity(:) => null()
contains
subroutine startElement_handler(nsURI, localname, name, attrs)
character(len=*), intent(in) :: nsURI
character(len=*), intent(in) :: localname
character(len=*), intent(in) :: name
type(dictionary_t), intent(in) :: attrs
type(URI), pointer :: URIref, URIbase, newURI
type(Node), pointer :: el, attr, dummy
character, pointer :: baseURI(:)
integer :: i
if (getParameter(domConfig, "namespaces")) then
el => createElementNS(mainDoc, nsURI, name)
else
el => createElement(mainDoc, name)
endif
if (getBase(attrs)/="") then
i = getIndex(attrs, "xml:base")
if (i>0) then
URIbase => parseURI(getBase(attrs))
URIref => parseURI(getValue(attrs, i))
newURI => rebaseURI(URIbase, URIref)
call destroyURI(URIbase)
call destroyURI(URIref)
baseURI => vs_str_alloc(expressURI(newURI))
call destroyURI(newURI)
else
baseURI => vs_str_alloc(getBase(attrs))
endif
if (getParameter(domConfig, "namespaces")) then
attr => createAttributeNS(mainDoc, &
"http://www.w3.org/XML/1998/namespace", "xml:base")
else
attr => createAttribute(mainDoc, "xml:base")
endif
call setValue(attr, str_vs(baseURI))
deallocate(baseURI)
if (i>0) then
call setSpecified(attr, isSpecified(attrs, i))
call setIsId(attr, getIsId(attrs, i))
endif
if (getParameter(domConfig, "namespaces")) then
dummy => setAttributeNodeNS(el, attr)
else
dummy => setAttributeNode(el, attr)
endif
endif
do i = 1, getLength(attrs)
if (getQName(attrs, i)=="xml:base") cycle
if (getParameter(domConfig, "namespaces")) then
attr => createAttributeNS(mainDoc, getURI(attrs, i), getQName(attrs, i))
else
attr => createAttribute(mainDoc, getQName(attrs, i))
endif
call setValue(attr, getValue(attrs, i))
call setSpecified(attr, isSpecified(attrs, i))
call setIsId(attr, getIsId(attrs, i))
if (getParameter(domConfig, "namespaces")) then
dummy => setAttributeNodeNS(el, attr)
else
dummy => setAttributeNode(el, attr)
endif
if (associated(inEntity)) call setReadOnlyNode(attr, .true., .true.)
enddo
if (associated(current, mainDoc)) then
current => appendChild(current,el)
call setDocumentElement(mainDoc, current)
else
current => appendChild(current,el)
endif
if (getParameter(domConfig, "namespaces")) &
call namespaceFixup(current, .false.)
if (associated(inEntity)) &
call setReadOnlyMap(getAttributes(current), .true.)
cdata = .false.
end subroutine startElement_handler
subroutine endElement_handler(URI, localName, name)
character(len=*), intent(in) :: URI
character(len=*), intent(in) :: localname
character(len=*), intent(in) :: name
if (associated(inEntity)) call setReadOnlyNode(current, .true., .false.)
current => getParentNode(current)
end subroutine endElement_handler
! FIXME to pick up entity references within attribute values, we need
! separate just_the_element, start_attribute, attribute_text etc. calls.
subroutine characters_handler(chunk)
character(len=*), intent(in) :: chunk
type(Node), pointer :: temp
logical :: readonly
temp => getLastChild(current)
if (associated(temp)) then
if (.not.cdata.and.getNodeType(temp)==TEXT_NODE) then
readonly = getReadOnly(temp) ! Reset readonly status quickly
call setReadOnlyNode(temp, .false., .false.)
call setData(temp, getData(temp)//chunk)
call setReadOnlyNode(temp, readonly, .false.)
return
endif
endif
if (cdata) then
temp => createCdataSection(mainDoc, chunk)
temp => appendChild(current, temp)
else
temp => createTextNode(mainDoc, chunk)
temp => appendChild(current, temp)
endif
if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.)
end subroutine characters_handler
subroutine ignorableWhitespace_handler(chunk)
character(len=*), intent(in) :: chunk
type(Node), pointer :: temp
logical :: readonly
if (getParameter(domConfig, "element-content-whitespace")) then
temp => getLastChild(current)
if (associated(temp)) then
if (getNodeType(temp)==TEXT_NODE) then
readonly = getReadOnly(temp) ! Reset readonly status quickly
call setReadOnlyNode(temp, .false., .false.)
call setData(temp, getData(temp)//chunk)
call setReadOnlyNode(temp, readonly, .false.)
call setIsElementContentWhitespace(temp, .true.)
return
endif
endif
temp => createTextNode(mainDoc, chunk)
temp => appendChild(current, temp)
call setIsElementContentWhitespace(temp, .true.)
if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.)
endif
end subroutine ignorableWhitespace_handler
subroutine comment_handler(comment)
character(len=*), intent(in) :: comment
type(Node), pointer :: temp
if (getParameter(domConfig, "comments")) then
temp => appendChild(current, createComment(mainDoc, comment))
if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.)
endif
end subroutine comment_handler
subroutine processingInstruction_handler(target, data)
character(len=*), intent(in) :: target
character(len=*), intent(in) :: data
type(Node), pointer :: temp
temp => appendChild(current, &
createProcessingInstruction(mainDoc, target, data))
if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.)
end subroutine processingInstruction_handler
subroutine startDocument_handler
mainDoc => createEmptyDocument()
current => mainDoc
call setGCstate(mainDoc, .false.)
call setDomConfig(mainDoc, domConfig)
end subroutine startDocument_handler
subroutine endDocument_Handler
call setGCstate(mainDoc, .true.)
end subroutine endDocument_Handler
subroutine startDTD_handler(name, publicId, systemId)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
type(Node), pointer :: np
np => createDocumentType(getImplementation(mainDoc), name, publicId=publicId, systemId=systemId)
np => appendChild(mainDoc, np)
call setDocType(mainDoc, np)
end subroutine startDTD_handler
subroutine endDTD_handler
type(Node), pointer :: np, oldcurrent
type(NamedNodeMap), pointer :: entities
type(xml_t) :: subsax
type(xml_doc_state), pointer :: xds
type(entity_t), pointer :: ent
integer :: i, ios
logical :: ok
entities => getEntities(getDocType(mainDoc))
xds => getXds(mainDoc)
do i = 1, size(xds%entityList)
ent => getEntityByIndex(xds%entityList, i)
np => getNamedItem(entities, str_vs(ent%name))
ok = .false.
if (ent%external) then
if (size(ent%notation)==0) then
call open_xml_file(subsax, expressURI(ent%baseURI), iostat=ios)
if (ios/=0) then
call setIllFormed(np, .true.)
else
ok = .true.
endif
endif
else
call open_xml_string(subsax, getStringValue(np))
ok = .true.
endif
if (ok) then
oldcurrent => current
current => np
! Run the parser over value
! We do this with all entities already declared.
call sax_parse(subsax%fx, subsax%fb, &
startElement_handler=startElement_handler, &
endElement_handler=endElement_handler, &
characters_handler=characters_handler, &
startCdata_handler=startCdata_handler, &
endCdata_handler=endCdata_handler, &
comment_handler=comment_handler, &
processingInstruction_handler=processingInstruction_handler, &
fatalError_handler=entityErrorHandler, &
startInCharData = .true., &
externalEntity = ent%external, &
xmlVersion = getXmlVersion(mainDoc), &
namespaces=getParameter(domConfig, "namespaces"), &
initial_entities = xds%entityList)
call close_xml_t(subsax)
current => oldcurrent
endif
enddo
if (associated(getDocType(mainDoc))) then
call setReadonlyMap(getEntities(getDocType(mainDoc)), .true.)
call setReadonlyMap(getNotations(getDocType(mainDoc)), .true.)
endif
end subroutine endDTD_handler
subroutine FoX_endDTD_handler(state)
type(xml_doc_state), pointer :: state
call setXds(mainDoc, state)
end subroutine FoX_endDTD_handler
subroutine notationDecl_handler(name, publicId, systemId)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
type(Node), pointer :: np
np => createNotation(mainDoc, name, publicId=publicId, systemId=systemId)
np => setNamedItem(getNotations(getDocType(mainDoc)), np)
! The SAX parser will never give us duplicate entities,
! so there is no need to check
end subroutine notationDecl_handler
subroutine startCdata_handler()
if (getParameter(domConfig, "cdata-sections")) cdata = .true.
end subroutine startCdata_handler
subroutine endCdata_handler()
cdata = .false.
end subroutine endCdata_handler
subroutine internalEntityDecl_handler(name, value)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: value
type(Node), pointer :: np
if (name(1:1)=="%") return
! Do nothing with parameter entities
! We only note that these exist here.
! A second parsing stage is triggered at the end
! of the DTD, in order to resolve entity references (which
! need not be declared in order)
np => createEntity(mainDoc, name, "", "", "")
call setStringValue(np, value)
np => setNamedItem(getEntities(getDocType(mainDoc)), np)
end subroutine internalEntityDecl_handler
subroutine normalErrorHandler(msg)
character(len=*), intent(in) :: msg
! This is called if the main parsing routine fails
error => vs_str_alloc(msg)
end subroutine normalErrorHandler
subroutine entityErrorHandler(msg)
character(len=*), intent(in) :: msg
!This gets called if parsing of an entity failed. If so,
!then we need to destroy all nodes which were being generated as
!children of this entity, then mark the entity as ill-formed - but
!otherwise carry on parsing the document, and only throw an error
!if a reference is made to it.
call destroyAllNodesRecursively(current, except=.true.)
call setIllFormed(current, .true.)
end subroutine entityErrorHandler
subroutine externalEntityDecl_handler(name, publicId, systemId)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
type(Node), pointer :: np
if (name(1:1)=="%") return
! Do nothing with parameter entities
np => createEntity(mainDoc, name, &
publicId=publicId, systemId=systemId, notationName="")
np => setNamedItem(getEntities(getDocType(mainDoc)), np)
end subroutine externalEntityDecl_handler
subroutine unparsedEntityDecl_handler(name, publicId, systemId, notationName)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
character(len=*), intent(in) :: notationName
type(Node), pointer :: np
np => getNamedItem(getEntities(getDocType(mainDoc)), name)
if (.not.associated(np)) then
np => createEntity(mainDoc, name, publicId=publicId, systemId=systemId, notationName=notationName)
np => setNamedItem(getEntities(getDocType(mainDoc)), np)
endif
end subroutine unparsedEntityDecl_handler
subroutine startEntity_handler(name)
character(len=*), intent(in) :: name
if (name(1:1)=="%") return
! Do nothing with parameter entities
if (getParameter(domConfig, "entities")) then
if (.not.associated(inEntity)) then
inEntity => vs_str_alloc(name)
endif
current => appendChild(current, createEmptyEntityReference(mainDoc, name))
endif
end subroutine startEntity_handler
subroutine endEntity_handler(name)
character(len=*), intent(in) :: name
if (name(1:1)=="%") return
! Do nothing with parameter entities
if (getParameter(domConfig, "entities")) then
call setReadOnlyNode(current, .true., .false.)
if (str_vs(inEntity)==name) deallocate(inEntity)
current => getParentNode(current)
endif
end subroutine endEntity_handler
subroutine skippedEntity_handler(name)
character(len=*), intent(in) :: name
type(Node), pointer :: temp
if (name(1:1)=="%") return
! Do nothing with parameter entities
temp => appendChild(current, createEntityReference(mainDoc, name))
if (associated(inEntity)) call setReadonlyNode(temp, .true., .false.)
end subroutine skippedEntity_handler
subroutine runParser(fxml, configuration, ex)
type(DOMException), intent(out), optional :: ex
type(xml_t), intent(inout) :: fxml
type(DOMConfiguration), pointer, optional :: configuration
allocate(DOMConfig)
if (present(configuration)) call copyDOMConfig(DOMConfig, configuration)
! We use internal sax_parse rather than public interface in order
! to use internal callbacks to get extra info.
call sax_parse(fx=fxml%fx, fb=fxml%fb,&
characters_handler=characters_handler, &
endDocument_handler=endDocument_handler, &
endElement_handler=endElement_handler, &
!endPrefixMapping_handler, &
ignorableWhitespace_handler=ignorableWhitespace_handler, &
processingInstruction_handler=processingInstruction_handler, &
! setDocumentLocator
skippedEntity_handler=skippedEntity_handler, &
startDocument_handler=startDocument_handler, &
startElement_handler=startElement_handler, &
!startPrefixMapping_handler, &
notationDecl_handler=notationDecl_handler, &
unparsedEntityDecl_handler=unparsedEntityDecl_handler, &
!error_handler, &
fatalError_handler=normalErrorHandler, &
!warning_handler, &
!attributeDecl_handler, &
!elementDecl_handler, &
externalEntityDecl_handler=externalEntityDecl_handler, &
internalEntityDecl_handler=internalEntityDecl_handler, &
comment_handler=comment_handler, &
endCdata_handler=endCdata_handler, &
endDTD_handler=endDTD_handler, &
endEntity_handler=endEntity_handler, &
startCdata_handler=startCdata_handler, &
startDTD_handler=startDTD_handler, &
startEntity_handler=startEntity_handler, &
FoX_endDTD_handler=FoX_endDTD_handler, &
namespaces = getParameter(domConfig, "namespaces"), &
namespace_prefixes = .true., &
validate = getParameter(domConfig, "validate"), & ! FIXME what about validate-if-present ...
xmlns_uris = .true.)
call close_xml_t(fxml)
if (associated(error)) then
if (associated(inEntity)) deallocate(inEntity)
! FIXME pass the value of the error through
! when we let exceptions do that
deallocate(error)
call destroy(mainDoc)
if (getFoX_checks().or.PARSE_ERR<200) then
call throw_exception(PARSE_ERR, "runParser", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
end subroutine runParser
function parsefile(filename, configuration, iostat, ex)
type(DOMException), intent(out), optional :: ex
character(len=*), intent(in) :: filename
type(DOMConfiguration), pointer, optional :: configuration
integer, intent(out), optional :: iostat
type(Node), pointer :: parsefile
type(DOMException) :: ex_
integer :: iostat_
call open_xml_file(fxml, filename, iostat_)
if (present(iostat)) then
iostat = iostat_
if (iostat/=0) return
elseif (in_error(fxml%fx%error_stack)) then
call FoX_error(str_vs(fxml%fx%error_stack%stack(1)%msg))
elseif (iostat_/=0) then
call FoX_error("Cannot open file")
endif
if (present(ex)) then
call runParser(fxml, configuration, ex)
elseif (present(iostat)) then
call runParser(fxml, configuration, ex_)
else
call runParser(fxml, configuration)
endif
if (present(iostat).and.inException(ex_)) then
iostat = getExceptionCode(ex_)
endif
parsefile => mainDoc
mainDoc => null()
end function parsefile
function parsestring(string, configuration, ex)
type(DOMException), intent(out), optional :: ex
character(len=*), intent(in) :: string
type(DOMConfiguration), pointer, optional :: configuration
type(Node), pointer :: parsestring
call open_xml_string(fxml, string)
call runParser(fxml, configuration, ex)
parsestring => mainDoc
mainDoc => null()
end function parsestring
end module m_dom_parse

437
src/xml/dom/m_dom_utils.F90 Normal file
View file

@ -0,0 +1,437 @@
module m_dom_utils
use fox_m_fsys_array_str, only: str_vs, vs_str
use fox_m_fsys_format, only: operator(//)
use m_common_attrs, only: getValue
use m_common_element, only: element_t, attribute_t, &
get_attlist_size, get_attribute_declaration, express_attribute_declaration
use m_common_struct, only: xml_doc_state
! Public interfaces
use m_dom_dom, only: DOMConfiguration, NamedNodeMap, Node, &
NodeList, &
ATTRIBUTE_NODE, CDATA_SECTION_NODE, COMMENT_NODE, DOCUMENT_NODE, &
DOCUMENT_TYPE_NODE, ELEMENT_NODE, ENTITY_REFERENCE_NODE, &
PROCESSING_INSTRUCTION_NODE, TEXT_NODE, &
getAttributes, getChildNodes, getData, getDomConfig, getEntities, &
getFirstChild, getFoX_checks, getLength, getLocalName, getName, &
getNamespaceURI, getNextSibling, getNodeName, getNodeType, getNotationName,&
getNotations, getOwnerDocument, getOwnerElement, getParameter, &
getParentNode, getPrefix, getPublicId, getSpecified, getSystemId, &
getTagName, getTarget, getXmlStandalone, getXmlVersion, getValue, &
haschildnodes, item, normalizeDocument
! Private interfaces
use m_dom_dom, only: getNamespaceNodes, getStringValue, getXds, namespaceFixup
use m_dom_error, only: DOMException, inException, throw_exception, &
getExceptionCode, &
NAMESPACE_ERR, SERIALIZE_ERR, FoX_INTERNAL_ERROR, FoX_INVALID_NODE
use FoX_wxml, only: xmlf_t, &
xml_AddAttribute, xml_AddCharacters, xml_AddComment, xml_AddElementToDTD, &
xml_AddEntityReference, xml_AddExternalEntity, xml_AddInternalEntity, &
xml_AddDOCTYPE, xml_AddNotation, xml_AddXMLDeclaration, xml_AddXMLPI, &
xml_EndElement, xml_Close, xml_DeclareNamespace, xml_NewElement, &
xml_OpenFile, xml_UndeclareNamespace, xml_AddAttlistToDTD
implicit none
public :: dumpTree
public :: serialize
private
contains
subroutine dumpTree(startNode)
type(Node), pointer :: startNode
integer :: indent_level
indent_level = 0
call dump2(startNode)
contains
recursive subroutine dump2(input)
type(Node), pointer :: input
type(Node), pointer :: temp, np
type(NamedNodeMap), pointer :: attrs
type(NodeList), pointer :: nsnodes
integer :: i
temp => input
do while(associated(temp))
write(*,"(3a,i0)") repeat(" ", indent_level), &
getNodeName(temp), " of type ", &
getNodeType(temp)
if (getNodeType(temp)==ELEMENT_NODE) then
write(*,"(2a)") repeat(" ", indent_level), &
" ATTRIBUTES:"
attrs => getAttributes(temp)
do i = 0, getLength(attrs) - 1
np => item(attrs, i)
write(*, "(2a)") repeat(" ", indent_level)//" ", &
getName(np)
enddo
write(*,"(2a)") repeat(" ", indent_level), &
" IN-SCOPE NAMESPACES:"
nsnodes => getNamespaceNodes(temp)
do i = 0, getLength(nsnodes) - 1
np => item(nsnodes, i)
write(*,"(4a)") repeat(" ", indent_level)//" ", &
getPrefix(np), ':', &
getNamespaceURI(np)
enddo
endif
if (hasChildNodes(temp)) then
indent_level = indent_level + 3
call dump2(getFirstChild(temp))
indent_level = indent_level - 3
endif
temp => getNextSibling(temp)
enddo
end subroutine dump2
end subroutine dumpTree
subroutine serialize(startNode, name, ex)
type(DOMException), intent(out), optional :: ex
type(Node), pointer :: startNode
character(len=*), intent(in) :: name
type(Node), pointer :: doc
type(xmlf_t) :: xf
integer :: iostat
logical :: xmlDecl
if (getNodeType(startNode)/=DOCUMENT_NODE &
.and.getNodeType(startNode)/=ELEMENT_NODE) then
if (getFoX_checks().or.FoX_INVALID_NODE<200) then
call throw_exception(FoX_INVALID_NODE, "serialize", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
if (getNodeType(startNode)==DOCUMENT_NODE) then
doc => startNode
if (getParameter(getDomConfig(doc), "canonical-form") &
.and.getXmlVersion(doc)=="1.1") then
if (getFoX_checks().or.SERIALIZE_ERR<200) then
call throw_exception(SERIALIZE_ERR, "serialize", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
call normalizeDocument(startNode, ex)
if (present(ex)) then
! Only possible error should be namespace error ...
! but we should avoid turning an error of 0 into
! an internal error!
if (inException(ex)) then
if (getExceptionCode(ex)/=NAMESPACE_ERR) then
if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then
call throw_exception(FoX_INTERNAL_ERROR, "serialize", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
else
if (getFoX_checks().or.SERIALIZE_ERR<200) then
call throw_exception(SERIALIZE_ERR, "serialize", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
endif
endif
else
doc => getOwnerDocument(startNode)
! We need to do this namespace fixup or serialization will fail.
! it doesn't change the semantics of the docs, but other
! normalization would, so we done here
! But only normalize if this is not a DOM level 1 node.
if (getLocalName(startNode)/="" &
.and.getParameter(getDomConfig(doc), "namespaces")) &
call namespaceFixup(startNode, .true.)
endif
xmlDecl = getParameter(getDomConfig(doc), "xml-declaration")
! FIXME we shouldnt really normalize the Document here
! (except for namespace Normalization) but rather just
! pay attention to the DOMConfig values
! NOTE: We set pretty_print on the basis of the FoX specific
! "invalid-pretty-print" config option. The DOM-L3-LS
! option "format-pretty-print is always false and is
! not settable by the user - this is because WXML
! cannot preserve validity conditions that may be set
! by a DTD. If WXML ever learns to do this we will need
! to pass the value of "format-pretty-print" through.
call xml_OpenFile(name, xf, iostat=iostat, unit=-1, &
pretty_print=getParameter(getDomConfig(doc), "invalid-pretty-print"), &
canonical=getParameter(getDomConfig(doc), "canonical-form"), &
warning=.false., addDecl=.false.)
if (iostat/=0) then
if (getFoX_checks().or.SERIALIZE_ERR<200) then
call throw_exception(SERIALIZE_ERR, "serialize", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
if (xmlDecl) then
if (getXmlStandalone(doc)) then
call xml_AddXMLDeclaration(xf, version=getXmlVersion(doc), standalone=.true.)
else
call xml_AddXMLDeclaration(xf, version=getXmlVersion(doc))
endif
endif
call iter_dmp_xml(xf, startNode, ex)
call xml_Close(xf)
end subroutine serialize
subroutine iter_dmp_xml(xf, arg, ex)
type(DOMException), intent(out), optional :: ex
type(xmlf_t), intent(inout) :: xf
type(Node), pointer :: this, arg, treeroot
type(Node), pointer :: doc, attrchild, np
type(NamedNodeMap), pointer :: nnm
type(DOMConfiguration), pointer :: dc
type(xml_doc_state), pointer :: xds
type(element_t), pointer :: elem
type(attribute_t), pointer :: att_decl
integer :: i_tree, j, k
logical :: doneChildren, doneAttributes
character, pointer :: attrvalue(:), tmp(:)
if (getNodeType(arg)==DOCUMENT_NODE) then
doc => arg
else
doc => getOwnerDocument(arg)
endif
dc => getDomConfig(doc)
xds => getXds(doc)
treeroot => arg
i_tree = 0
doneChildren = .false.
doneAttributes = .false.
this => treeroot
do
if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then
select case(getNodeType(this))
case (ELEMENT_NODE)
nnm => getAttributes(this)
do j = 0, getLength(nnm) - 1
attrchild => item(nnm, j)
if (getLocalName(attrchild)=="xmlns") then
if (len(getValue(attrchild))==0) then
call xml_UndeclareNamespace(xf)
else
call xml_DeclareNamespace(xf, getValue(attrchild))
endif
elseif (getPrefix(attrchild)=="xmlns") then
if (len(getValue(attrchild))==0) then
call xml_UndeclareNamespace(xf, getLocalName(attrchild))
else
call xml_DeclareNamespace(xf, getValue(attrchild), &
getLocalName(attrchild))
endif
endif
enddo
call xml_NewElement(xf, getTagName(this))
case (ATTRIBUTE_NODE)
if ((.not.getParameter(dc, "discard-default-content") &
.or.getSpecified(this)) &
! only output it if it is not a default, or we are outputting defaults
.and. (getPrefix(this)/="xmlns".and.getLocalName(this)/="xmlns")) then
! and we dont output NS declarations here.
! complex loop below is because we might have to worry about entrefs
! being preserved in the attvalue. If we dont, we only go through the loop once anyway.
allocate(attrvalue(0))
do j = 0, getLength(getChildNodes(this)) - 1
attrchild => item(getChildNodes(this), j)
if (getNodeType(attrchild)==TEXT_NODE) then
tmp => attrvalue
allocate(attrvalue(size(tmp)+getLength(attrchild)))
attrvalue(:size(tmp)) = tmp
attrvalue(size(tmp)+1:) = vs_str(getData(attrChild))
deallocate(tmp)
elseif (getNodeType(attrchild)==ENTITY_REFERENCE_NODE) then
tmp => attrvalue
allocate(attrvalue(size(tmp)+len(getNodeName(attrchild))+2))
attrvalue(:size(tmp)) = tmp
attrvalue(size(tmp)+1:) = vs_str("&"//getData(attrChild)//";")
deallocate(tmp)
else
if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then
call throw_exception(FoX_INTERNAL_ERROR, "iter_dmp_xml", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
enddo
call xml_AddAttribute(xf, getName(this), str_vs(attrvalue))
deallocate(attrvalue)
endif
doneChildren = .true.
case (TEXT_NODE)
call xml_AddCharacters(xf, getData(this))
case (CDATA_SECTION_NODE)
if (getParameter(getDomConfig(doc), "canonical-form")) then
call xml_AddCharacters(xf, getData(this))
else
call xml_AddCharacters(xf, getData(this), parsed = .false.)
endif
case (ENTITY_REFERENCE_NODE)
if (.not.getParameter(getDomConfig(doc), "canonical-form")) then
call xml_AddEntityReference(xf, getNodeName(this))
doneChildren = .true.
endif
case (PROCESSING_INSTRUCTION_NODE)
call xml_AddXMLPI(xf, getTarget(this), getData(this))
case (COMMENT_NODE)
if (.not.getParameter(getDomConfig(doc), "comments")) then
call xml_AddComment(xf, getData(this))
endif
case (DOCUMENT_TYPE_NODE)
if (.not.getParameter(getDomConfig(doc), "canonical-form")) then
call xml_AddDOCTYPE(xf, getName(this))
nnm => getNotations(this)
do j = 0, getLength(nnm)-1
np => item(nnm, j)
if (getSystemId(np)=="") then
call xml_AddNotation(xf, getNodeName(np), public=getPublicId(np))
elseif (getPublicId(np)=="") then
call xml_AddNotation(xf, getNodeName(np), system=getSystemId(np))
else
call xml_AddNotation(xf, getNodeName(np), system=getSystemId(np), &
public=getPublicId(np))
endif
enddo
nnm => getEntities(this)
do j = 0, getLength(nnm)-1
np => item(nnm, j)
if (getSystemId(np)=="") then
call xml_AddInternalEntity(xf, getNodeName(np), getStringValue(np))
elseif (getPublicId(np)=="".and.getNotationName(np)=="") then
call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np))
elseif (getNotationName(np)=="") then
call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), &
public=getPublicId(np))
elseif (getPublicId(np)=="") then
call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), &
notation=getNotationName(np))
else
call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), &
public=getPublicId(np), notation=getNotationName(np))
endif
enddo
do j = 1, size(xds%element_list%list)
elem => xds%element_list%list(j)
if (associated(elem%model)) &
call xml_AddElementToDTD(xf, str_vs(elem%name), str_vs(elem%model))
! Because we may have some undeclared but referenced elements
do k = 1, get_attlist_size(elem)
att_decl => get_attribute_declaration(elem, k)
call xml_AddAttlistToDTD(xf, str_vs(elem%name), &
express_attribute_declaration(att_decl))
enddo
enddo
endif
end select
else
if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then
doneAttributes = .true.
else
if (getNodeType(this)==ELEMENT_NODE) then
call xml_EndElement(xf, getTagName(this))
endif
endif
endif
if (.not.doneChildren) then
if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then
if (getLength(getAttributes(this))>0) then
this => item(getAttributes(this), 0)
else
doneAttributes = .true.
endif
elseif (hasChildNodes(this)) then
this => getFirstChild(this)
doneChildren = .false.
doneAttributes = .false.
else
doneChildren = .true.
doneAttributes = .false.
endif
else ! if doneChildren
if (associated(this, treeroot)) exit
if (getNodeType(this)==ATTRIBUTE_NODE) then
if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then
i_tree= i_tree+ 1
this => item(getAttributes(getOwnerElement(this)), i_tree)
doneChildren = .false.
else
i_tree= 0
this => getOwnerElement(this)
doneAttributes = .true.
doneChildren = .false.
endif
elseif (associated(getNextSibling(this))) then
this => getNextSibling(this)
doneChildren = .false.
doneAttributes = .false.
else
this => getParentNode(this)
endif
endif
enddo
end subroutine iter_dmp_xml
end module m_dom_utils

48
src/xml/fsys/Makefile Normal file
View file

@ -0,0 +1,48 @@
source = $(wildcard *.F90)
objects = $(source:.F90=.o)
#===============================================================================
# Compiler Options
#===============================================================================
# Ignore unusd variables
ifeq ($(MACHINE),bluegene)
override F90 = xlf2003
endif
ifeq ($(F90),ifort)
override F90FLAGS += -warn nounused
endif
#===============================================================================
# Targets
#===============================================================================
all: $(objects)
mv *.mod ../include
mv *.o ../lib
clean:
@rm -f *.o *.mod
neat:
@rm -f *.o *.mod
#===============================================================================
# Rules
#===============================================================================
.SUFFIXES: .F90 .o
.PHONY: clean neat
%.o: %.F90
$(F90) $(F90FLAGS) -I../include -c $<
#===============================================================================
# Dependencies
#===============================================================================
fox_m_fsys_format.o: fox_m_fsys_realtypes.o fox_m_fsys_abort_flush.o
fox_m_fsys_parse_input.o: fox_m_fsys_realtypes.o
fox_m_fsys_count_parse_input.o: fox_m_fsys_realtypes.o
fox_m_fsys_string_list.o: fox_m_fsys_array_str.o

124
src/xml/fsys/fox_m_fsys_abort_flush.F90 Normal file
View file

@ -0,0 +1,124 @@
module fox_m_fsys_abort_flush
implicit none
public :: pxfflush
public :: pxfabort
public :: pure_pxfabort
! status values to write to stderr on termination
integer, public, parameter :: STDERR_SUCCESS_STATUS = 0
integer, public, parameter :: STDERR_FAILURE_STATUS = 1
! pxf.F90 - assortment of Fortran wrappers to various
! unix-y system calls.
!
! Copyright Toby White, <tow21@cam.ac.uk> 2005
! The name pxf is intended to be reminiscent of the POSIX
! fortran interfaces defined by IEEE 1003.9-1992, although
! in fact I don't think that either flush or abort were
! covered by said standard.
! Of the preprocessor defines used here, only xlC is
! automatically defined by the appropriate compiler. All
! others must be defined by some other mechanism - I
! recommend autoconf.
! FLUSH: flushes buffered output on a given unit. Not guaranteed
! to do anything at all (particularly under MPI when even FLUSHed
! buffers may not make it to the host cpu after an abort.
!
! IMPLEMENTATION: in F2003, this is a native operation called by the
! FLUSH statement.
! In almost every compiler, there is a FLUSH intrinsic subroutine
! available which takes one argument, the unit to be flushed.
! (some will flush all open units when no argument is given - this
! facility is not used here.
! NAG complicates matters by having to USE a module to get at flush.
!
! If no FLUSH is available, the subroutine is a no-op.
CONTAINS
subroutine pxfflush(unit)
#ifdef __NAG__
use f90_unix_io, only : flush
#endif
integer, intent(in) :: unit
integer :: i
#if defined(F2003)
flush(unit)
#elif defined(xlC)
call flush_(unit)
#elif defined (FC_HAVE_FLUSH)
call flush(unit)
#else
i= unit ! pacify compiler
continue
#endif
end subroutine pxfflush
! ABORT: terminates program execution in such a way that a backtrace
! is produced. (see abort() in the C Standard Library). No arguments.
!
! IMPLEMENTATION: In F2003, the C interoperability features mean that
! the abort in stdlib.h is available to be linked against.
! In several other compilers an ABORT intrinsic subroutine is available.
! Again, NAG complicates matters by needing to USE a module.
!
! In the case where no native ABORT can be found, we emulate one
! by dereferencing a null pointer. This has reliably produced coredumps
! on every platform I've tried it with. Just in case it doesn't (it need
! not even stop execution) a stop is given to force termination.
subroutine pxfabort()
#ifdef __NAG__
use f90_unix_proc, only : abort
#endif
#ifdef F2003
interface
subroutine abort() bind(c)
end subroutine abort
end interface
#define FC_HAVE_ABORT
#endif
#ifndef FC_HAVE_ABORT
integer, pointer :: i
#endif
call pxfflush(6)
#ifdef FC_HAVE_ABORT
#ifdef FC_ABORT_UNDERSCORE
call abort_()
#elif defined(FC_ABORT_ARG)
call abort("")
#else
call abort()
#endif
#else
i=>null()
Print*,i
#endif
stop STDERR_FAILURE_STATUS
end subroutine pxfabort
! For where we need a pxfabort that is pure, we have
! this below. I am less sure of its working everywhe
! also it must be used as a function not a subroutine
! (otherwise it would be optimized away as side-effect
! free
pure function pure_pxfabort() result (crash)
integer :: crash
integer, pointer :: i
nullify(i)
crash = i
end function pure_pxfabort
end module fox_m_fsys_abort_flush

94
src/xml/fsys/fox_m_fsys_array_str.F90 Normal file
View file

@ -0,0 +1,94 @@
module fox_m_fsys_array_str
#ifndef DUMMYLIB
implicit none
private
interface destroy
module procedure destroy_vs
end interface
interface concat
module procedure vs_s_concat
end interface
interface alloc
module procedure vs_str_alloc
end interface
public :: str_vs
public :: vs_str
public :: vs_str_alloc
public :: vs_vs_alloc
public :: concat
public :: alloc
public :: destroy
contains
pure function str_vs(vs) result(s)
character, dimension(:), intent(in) :: vs
character(len=size(vs)) :: s
integer :: i
! Note that we could use s = transfer(vs, s)
! here and (in principle) this could be an O(1)
! operation. However, this leakes memory on all
! recent gfortrans and crashes on some versions of
! PGF90. So the loop would need to be included with
! an #ifdef PGF90. In any case, the looping version
! seems to be quickers (probably due to the character
! copying being vectorized in the loop). See:
! http://gcc.gnu.org/bugzilla/show_bug.cgi?id=51175
do i = 1, size(vs)
s(i:i) = vs(i)
enddo
end function str_vs
pure function vs_str(s) result(vs)
character(len=*), intent(in) :: s
character, dimension(len(s)) :: vs
vs = transfer(s, vs)
end function vs_str
pure function vs_str_alloc(s) result(vs)
character(len=*), intent(in) :: s
character, dimension(:), pointer :: vs
allocate(vs(len(s)))
vs = vs_str(s)
end function vs_str_alloc
pure function vs_vs_alloc(s) result(vs)
character, dimension(:), pointer :: s
character, dimension(:), pointer :: vs
if (associated(s)) then
allocate(vs(size(s)))
vs = s
else
vs => null()
endif
end function vs_vs_alloc
pure function vs_s_concat(vs, s) result(vs2)
character, dimension(:), intent(in) :: vs
character(len=*), intent(in) :: s
character, dimension(:), pointer :: vs2
allocate(vs2(size(vs)+len(s)))
vs2(:size(vs)) = vs
vs2(size(vs)+1:) = vs_str(s)
end function vs_s_concat
subroutine destroy_vs(vs)
character, dimension(:), pointer :: vs
deallocate(vs)
end subroutine destroy_vs
#endif
end module fox_m_fsys_array_str

561
src/xml/fsys/fox_m_fsys_count_parse_input.F90 Normal file
View file

@ -0,0 +1,561 @@
module fox_m_fsys_count_parse_input
use fox_m_fsys_realtypes, only: sp, dp
implicit none
private
character(len=1), parameter :: SPACE = achar(32)
character(len=1), parameter :: NEWLINE = achar(10)
character(len=1), parameter :: CARRIAGE_RETURN = achar(13)
character(len=1), parameter :: TAB = achar(9)
character(len=*), parameter :: whitespace = &
SPACE//NEWLINE//CARRIAGE_RETURN//TAB
interface countrts
module procedure countstring
module procedure countlogical
module procedure countinteger
module procedure countrealsp
module procedure countrealdp
module procedure countcomplexsp
module procedure countcomplexdp
end interface
public :: countrts
contains
pure function countstring(s, datatype, separator, csv) result(num)
character(len=*), intent(in) :: s
character(len=*), intent(in) :: datatype
character, intent(in), optional :: separator
logical, intent(in), optional :: csv
integer :: num
#ifndef DUMMYLIB
logical :: bracketed
integer :: i, j, ij, k, s_i, err, ios, length
real :: r, c
character(len=len(s)) :: s2
logical :: csv_, eof
integer :: m
csv_ = .false.
if (present(csv)) then
if (csv) csv_ = csv
endif
s_i = 1
err = 0
eof = .false.
ij = 0
loop: do
if (csv_) then
if (s_i>len(s)) then
ij = ij + 1
exit loop
endif
k = verify(s(s_i:), achar(10)//achar(13))
if (k==0) then
ij = ij + 1
exit loop
elseif (s(s_i+k-1:s_i+k-1)=="""") then
! we have a quote-delimited string;
s_i = s_i + k
s2 = ""
quote: do
k = index(s(s_i:), """")
if (k==0) then
err = 2
exit loop
endif
k = s_i + k - 1
s2(m:) = s(s_i:k)
m = m + (k-s_i+1)
k = k + 2
if (k>len(s)) then
err = 2
exit loop
endif
if (s(k:k)/="""") exit
s_i = k + 1
if (s_i > len(s)) then
err = 2
exit loop
endif
m = m + 1
s2(m:m) = """"
enddo quote
k = scan(s(s_i:), whitespace)
if (k==0) then
err = 2
exit loop
endif
else
s_i = s_i + k - 1
k = scan(s(s_i:), achar(10)//achar(13)//",")
if (k==0) then
eof = .true.
k = len(s)
else
k = s_i + k - 2
endif
if (index(s(s_i:k), """")/=0) then
err = 2
exit loop
endif
endif
ij = ij + 1
s_i = k + 2
if (eof) exit loop
else
if (present(separator)) then
k = index(s(s_i:), separator)
else
k = verify(s(s_i:), whitespace)
if (k==0) exit loop
s_i = s_i + k - 1
k = scan(s(s_i:), whitespace)
endif
if (k==0) then
k = len(s)
else
k = s_i + k - 2
endif
ij = ij + 1
s_i = k + 2
if (s_i>len(s)) exit loop
endif
end do loop
num = ij
if (err/=0) num=0
#else
num = 0
#endif
end function countstring
pure function countlogical(s, datatype) result(num)
character(len=*), intent(in) :: s
logical, intent(in) :: datatype
logical :: dummy_data
integer :: num
#ifndef DUMMYLIB
logical :: bracketed
integer :: i, j, ij, k, s_i, err, ios, length
real :: r, c
s_i = 1
err = 0
ij = 0
length = 1
loop: do
k = verify(s(s_i:), whitespace)
if (k==0) exit loop
s_i = s_i + k - 1
if (s(s_i:s_i)==",") then
if (s_i+1>len(s)) then
err = 2
exit loop
endif
k = verify(s(s_i+1:), whitespace)
s_i = s_i + k - 1
endif
k = scan(s(s_i:), whitespace//",")
if (k==0) then
k = len(s)
else
k = s_i + k - 2
endif
if (.not.((s(s_i:k)=="true".or.s(s_i:k)=="1").or. &
(s(s_i:k)=="false".or.s(s_i:k)=="0"))) then
err = 2
exit loop
endif
ij = ij + 1
s_i = k + 2
if (ij<length.and.s_i>len(s)) exit loop
end do loop
num = ij
if (verify(s(s_i:), whitespace)/=0) num = 0
if (err/=0) num=0
#else
num = 0
#endif
end function countlogical
pure function countinteger(s, datatype) result(num)
character(len=*), intent(in) :: s
integer, intent(in) :: datatype
integer :: dummy_data
integer num
#ifndef DUMMYLIB
logical :: bracketed
integer :: i, j, ij, k, s_i, err, ios, length
real :: r, c
s_i = 1
err = 0
ij = 0
length = 1
loop: do
k = verify(s(s_i:), whitespace)
if (k==0) exit loop
s_i = s_i + k - 1
if (s(s_i:s_i)==",") then
if (s_i+1>len(s)) then
err = 2
exit loop
endif
k = verify(s(s_i+1:), whitespace)
s_i = s_i + k - 1
endif
k = scan(s(s_i:), whitespace//",")
if (k==0) then
k = len(s)
else
k = s_i + k - 2
endif
read(s(s_i:k), *, iostat=ios) dummy_data
if (ios/=0) then
err = 2
exit loop
endif
ij = ij + 1
s_i = k + 2
if (ij<length.and.s_i>len(s)) exit loop
end do loop
num = ij
if (verify(s(s_i:), whitespace)/=0) num = 0
if (err/=0) num=0
#else
num = 0
#endif
end function countinteger
pure function countrealsp(s, datatype) result(num)
character(len=*), intent(in) :: s
real(sp), intent(in) :: datatype
real(sp) :: dummy_data
integer :: num
#ifndef DUMMYLIB
logical :: bracketed
integer :: i, j, ij, k, s_i, err, ios, length
real :: r, c
s_i = 1
err = 0
ij = 0
length = 1
loop: do
k = verify(s(s_i:), whitespace)
if (k==0) exit loop
s_i = s_i + k - 1
if (s(s_i:s_i)==",") then
if (s_i+1>len(s)) then
err = 2
exit loop
endif
k = verify(s(s_i+1:), whitespace)
s_i = s_i + k - 1
endif
k = scan(s(s_i:), whitespace//",")
if (k==0) then
k = len(s)
else
k = s_i + k - 2
endif
read(s(s_i:k), *, iostat=ios) dummy_data
if (ios/=0) then
err = 2
exit loop
endif
ij = ij + 1
s_i = k + 2
if (ij<length.and.s_i>len(s)) exit loop
end do loop
num = ij
if (verify(s(s_i:), whitespace)/=0) num = 0
if (err/=0) num=0
#else
num = 0
#endif
end function countrealsp
pure function countrealdp(s, datatype) result(num)
character(len=*), intent(in) :: s
real(dp), intent(in) :: datatype
real(dp) :: dummy_data
integer :: num
#ifndef DUMMYLIB
logical :: bracketed
integer :: i, j, ij, k, s_i, err, ios, length
real :: r, c
s_i = 1
err = 0
ij = 0
length = 1
loop: do
k = verify(s(s_i:), whitespace)
if (k==0) exit loop
s_i = s_i + k - 1
if (s(s_i:s_i)==",") then
if (s_i+1>len(s)) then
err = 2
exit loop
endif
k = verify(s(s_i+1:), whitespace)
s_i = s_i + k - 1
endif
k = scan(s(s_i:), whitespace//",")
if (k==0) then
k = len(s)
else
k = s_i + k - 2
endif
read(s(s_i:k), *, iostat=ios) dummy_data
if (ios/=0) then
err = 2
exit loop
endif
ij = ij + 1
s_i = k + 2
if (ij<length.and.s_i>len(s)) exit loop
end do loop
num = ij
if (verify(s(s_i:), whitespace)/=0) num = 0
if (err/=0) num=0
#else
num = 0
#endif
end function countrealdp
pure function countcomplexsp(s, datatype) result(num)
character(len=*), intent(in) :: s
complex(sp), intent(in) :: datatype
complex(sp) :: dummy_data
integer :: num
#ifndef DUMMYLIB
logical :: bracketed
integer :: i, j, ij, k, s_i, err, ios, length
real :: r, c
s_i = 1
err = 0
ij = 0
length = 1
loop: do
bracketed = .false.
k = verify(s(s_i:), whitespace)
if (k==0) exit loop
s_i = s_i + k - 1
select case (s(s_i:s_i))
case ("(")
bracketed = .true.
k = verify(s(s_i:), whitespace)
if (k==0) then
err = 2
exit loop
endif
s_i = s_i + k
case (",")
k = verify(s(s_i:), whitespace)
if (k==0) then
err = 2
exit loop
endif
s_i = s_i + k - 1
case ("+", "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
continue
case default
err = 2
exit loop
end select
if (bracketed) then
k = index(s(s_i:), ")+i(")
else
k = scan(s(s_i:), whitespace//",")
endif
if (k==0) then
err = 2
exit loop
endif
k = s_i + k - 2
read(s(s_i:k), *, iostat=ios) r
if (ios/=0) then
err = 2
exit loop
endif
if (bracketed) then
s_i = k + 5
if (s_i>len(s)) then
err = 2
exit loop
endif
else
s_i = k + 2
endif
if (bracketed) then
k = index(s(s_i:), ")")
if (k==0) then
err = 2
exit loop
endif
k = s_i + k - 2
else
k = scan(s(s_i:), whitespace//",")
if (k==0) then
k = len(s)
else
k = s_i + k - 2
endif
endif
read(s(s_i:k), *, iostat=ios) c
if (ios/=0) then
err = 2
exit loop
endif
ij = ij + 1
s_i = k + 2
if (ij<length.and.s_i>len(s)) exit loop
end do loop
num = ij
if (verify(s(s_i:), whitespace)/=0) num = 0
if (err/=0) num=0
#else
num = 0
#endif
end function countcomplexsp
pure function countcomplexdp(s, datatype) result(num)
character(len=*), intent(in) :: s
complex(dp), intent(in) :: datatype
complex(dp) :: dummy_data
integer :: num
#ifndef DUMMYLIB
logical :: bracketed
integer :: i, j, ij, k, s_i, err, ios, length
real :: r, c
s_i = 1
err = 0
ij = 0
length = 1
loop: do
bracketed = .false.
k = verify(s(s_i:), whitespace)
if (k==0) exit loop
s_i = s_i + k - 1
select case (s(s_i:s_i))
case ("(")
bracketed = .true.
k = verify(s(s_i:), whitespace)
if (k==0) then
err = 2
exit loop
endif
s_i = s_i + k
case (",")
k = verify(s(s_i:), whitespace)
if (k==0) then
err = 2
exit loop
endif
s_i = s_i + k - 1
case ("+", "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
continue
case default
err = 2
exit loop
end select
if (bracketed) then
k = index(s(s_i:), ")+i(")
else
k = scan(s(s_i:), whitespace//",")
endif
if (k==0) then
err = 2
exit loop
endif
k = s_i + k - 2
read(s(s_i:k), *, iostat=ios) r
if (ios/=0) then
err = 2
exit loop
endif
if (bracketed) then
s_i = k + 5
if (s_i>len(s)) then
err = 2
exit loop
endif
else
s_i = k + 2
endif
if (bracketed) then
k = index(s(s_i:), ")")
if (k==0) then
err = 2
exit loop
endif
k = s_i + k - 2
else
k = scan(s(s_i:), whitespace//",")
if (k==0) then
k = len(s)
else
k = s_i + k - 2
endif
endif
read(s(s_i:k), *, iostat=ios) c
if (ios/=0) then
err = 2
exit loop
endif
ij = ij + 1
s_i = k + 2
if (ij<length.and.s_i>len(s)) exit loop
end do loop
num = ij
if (verify(s(s_i:), whitespace)/=0) num = 0
if (err/=0) num=0
#else
num = 0
#endif
end function countcomplexdp
end module fox_m_fsys_count_parse_input

2250
src/xml/fsys/fox_m_fsys_format.F90 Normal file
View file

File diff suppressed because it is too large Load diff

2281
src/xml/fsys/fox_m_fsys_parse_input.F90 Normal file
View file

File diff suppressed because it is too large Load diff

12
src/xml/fsys/fox_m_fsys_realtypes.F90 Normal file
View file

@ -0,0 +1,12 @@
module fox_m_fsys_realtypes
implicit none
private
integer, parameter :: sp = selected_real_kind(6,30)
integer, parameter :: dp = selected_real_kind(14,100)
public :: sp
public :: dp
end module fox_m_fsys_realtypes

35
src/xml/fsys/fox_m_fsys_string.F90 Normal file
View file

@ -0,0 +1,35 @@
module fox_m_fsys_string
#ifndef DUMMYLIB
! Assorted generally useful string manipulation functions
implicit none
private
character(len=26), parameter :: lowerAlphabet = &
"abcdefghijklmnopqrstuvwxyz"
character(len=26), parameter :: UPPERAlphabet = &
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
public :: toLower
contains
function toLower(s_in) result(s)
character(len=*), intent(in) :: s_in
character(len=len(s_in)) :: s
integer :: i, n
do i = 1, len(s)
n = index(UPPERAlphabet, s_in(i:i))
if (n>0) then
s(i:i) = lowerAlphabet(n:n)
else
s(i:i) = s_in(i:i)
endif
enddo
end function toLower
#endif
end module fox_m_fsys_string

191
src/xml/fsys/fox_m_fsys_string_list.F90 Normal file
View file

@ -0,0 +1,191 @@
module fox_m_fsys_string_list
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc
implicit none
private
type string_t
character, pointer :: s(:) => null()
end type string_t
type string_list
type(string_t), pointer :: list(:) => null()
end type string_list
public :: string_t
public :: string_list
public :: init_string_list
public :: destroy_string_list
public :: add_string
public :: remove_last_string
public :: get_last_string
public :: tokenize_to_string_list
public :: tokenize_and_add_strings
public :: registered_string
interface destroy
module procedure destroy_string_list
end interface
public :: destroy
contains
subroutine init_string_list(s_list)
type(string_list), intent(inout) :: s_list
allocate(s_list%list(0))
end subroutine init_string_list
subroutine destroy_string_list(s_list)
type(string_list), intent(inout) :: s_list
integer :: i
if (associated(s_list%list)) then
do i = 1, ubound(s_list%list, 1)
deallocate(s_list%list(i)%s)
enddo
deallocate(s_list%list)
endif
end subroutine destroy_string_list
subroutine add_string(s_list, s)
type(string_list), intent(inout) :: s_list
character(len=*), intent(in) :: s
integer :: i
type(string_t), pointer :: temp(:)
temp => s_list%list
allocate(s_list%list(size(temp)+1))
do i = 1, size(temp)
s_list%list(i)%s => temp(i)%s
enddo
deallocate(temp)
s_list%list(i)%s => vs_str_alloc(s)
end subroutine add_string
subroutine remove_last_string(s_list)
type(string_list), intent(inout) :: s_list
integer :: i
type(string_t), pointer :: temp(:)
temp => s_list%list
allocate(s_list%list(size(temp)-1))
do i = 1, size(temp)-1
s_list%list(i)%s => temp(i)%s
enddo
deallocate(temp)
end subroutine remove_last_string
function get_last_string(s_list) result(s)
type(string_list), intent(in) :: s_list
character(len=size(s_list%list(size(s_list%list))%s)) :: s
s = str_vs(s_list%list(size(s_list%list))%s)
end function get_last_string
function tokenize_to_string_list(s) result(s_list)
character(len=*), intent(in) :: s
type(string_list) :: s_list
! tokenize a whitespace-separated list of strings
! and place results in a string list
character(len=*), parameter :: &
WHITESPACE = achar(9)//achar(10)//achar(13)//achar(32)
integer :: i, j
call init_string_list(s_list)
i = verify(s, WHITESPACE)
if (i==0) return
j = scan(s(i:), WHITESPACE)
if (j==0) then
j = len(s)
else
j = i + j - 2
endif
do
call add_string(s_list, s(i:j))
i = j + 1
j = verify(s(i:), WHITESPACE)
if (j==0) exit
i = i + j - 1
j = scan(s(i:), WHITESPACE)
if (j==0) then
j = len(s)
else
j = i + j - 2
endif
enddo
end function tokenize_to_string_list
function registered_string(s_list, s) result(p)
type(string_list), intent(in) :: s_list
character(len=*), intent(in) :: s
logical :: p
integer :: i
p = .false.
do i = 1, size(s_list%list)
if (str_vs(s_list%list(i)%s)//"x"==s//"x") then
p = .true.
exit
endif
enddo
end function registered_string
subroutine tokenize_and_add_strings(s_list, s, uniquify)
type(string_list), intent(inout) :: s_list
character(len=*), intent(in) :: s
logical, intent(in), optional :: uniquify
! tokenize a whitespace-separated list of strings
! and place results in the given string list
character(len=*), parameter :: &
WHITESPACE = achar(9)//achar(10)//achar(13)//achar(32)
integer :: i, j
logical :: uniquify_
if (present(uniquify)) then
uniquify_ = uniquify
else
uniquify_ = .false.
endif
i = verify(s, WHITESPACE)
if (i==0) return
j = scan(s(i:), WHITESPACE)
if (j==0) then
j = len(s)
else
j = i + j - 2
endif
do
if (uniquify_.and..not.registered_string(s_list, s(i:j))) &
call add_string(s_list, s(i:j))
i = j + 1
j = verify(s(i:), WHITESPACE)
if (j==0) exit
i = i + j - 1
j = scan(s(i:), WHITESPACE)
if (j==0) then
j = len(s)
else
j = i + j - 2
endif
enddo
end subroutine tokenize_and_add_strings
#endif
end module fox_m_fsys_string_list

254
src/xml/fsys/fox_m_fsys_varstr.F90 Normal file
View file

@ -0,0 +1,254 @@
module fox_m_fsys_varstr
implicit none
private
public :: varstr
public :: init_varstr
public :: destroy_varstr
public :: varstr_len
public :: is_varstr_empty
public :: set_varstr_empty
public :: is_varstr_null
public :: set_varstr_null
public :: vs_varstr_alloc
public :: move_varstr_vs
public :: move_varstr_varstr
public :: str_varstr
public :: append_varstr
public :: varstr_str
public :: varstr_vs
public :: equal_varstr_str
public :: equal_varstr_varstr
! Allocation step in which the data within varstr will be allocated
integer, parameter :: VARSTR_INIT_SIZE=1024
integer, parameter :: VARSTR_ALLOC_SIZE=1024
! Variable size string type.
! It is used for token field, so that it can be grown
! by one character at a time without incurring constant
! penalty on allocating/deallocating vs data.
! See functions and subroutines at the end of this module.
type varstr
private
character, dimension(:), pointer :: data
integer :: length
end type varstr
contains
! Initialise varstr type. The string is initialised as null (i.e. invalid)
subroutine init_varstr(vstr)
type(varstr), intent(inout) :: vstr
allocate(vstr%data(VARSTR_INIT_SIZE))
vstr%length = -1
end subroutine init_varstr
! Clean up memory (leaves varstr null, and drops the data field)
subroutine destroy_varstr(vstr)
type(varstr), intent(inout) :: vstr
if (associated(vstr%data)) deallocate(vstr%data)
call set_varstr_null(vstr)
end subroutine destroy_varstr
! Return real length of varstr
function varstr_len(vstr) result(l)
type(varstr), intent(in) :: vstr
integer :: l
if (vstr%length<0) print *, "WARNING: asking for length of null varstr"
l = vstr%length
end function varstr_len
! Make sure that varstr is at least size-n.
! The data will be kept (copied) if keep is true (default)
! This can be called on a null varstr, but should noty be called on
! one which was destroyed.
subroutine ensure_varstr_size(vstr,n,keep)
type(varstr), intent(inout) :: vstr
integer, intent(in) :: n
logical, optional, intent(in) :: keep
character, pointer, dimension(:) :: new_data
integer :: new_size, old_size
logical :: keep_flag
if (present(keep)) then
keep_flag = keep
else
keep_flag = .true.
end if
old_size = size(vstr%data)
if (n <= old_size ) return
new_size = old_size + ((n-old_size)/VARSTR_ALLOC_SIZE+1) * VARSTR_ALLOC_SIZE
allocate(new_data(new_size))
if (keep_flag) new_data(1:old_size) = vstr%data(1:old_size)
deallocate( vstr%data )
vstr%data => new_data
end subroutine ensure_varstr_size
! Returns whether varstr is empty: ""
function is_varstr_empty(vstr)
type(varstr), intent(in) :: vstr
logical is_varstr_empty
is_varstr_empty = (vstr%length == 0)
end function is_varstr_empty
! Set vstr to empty string
subroutine set_varstr_empty(vstr)
type(varstr), intent(inout) :: vstr
vstr%length = 0
end subroutine set_varstr_empty
! Returns whether varstr is null (i.e. invalid)
function is_varstr_null(vstr)
type(varstr), intent(in) :: vstr
logical is_varstr_null
is_varstr_null = (vstr%length < 0)
end function is_varstr_null
! Set vstr to null
subroutine set_varstr_null(vstr)
type(varstr), intent(inout) :: vstr
vstr%length = -1
end subroutine set_varstr_null
! Convert varstr to newly allocated array of characters
function vs_varstr_alloc(vstr) result(vs)
type(varstr) :: vstr
character, dimension(:), pointer :: vs
if (is_varstr_null(vstr)) then
print *, "WARNING: Converting null varstr to string... making it empty first"
call set_varstr_empty(vstr)
end if
allocate(vs(vstr%length))
vs = vstr%data(1:vstr%length)
end function vs_varstr_alloc
! This call moves data from varstr to vs (i.e. vs is overwritten and vstr is made null)
subroutine move_varstr_vs(vstr,vs)
type(varstr), intent(inout) :: vstr
character, dimension(:), pointer, intent(inout) :: vs
if (associated(vs)) deallocate(vs)
vs => vs_varstr_alloc(vstr)
call set_varstr_null(vstr)
end subroutine move_varstr_vs
! This call moves data from varstr to varstr (src becomes null)
subroutine move_varstr_varstr(src,dst)
type(varstr), intent(inout) :: src
type(varstr), intent(inout) :: dst
character, dimension(:), pointer :: tmpdata
tmpdata => dst%data
dst%data => src%data
src%data => tmpdata
dst%length = src%length
call set_varstr_null(src)
end subroutine move_varstr_varstr
! Convert varstr to string type
function str_varstr(vstr) result(s)
type(varstr), intent(in) :: vstr
character(len=vstr%length) :: s
integer :: i
if (is_varstr_null(vstr)) then
! Can we really end-up here? Or will it blow on allocation with len=-1 ?
print *, "WARNING: Trying to convert null varstr to str... returning empty string"
s = ""
end if
do i = 1, vstr%length
s(i:i) = vstr%data(i)
enddo
end function str_varstr
! Append string to varstr
subroutine append_varstr(vstr,str)
type(varstr), intent(inout) :: vstr
character(len=*), intent(in) :: str
character, dimension(:), pointer :: tmp
integer :: i
if (is_varstr_null(vstr)) then
print *, "WARNING: Trying to append to null varstr... making it empty first"
call set_varstr_empty(vstr)
end if
call ensure_varstr_size(vstr,vstr%length+len(str))
! Note: on a XML file with very large tokens, this loop
! is consistently faster than equivalent 'transfer' intrinsic
do i=1,len(str)
vstr%data(vstr%length+i) = str(i:i)
end do
vstr%length = vstr%length + len(str)
end subroutine append_varstr
! Convert string to varstr in place
subroutine varstr_str(vstr,str)
type(varstr), intent(inout) :: vstr
character(len=*), intent(in) :: str
integer :: i
call ensure_varstr_size(vstr,len(str),.false.)
do i=1,len(str)
vstr%data(i) = str(i:i)
end do
vstr%length = len(str)
end subroutine varstr_str
! Convert character array to varstr in place
subroutine varstr_vs(vstr,vs)
type(varstr), intent(inout) :: vstr
character, dimension(:), intent(in) :: vs
call ensure_varstr_size(vstr,size(vs),.false.)
vstr%length = size(vs)
vstr%data(1:size(vs)) = vs
end subroutine varstr_vs
! Compare varstr to str (true if equal)
function equal_varstr_str(vstr,str) result(r)
type(varstr), intent(in) :: vstr
character(len=*) :: str
logical :: r
integer :: i
r = .false.
if ( len(str) /= varstr_len(vstr) ) return
do i=1,len(str)
if ( str(i:i) /= vstr%data(i) ) return
end do
r = .true.
end function equal_varstr_str
! Compare varstr to varstr (true if equal)
function equal_varstr_varstr(vstr1,vstr2) result(r)
type(varstr), intent(in) :: vstr1, vstr2
logical :: r
integer :: i
r = .false.
if ( varstr_len(vstr1) /= varstr_len(vstr2) ) return
do i=1,varstr_len(vstr1)
if ( vstr1%data(i) /= vstr2%data(i) ) return
end do
r = .true.
end function equal_varstr_varstr
end module fox_m_fsys_varstr

17
src/xml/fsys/m_ieee.F90 Normal file
View file

@ -0,0 +1,17 @@
module m_ieee
implicit none
private
public :: generate_nan
contains
function generate_nan() result(nan)
real :: nan
real :: zero
zero = 0.0
nan = 0.0/zero
end function generate_nan
end module m_ieee

34
src/xml/sax/FoX_sax.F90 Normal file
View file

@ -0,0 +1,34 @@
module FoX_sax
use FoX_common
use m_sax_operate
implicit none
private
public :: open_xml_file
public :: open_xml_string
public :: close_xml_t
public :: parse
public :: stop_parser
public :: SAX_OPEN_ERROR
public :: xml_t
public :: dictionary_t
!SAX functions
public :: getIndex
public :: getLength
public :: getLocalName
public :: getQName
public :: getURI
public :: getValue
public :: getType
public :: isSpecified
public :: isDeclared
public :: setSpecified
public :: setDeclared
!For convenience
public :: hasKey
end module FoX_sax

50
src/xml/sax/Makefile Normal file
View file

@ -0,0 +1,50 @@
source = $(wildcard *.F90)
objects = $(source:.F90=.o)
#===============================================================================
# Compiler Options
#===============================================================================
# Ignore unusd variables
ifeq ($(MACHINE),bluegene)
override F90 = xlf2003
endif
ifeq ($(F90),ifort)
override F90FLAGS += -warn nounused
endif
#===============================================================================
# Targets
#===============================================================================
all: $(objects)
mv *.mod ../include
mv *.o ../lib
clean:
@rm -f *.o *.mod
neat:
@rm -f *.o *.mod
#===============================================================================
# Rules
#===============================================================================
.SUFFIXES: .F90 .o
.PHONY: clean neat
%.o: %.F90
$(F90) $(F90FLAGS) -c -I../include $<
#===============================================================================
# Dependencies
#===============================================================================
FoX_sax.o: m_sax_operate.o
m_sax_operate.o: m_sax_parser.o m_sax_reader.o m_sax_types.o
m_sax_parser.o: m_sax_reader.o m_sax_tokenizer.o m_sax_types.o
m_sax_reader.o: m_sax_xml_source.o
m_sax_tokenizer.o: m_sax_reader.o m_sax_types.o
m_sax_types.o: m_sax_reader.o

313
src/xml/sax/m_sax_operate.F90 Normal file
View file

@ -0,0 +1,313 @@
module m_sax_operate
#ifndef DUMMYLIB
use m_common_error, only: FoX_error, in_error
use FoX_common, only : str_vs
use m_sax_reader, only: open_file, close_file
use m_sax_parser, only: sax_parser_init, sax_parser_destroy, sax_parse
use m_sax_types, only: ST_STOP
#endif
use m_sax_types, only: xml_t
implicit none
private
integer, parameter :: SAX_OPEN_ERROR = 1001
public :: xml_t
public :: open_xml_file
public :: open_xml_string
public :: close_xml_t
public :: parse
public :: stop_parser
public :: SAX_OPEN_ERROR
contains
subroutine open_xml_file(xt, file, iostat, lun)
type(xml_t), intent(out) :: xt
character(len=*), intent(in) :: file
integer, intent(out), optional :: iostat
integer, intent(in), optional :: lun
#ifdef DUMMYLIB
if (present(iostat)) iostat = 0
#else
integer :: i
call open_file(xt%fb, file=trim(file), iostat=i, lun=lun, es=xt%fx%error_stack)
if (present(iostat)) then
if (in_error(xt%fx%error_stack)) i = SAX_OPEN_ERROR
iostat = i
if (i/=0) return
else
if (i/=0) &
call FoX_error("Error opening file in open_xml_file")
if (in_error(xt%fx%error_stack)) &
call FoX_error(str_vs(xt%fx%error_stack%stack(1)%msg))
endif
if (i==0) call sax_parser_init(xt%fx, xt%fb)
#endif
end subroutine open_xml_file
subroutine open_xml_string(xt, string)
type(xml_t), intent(out) :: xt
character(len=*), intent(in) :: string
#ifndef DUMMYLIB
integer :: iostat
call open_file(xt%fb, string=string, iostat=iostat, es=xt%fx%error_stack)
call sax_parser_init(xt%fx, xt%fb)
#endif
end subroutine open_xml_string
subroutine close_xml_t(xt)
type(xml_t), intent(inout) :: xt
#ifndef DUMMYLIB
call close_file(xt%fb)
call sax_parser_destroy(xt%fx)
#endif
end subroutine close_xml_t
subroutine parse(xt, &
characters_handler, &
endDocument_handler, &
endElement_handler, &
endPrefixMapping_handler, &
ignorableWhitespace_handler, &
processingInstruction_handler, &
! setDocumentLocator
skippedEntity_handler, &
startDocument_handler, &
startElement_handler, &
startPrefixMapping_handler, &
notationDecl_handler, &
unparsedEntityDecl_handler, &
error_handler, &
fatalError_handler, &
warning_handler, &
attributeDecl_handler, &
elementDecl_handler, &
externalEntityDecl_handler, &
internalEntityDecl_handler, &
comment_handler, &
endCdata_handler, &
endDTD_handler, &
endEntity_handler, &
startCdata_handler, &
startDTD_handler, &
startEntity_handler, &
! Features / properties
namespaces, &
namespace_prefixes, &
validate, &
xmlns_uris)
type(xml_t), intent(inout) :: xt
optional :: characters_handler
optional :: endDocument_handler
optional :: endElement_handler
optional :: endPrefixMapping_handler
optional :: ignorableWhitespace_handler
optional :: processingInstruction_handler
optional :: skippedEntity_handler
optional :: startElement_handler
optional :: startDocument_handler
optional :: startPrefixMapping_handler
optional :: notationDecl_handler
optional :: unparsedEntityDecl_handler
optional :: error_handler
optional :: fatalError_handler
optional :: warning_handler
optional :: attributeDecl_handler
optional :: elementDecl_handler
optional :: externalEntityDecl_handler
optional :: internalEntityDecl_handler
optional :: comment_handler
optional :: endCdata_handler
optional :: endEntity_handler
optional :: endDTD_handler
optional :: startCdata_handler
optional :: startDTD_handler
optional :: startEntity_handler
logical, intent(in), optional :: namespaces
logical, intent(in), optional :: namespace_prefixes
logical, intent(in), optional :: validate
logical, intent(in), optional :: xmlns_uris
interface
subroutine characters_handler(chunk)
character(len=*), intent(in) :: chunk
end subroutine characters_handler
subroutine endDocument_handler()
end subroutine endDocument_handler
subroutine endElement_handler(namespaceURI, localName, name)
character(len=*), intent(in) :: namespaceURI
character(len=*), intent(in) :: localName
character(len=*), intent(in) :: name
end subroutine endElement_handler
subroutine endPrefixMapping_handler(prefix)
character(len=*), intent(in) :: prefix
end subroutine endPrefixMapping_handler
subroutine ignorableWhitespace_handler(chars)
character(len=*), intent(in) :: chars
end subroutine ignorableWhitespace_handler
subroutine processingInstruction_handler(name, content)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: content
end subroutine processingInstruction_handler
subroutine skippedEntity_handler(name)
character(len=*), intent(in) :: name
end subroutine skippedEntity_handler
subroutine startDocument_handler()
end subroutine startDocument_handler
subroutine startElement_handler(namespaceURI, localName, name, attributes)
use FoX_common
character(len=*), intent(in) :: namespaceUri
character(len=*), intent(in) :: localName
character(len=*), intent(in) :: name
type(dictionary_t), intent(in) :: attributes
end subroutine startElement_handler
subroutine startPrefixMapping_handler(namespaceURI, prefix)
character(len=*), intent(in) :: namespaceURI
character(len=*), intent(in) :: prefix
end subroutine startPrefixMapping_handler
subroutine notationDecl_handler(name, publicId, systemId)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
end subroutine notationDecl_handler
subroutine unparsedEntityDecl_handler(name, publicId, systemId, notation)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
character(len=*), intent(in) :: notation
end subroutine unparsedEntityDecl_handler
subroutine error_handler(msg)
character(len=*), intent(in) :: msg
end subroutine error_handler
subroutine fatalError_handler(msg)
character(len=*), intent(in) :: msg
end subroutine fatalError_handler
subroutine warning_handler(msg)
character(len=*), intent(in) :: msg
end subroutine warning_handler
subroutine attributeDecl_handler(eName, aName, type, mode, value)
character(len=*), intent(in) :: eName
character(len=*), intent(in) :: aName
character(len=*), intent(in) :: type
character(len=*), intent(in), optional :: mode
character(len=*), intent(in), optional :: value
end subroutine attributeDecl_handler
subroutine elementDecl_handler(name, model)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: model
end subroutine elementDecl_handler
subroutine externalEntityDecl_handler(name, publicId, systemId)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
end subroutine externalEntityDecl_handler
subroutine internalEntityDecl_handler(name, value)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: value
end subroutine internalEntityDecl_handler
subroutine comment_handler(comment)
character(len=*), intent(in) :: comment
end subroutine comment_handler
subroutine endCdata_handler()
end subroutine endCdata_handler
subroutine endDTD_handler()
end subroutine endDTD_handler
subroutine endEntity_handler(name)
character(len=*), intent(in) :: name
end subroutine endEntity_handler
subroutine startCdata_handler()
end subroutine startCdata_handler
subroutine startDTD_handler(name, publicId, systemId)
character(len=*), intent(in) :: name
character(len=*), intent(in) :: publicId
character(len=*), intent(in) :: systemId
end subroutine startDTD_handler
subroutine startEntity_handler(name)
character(len=*), intent(in) :: name
end subroutine startEntity_handler
end interface
#ifndef DUMMYLIB
! FIXME check xt is initialized
call sax_parse(xt%fx, xt%fb, &
characters_handler, &
endDocument_handler, &
endElement_handler, &
endPrefixMapping_handler, &
ignorableWhitespace_handler, &
processingInstruction_handler, &
! setDocumentLocator
skippedEntity_handler, &
startDocument_handler, &
startElement_handler, &
startPrefixMapping_handler, &
notationDecl_handler, &
unparsedEntityDecl_handler, &
error_handler, &
fatalError_handler, &
warning_handler, &
attributeDecl_handler, &
elementDecl_handler, &
externalEntityDecl_handler, &
internalEntityDecl_handler, &
comment_handler, &
endCdata_handler, &
endDTD_handler, &
endEntity_handler, &
startCdata_handler, &
startDTD_handler, &
startEntity_handler, &
namespaces=namespaces, &
namespace_prefixes=namespace_prefixes, &
validate=validate, &
xmlns_uris=xmlns_uris)
#endif
end subroutine parse
subroutine stop_parser(xt)
! To be called from within a callback function;
! this will stop the parser.
type(xml_t), intent(inout) :: xt
#ifndef DUMMYLIB
xt%fx%state = ST_STOP
#endif
end subroutine stop_parser
end module m_sax_operate

3029
src/xml/sax/m_sax_parser.F90 Normal file
View file

File diff suppressed because it is too large Load diff

411
src/xml/sax/m_sax_reader.F90 Normal file
View file

@ -0,0 +1,411 @@
module m_sax_reader
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc
use fox_m_fsys_format, only: operator(//)
use m_common_charset, only: XML1_0
use m_common_error, only: error_stack, FoX_error, in_error, add_error
use m_common_io, only: setup_io, get_unit, io_err
use FoX_utils, only: URI, parseURI, copyURI, destroyURI, &
hasScheme, getScheme, getPath
use m_sax_xml_source, only: xml_source_t, &
get_char_from_file, push_file_chars, parse_declaration
implicit none
private
type file_buffer_t
!FIXME private
type(xml_source_t), pointer :: f(:) => null()
logical :: standalone = .false.
integer :: xml_version = XML1_0
end type file_buffer_t
public :: file_buffer_t
public :: line
public :: column
public :: add_error_position
public :: open_file
public :: close_file
public :: open_new_file
public :: push_chars
public :: get_character
public :: get_all_characters
public :: open_new_string
public :: pop_buffer_stack
public :: parse_xml_declaration
public :: parse_text_declaration
public :: reading_main_file
public :: reading_first_entity
contains
subroutine open_file(fb, iostat, file, lun, string, es)
type(file_buffer_t), intent(out) :: fb
character(len=*), intent(in), optional :: file
integer, intent(out) :: iostat
integer, intent(in), optional :: lun
character(len=*), intent(in), optional :: string
type(error_stack), intent(inout) :: es
type(URI), pointer :: fileURI
iostat = 0
call setup_io()
if (present(string)) then
if (present(file)) then
call FoX_error("Cannot specify both file and string input to open_xml")
elseif (present(lun)) then
call FoX_error("Cannot specify lun for string input to open_xml")
endif
fileURI => parseURI("")
call open_new_string(fb, string, "", baseURI=fileURI)
else
fileURI => parseURI(file)
if (.not.associated(fileURI)) then
call add_error(es, "Could not open file "//file//" - not a valid URI")
iostat=1
return
endif
call open_new_file(fb, fileURI, iostat, lun)
endif
call destroyURI(fileURI)
end subroutine open_file
subroutine open_new_file(fb, baseURI, iostat, lun, pe)
type(file_buffer_t), intent(inout) :: fb
integer, intent(out) :: iostat
type(URI), pointer :: baseURI
integer, intent(in), optional :: lun
logical, intent(in), optional :: pe
integer :: i
type(xml_source_t) :: f
type(xml_source_t), pointer :: temp(:)
logical :: pe_
if (present(pe)) then
pe_ = pe
else
pe_ = .false.
endif
if (hasScheme(baseURI)) then
if (getScheme(baseURI)/="file") then
iostat = io_err
return
endif
endif
call open_actual_file(f, getPath(baseURI), iostat, lun)
if (iostat==0) then
if (.not.associated(fb%f)) allocate(fb%f(0))
! First file
temp => fb%f
allocate(fb%f(size(temp)+1))
do i = 1, size(temp)
fb%f(i+1)%lun = temp(i)%lun
fb%f(i+1)%xml_version = temp(i)%xml_version
fb%f(i+1)%encoding => temp(i)%encoding
fb%f(i+1)%filename => temp(i)%filename
fb%f(i+1)%line = temp(i)%line
fb%f(i+1)%col = temp(i)%col
fb%f(i+1)%startChar = temp(i)%startChar
fb%f(i+1)%next_chars => temp(i)%next_chars
fb%f(i+1)%input_string => temp(i)%input_string
fb%f(i+1)%baseURI => temp(i)%baseURI
fb%f(i+1)%pe = temp(i)%pe
enddo
deallocate(temp)
fb%f(1)%lun = f%lun
fb%f(1)%filename => f%filename
if (pe_) then
fb%f(1)%next_chars => vs_str_alloc(" ")
else
fb%f(1)%next_chars => vs_str_alloc("")
endif
fb%f(1)%pe = pe_
fb%f(1)%baseURI => copyURI(baseURI)
endif
end subroutine open_new_file
subroutine open_actual_file(f, file, iostat, lun)
type(xml_source_t), intent(out) :: f
character(len=*), intent(in) :: file
integer, intent(out) :: iostat
integer, intent(in), optional :: lun
if (present(lun)) then
f%lun = lun
else
call get_unit(f%lun, iostat)
if (iostat/=0) return
endif
open(unit=f%lun, file=file, form="formatted", status="old", &
action="read", position="rewind", iostat=iostat)
if (iostat/=0) return
f%filename => vs_str_alloc(file)
end subroutine open_actual_file
subroutine close_file(fb)
type(file_buffer_t), intent(inout) :: fb
integer :: i
do i = 1, size(fb%f)
call close_actual_file(fb%f(i))
enddo
if (associated(fb%f)) deallocate(fb%f)
end subroutine close_file
subroutine close_actual_file(f)
type(xml_source_t), intent(inout) :: f
deallocate(f%filename)
if (f%lun>0) then
close(f%lun)
else
deallocate(f%input_string%s)
deallocate(f%input_string)
endif
if (associated(f%encoding)) deallocate(f%encoding)
f%line = 0
f%col = 0
deallocate(f%next_chars)
call destroyURI(f%baseURI)
end subroutine close_actual_file
subroutine open_new_string(fb, string, name, baseURI, pe)
type(file_buffer_t), intent(inout) :: fb
character(len=*), intent(in) :: string
character(len=*), intent(in) :: name
type(URI), pointer :: baseURI
logical, intent(in), optional :: pe
integer :: i
type(xml_source_t), pointer :: temp(:)
logical :: pe_
if (present(pe)) then
pe_ = pe
else
pe_ = .false.
endif
if (.not.associated(fb%f)) allocate(fb%f(0))
temp => fb%f
allocate(fb%f(size(temp)+1))
do i = 1, size(temp)
fb%f(i+1)%lun = temp(i)%lun
fb%f(i+1)%xml_version = temp(i)%xml_version
fb%f(i+1)%encoding => temp(i)%encoding
fb%f(i+1)%filename => temp(i)%filename
fb%f(i+1)%line = temp(i)%line
fb%f(i+1)%col = temp(i)%col
fb%f(i+1)%startChar = temp(i)%startChar
fb%f(i+1)%next_chars => temp(i)%next_chars
fb%f(i+1)%input_string => temp(i)%input_string
fb%f(i+1)%baseURI => temp(i)%baseURI
fb%f(i+1)%pe = temp(i)%pe
enddo
deallocate(temp)
allocate(fb%f(1)%input_string)
fb%f(1)%filename => vs_str_alloc(name)
fb%f(1)%input_string%s => vs_str_alloc(string)
if (pe_) then
fb%f(1)%next_chars => vs_str_alloc(" ")
else
fb%f(1)%next_chars => vs_str_alloc("")
endif
fb%f(1)%pe = pe_
if (associated(baseURI)) then
fb%f(1)%baseURI => copyURI(baseURI)
else
fb%f(1)%baseURI => copyURI(fb%f(2)%baseURI)
endif
end subroutine open_new_string
subroutine pop_buffer_stack(fb)
type(file_buffer_t), intent(inout) :: fb
integer :: i
type(xml_source_t), pointer :: temp(:)
call close_actual_file(fb%f(1))
temp => fb%f
allocate(fb%f(size(temp)-1))
do i = 1, size(temp)-1
fb%f(i)%lun = temp(i+1)%lun
fb%f(i)%xml_version = temp(i+1)%xml_version
fb%f(i)%encoding => temp(i+1)%encoding
fb%f(i)%filename => temp(i+1)%filename
fb%f(i)%line = temp(i+1)%line
fb%f(i)%col = temp(i+1)%col
fb%f(i)%startChar = temp(i+1)%startChar
fb%f(i)%next_chars => temp(i+1)%next_chars
fb%f(i)%input_string => temp(i+1)%input_string
fb%f(i)%baseURI => temp(i+1)%baseURI
fb%f(i)%pe = temp(i+1)%pe
enddo
deallocate(temp)
end subroutine pop_buffer_stack
subroutine push_chars(fb, s)
type(file_buffer_t), intent(inout) :: fb
character(len=*), intent(in) :: s
call push_file_chars(fb%f(1), s)
end subroutine push_chars
function get_character(fb, eof, es) result(string)
type(file_buffer_t), intent(inout) :: fb
logical, intent(out) :: eof
type(error_stack), intent(inout) :: es
character(len=1) :: string
type(xml_source_t), pointer :: f
character, pointer :: temp(:)
f => fb%f(1)
if (size(f%next_chars)>0) then
eof = .false.
string = f%next_chars(1)
if (size(f%next_chars)>1) then
temp => vs_str_alloc(str_vs(f%next_chars(2:)))
else
temp => vs_str_alloc("")
endif
deallocate(f%next_chars)
f%next_chars => temp
else
string = get_char_from_file(f, fb%xml_version, eof, es)
endif
end function get_character
function get_all_characters(fb, es) result(s)
type(file_buffer_t), intent(inout) :: fb
type(error_stack), intent(inout) :: es
character, pointer :: s(:)
logical :: eof
character :: c
character, pointer :: temp(:)
eof = .false.
s => vs_str_alloc("")
do while (.not.eof)
c = get_character(fb, eof, es)
if (eof.or.in_error(es)) return
temp => vs_str_alloc(str_vs(s)//c)
deallocate(s)
s => temp
enddo
end function get_all_characters
function line(fb) result(n)
type(file_buffer_t), intent(in) :: fb
integer :: n
n = fb%f(1)%line
end function line
function column(fb) result(n)
type(file_buffer_t), intent(in) :: fb
integer :: n
n = fb%f(1)%col
end function column
subroutine parse_xml_declaration(fb, xv, enc, sa, es)
type(file_buffer_t), intent(inout) :: fb
integer, intent(out) :: xv
character, pointer :: enc(:)
logical, intent(out) :: sa
type(error_stack), intent(inout) :: es
logical :: eof
call parse_declaration(fb%f(1), eof, es, sa)
if (eof.or.in_error(es)) then
call add_error(es, "Error parsing XML declaration")
else
fb%xml_version = fb%f(1)%xml_version
xv = fb%xml_version
enc => vs_vs_alloc(fb%f(1)%encoding)
endif
end subroutine parse_xml_declaration
subroutine parse_text_declaration(fb, es)
type(file_buffer_t), intent(inout) :: fb
type(error_stack), intent(inout) :: es
logical :: eof
integer :: xv
xv = fb%f(size(fb%f))%xml_version
call parse_declaration(fb%f(1), eof, es)
if (in_error(es)) then
call add_error(es, "Error parsing text declaration")
return
elseif (xv==XML1_0.and.fb%f(1)%xml_version/=XML1_0) then
call add_error(es, "XML 1.0 document cannot reference entities with higher version numbers")
return
endif
end subroutine parse_text_declaration
function reading_main_file(fb) result(p)
type(file_buffer_t), intent(in) :: fb
logical :: p
p = (size(fb%f)==1)
end function reading_main_file
function reading_first_entity(fb) result(p)
type(file_buffer_t), intent(in) :: fb
logical :: p
p = (size(fb%f)==2)
end function reading_first_entity
subroutine add_error_position(stack, fb)
type(error_stack), intent(inout) :: stack
type(file_buffer_t), intent(in) :: fb
call add_error(stack,"(Possibly near line="//line(fb)//" col="//column(fb)//")")
end subroutine add_error_position
#endif
end module m_sax_reader

1139
src/xml/sax/m_sax_tokenizer.F90 Normal file
View file

File diff suppressed because it is too large Load diff

163
src/xml/sax/m_sax_types.F90 Normal file
View file

@ -0,0 +1,163 @@
module m_sax_types
#ifndef DUMMYLIB
use m_common_attrs, only: dictionary_t
use m_common_elstack, only: elstack_t
use m_common_entities, only: entity_list
use m_common_error, only: error_stack
use m_common_namespaces, only: namespacedictionary
use m_common_notations, only: notation_list
use m_common_struct, only: xml_doc_state
use fox_m_fsys_varstr, only: varstr
use m_sax_reader, only: file_buffer_t
implicit none
! Context
integer, parameter :: CTXT_NULL = -1
integer, parameter :: CTXT_INIT = 0
integer, parameter :: CTXT_BEFORE_DTD = 1
integer, parameter :: CTXT_IN_DTD = 2
integer, parameter :: CTXT_IGNORE = 3
integer, parameter :: CTXT_BEFORE_CONTENT = 4
integer, parameter :: CTXT_IN_CONTENT = 5
integer, parameter :: CTXT_AFTER_CONTENT = 6
! State
integer, parameter :: ST_STOP = -1
integer, parameter :: ST_NULL = 0
integer, parameter :: ST_MISC = 1
integer, parameter :: ST_BANG_TAG = 2
integer, parameter :: ST_START_PI = 3
integer, parameter :: ST_PI_CONTENTS = 4
integer, parameter :: ST_PI_END = 5
integer, parameter :: ST_START_COMMENT = 6
integer, parameter :: ST_COMMENT_END = 7
integer, parameter :: ST_START_TAG = 8
integer, parameter :: ST_START_CDATA_DECLARATION = 9
integer, parameter :: ST_FINISH_CDATA_DECLARATION = 10
integer, parameter :: ST_IN_TAG = 11
integer, parameter :: ST_ATT_NAME = 12
integer, parameter :: ST_ATT_EQUALS = 13
integer, parameter :: ST_CHAR_IN_CONTENT = 14
integer, parameter :: ST_CLOSING_TAG = 15
integer, parameter :: ST_CDATA_CONTENTS = 16
integer, parameter :: ST_IN_CLOSING_TAG = 17
integer, parameter :: ST_TAG_IN_CONTENT = 18
integer, parameter :: ST_CDATA_END = 19
integer, parameter :: ST_IN_DOCTYPE = 20
integer, parameter :: ST_DOC_NAME = 21
integer, parameter :: ST_DOC_SYSTEM = 22
integer, parameter :: ST_DOC_PUBLIC = 23
integer, parameter :: ST_DOC_DECL = 24
integer, parameter :: ST_CLOSE_DOCTYPE = 25
integer, parameter :: ST_START_ENTITY = 26
integer, parameter :: ST_START_PE = 27
integer, parameter :: ST_IN_SUBSET = 28
! DTD states
integer, parameter :: ST_DTD_NULL = 50
integer, parameter :: ST_DTD_SUBSET = 51
integer, parameter :: ST_DTD_START_SECTION_DECL = 52
integer, parameter :: ST_DTD_FINISH_SECTION_DECL = 53
integer, parameter :: ST_DTD_IN_IGNORE_SECTION = 54
integer, parameter :: ST_DTD_BANG_TAG = 55
integer, parameter :: ST_DTD_START_PI = 56
integer, parameter :: ST_DTD_PI_CONTENTS = 57
integer, parameter :: ST_DTD_PI_END = 58
integer, parameter :: ST_DTD_COMMENT_END = 59
integer, parameter :: ST_DTD_START_COMMENT = 60
integer, parameter :: ST_DTD_ATTLIST = 61
integer, parameter :: ST_DTD_ELEMENT = 62
integer, parameter :: ST_DTD_ENTITY = 63
integer, parameter :: ST_DTD_NOTATION = 64
integer, parameter :: ST_DTD_NOTATION_ID = 65
integer, parameter :: ST_DTD_NOTATION_SYSTEM = 66
integer, parameter :: ST_DTD_NOTATION_PUBLIC = 67
integer, parameter :: ST_DTD_NOTATION_PUBLIC_2 = 68
integer, parameter :: ST_DTD_NOTATION_END = 69
integer, parameter :: ST_DTD_ENTITY_PE = 70
integer, parameter :: ST_DTD_ENTITY_ID = 71
integer, parameter :: ST_DTD_ENTITY_PUBLIC = 72
integer, parameter :: ST_DTD_ENTITY_SYSTEM = 73
integer, parameter :: ST_DTD_ENTITY_NDATA = 74
integer, parameter :: ST_DTD_ENTITY_NDATA_VALUE = 75
integer, parameter :: ST_DTD_ENTITY_END = 76
integer, parameter :: ST_DTD_ATTLIST_CONTENTS = 77
integer, parameter :: ST_DTD_ATTLIST_END = 78
integer, parameter :: ST_DTD_ELEMENT_CONTENTS = 79
integer, parameter :: ST_DTD_ELEMENT_END = 80
integer, parameter :: ST_DTD_DONE = 81
! token types
integer, parameter :: TOK_NULL = 0
integer, parameter :: TOK_PI_TAG = 1 ! <?
integer, parameter :: TOK_BANG_TAG = 2 ! <!
integer, parameter :: TOK_OPEN_TAG = 3 ! <
integer, parameter :: TOK_OPEN_SB = 4 ! [
integer, parameter :: TOK_CLOSE_SB = 5 ! [
integer, parameter :: TOK_OPEN_COMMENT = 6 ! --
integer, parameter :: TOK_NAME = 7 ! name (+token)
integer, parameter :: TOK_CHAR = 8 ! character data (+token)
integer, parameter :: TOK_PI_END = 9 ! ?>
integer, parameter :: TOK_COMMENT_END = 10 ! -->
integer, parameter :: TOK_SECTION_START = 11 ! <![
integer, parameter :: TOK_SECTION_END = 12 ! ]]>
integer, parameter :: TOK_END_TAG = 13 ! >
integer, parameter :: TOK_END_TAG_CLOSE = 14 ! />
integer, parameter :: TOK_CLOSE_TAG = 15 ! </
integer, parameter :: TOK_ENTITY = 16 ! % or &
integer, parameter :: TOK_EQUALS = 17 ! =
integer, parameter :: TOK_DTD_CONTENTS = 18 ! for element and attlist
integer, parameter :: TOK_OPEN_PAR = 19 ! (
integer, parameter :: TOK_CLOSE_PAR = 20 ! )
type sax_parser_t
type(xml_doc_state), pointer :: xds
logical :: xds_used = .false. ! is the xds used by DOM? If so, we must
! not destroy it once we are finished
integer :: context
integer :: state = ST_NULL
integer :: state_dtd = ST_DTD_SUBSET
logical :: well_formed = .false.
logical :: skippedExternal = .false.
type(varstr) :: token
type(varstr) :: content
integer :: tokenType = TOK_NULL
integer :: nextTokenType = TOK_NULL
type(varstr) :: name
type(varstr) :: attname
logical :: error = .false.
type(error_stack) :: error_stack
! Aspects of document structure
type(varstr) :: root_element
type(elstack_t) :: elstack
type(dictionary_t) :: attributes
type(namespacedictionary) :: nsdict
type(notation_list) :: nlist
type(entity_list) :: predefined_e_list
type(entity_list) :: forbidden_pe_list
type(entity_list) :: forbidden_ge_list
type(varstr) :: PublicId
type(varstr) :: SystemId
type(varstr) :: Ndata
logical :: inIntSubset = .false.
logical :: spaceBeforeEntity = .false.
end type sax_parser_t
#endif
type xml_t
#ifndef DUMMYLIB
type(file_buffer_t) :: fb
type(sax_parser_t) :: fx
#else
integer :: i = 0
#endif
end type xml_t
end module m_sax_types

438
src/xml/sax/m_sax_xml_source.F90 Normal file
View file

@ -0,0 +1,438 @@
module m_sax_xml_source
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc
use fox_m_fsys_format, only: operator(//)
use m_common_error, only: error_stack, add_error, in_error
use m_common_charset, only: XML_WHITESPACE, XML_INITIALENCODINGCHARS, &
XML_ENCODINGCHARS, XML1_0, XML1_1, isXML1_0_NameChar, &
isLegalChar, isUSASCII, allowed_encoding
use m_common_io, only: io_eor, io_eof
use FoX_utils, only: URI
implicit none
private
type buffer_t
character, dimension(:), pointer :: s
integer :: pos = 1
end type buffer_t
type xml_source_t
!FIXME private
integer :: lun = -1
integer :: xml_version = XML1_0
character, pointer :: encoding(:) => null()
logical :: isUSASCII
character, pointer :: filename(:) => null()
type(URI), pointer :: baseURI => null()
integer :: line = 0
integer :: col = 0
integer :: startChar = 1 ! First character after XML decl
character, pointer :: next_chars(:) => null() ! pushback buffer
type(buffer_t), pointer :: input_string => null()
logical :: pe = .false. ! is this a parameter entity?
logical :: eof = .false.! need to keep track of this at the end of pes
end type xml_source_t
public :: buffer_t
public :: xml_source_t
public :: get_char_from_file
public :: push_file_chars
public :: parse_declaration
contains
function get_char_from_file(f, xv, eof, es) result(string)
type(xml_source_t), intent(inout) :: f
integer, intent(in) :: xv
logical, intent(out) :: eof
type(error_stack), intent(inout) :: es
character(len=1) :: string
integer :: iostat
logical :: pending
character :: c, c2
pending = .false.
eof = .false.
c = read_single_char(f, iostat)
if (iostat==io_eof) then
eof = .true.
return
elseif (iostat/=0) then
call add_error(es, "Error reading "//str_vs(f%filename))
return
endif
if (.not.isLegalChar(c, f%isUSASCII, xv)) then
call add_error(es, "Illegal character found at " &
//str_vs(f%filename)//":"//f%line//":"//f%col)
return
endif
if (c==achar(13)) then
c = achar(10)
c2 = read_single_char(f, iostat)
if (iostat==io_eof) then
! the file has just ended on a single CR. Report is as a LF.
! Ignore the eof just now, it'll be picked up if we need to
! perform another read.
eof = .false.
elseif (iostat/=0) then
call add_error(es, "Error reading "//str_vs(f%filename))
return
elseif (c2/=achar(10)) then
! then we keep c2, otherwise we'd just ignore it.
pending = .true.
endif
endif
string = c
if (pending) then
! we have one character left over, put in the pushback buffer
deallocate(f%next_chars)
allocate(f%next_chars(1))
f%next_chars = c2
endif
if (c==achar(10)) then
f%line = f%line + 1
f%col = 0
else
f%col = f%col + 1
endif
end function get_char_from_file
function read_single_char(f, iostat) result(c)
type(xml_source_t), intent(inout) :: f
integer, intent(out) :: iostat
character :: c
if (f%eof) then
c = ""
iostat = io_eof
return
endif
if (f%lun==-1) then
if (f%input_string%pos>size(f%input_string%s)) then
c = ""
if (f%pe) then
iostat = 0
else
iostat = io_eof
endif
f%eof = .true.
else
iostat = 0
c = f%input_string%s(f%input_string%pos)
f%input_string%pos = f%input_string%pos + 1
endif
else
read (unit=f%lun, iostat=iostat, advance="no", fmt="(a1)") c
if (iostat==io_eor) then
iostat = 0
#ifdef FC_EOR_LF
c = achar(10)
#else
c = achar(13)
#endif
elseif (iostat==io_eof) then
if (f%pe) iostat = 0
c = ""
f%eof = .true.
endif
endif
end function read_single_char
subroutine rewind_source(f)
type(xml_source_t), intent(inout) :: f
if (f%lun==-1) then
f%input_string%pos = 1
else
rewind(f%lun)
endif
end subroutine rewind_source
subroutine push_file_chars(f, s)
type(xml_source_t), intent(inout) :: f
character(len=*), intent(in) :: s
character, dimension(:), pointer :: nc
nc => vs_str_alloc(s//str_vs(f%next_chars))
deallocate(f%next_chars)
f%next_chars => nc
end subroutine push_file_chars
subroutine parse_declaration(f, eof, es, standalone)
type(xml_source_t), intent(inout) :: f
logical, intent(out) :: eof
type(error_stack), intent(inout) :: es
logical, intent(out), optional :: standalone
integer :: parse_state, xd_par
character :: c, q
character, pointer :: ch(:), ch2(:)
integer, parameter :: XD_0 = 0
integer, parameter :: XD_START = 1
integer, parameter :: XD_TARGET = 2
integer, parameter :: XD_MISC = 3
integer, parameter :: XD_PA = 4
integer, parameter :: XD_EQ = 5
integer, parameter :: XD_QUOTE = 6
integer, parameter :: XD_PV = 7
integer, parameter :: XD_END = 8
integer, parameter :: XD_SPACE = 9
integer, parameter :: xd_nothing = 0
integer, parameter :: xd_version = 1
integer, parameter :: xd_encoding = 2
integer, parameter :: xd_standalone = 3
f%xml_version = XML1_0
if (present(standalone)) standalone = .false.
f%startChar = 1
parse_state = XD_0
xd_par = xd_nothing
ch => null()
do
c = get_char_from_file(f, XML1_0, eof, es)
if (eof) then
call rewind_source(f)
exit
elseif (in_error(es)) then
goto 100
endif
f%startChar = f%startChar + 1
select case (parse_state)
case (XD_0)
if (c=="<") then
parse_state = XD_START
else
call rewind_source(f)
exit
endif
case (XD_START)
if (c=="?") then
parse_state = XD_TARGET
ch => vs_str_alloc("")
else
call rewind_source(f)
exit
endif
case (XD_TARGET)
if (isXML1_0_NameChar(c)) then
ch2 => vs_str_alloc(str_vs(ch)//c)
deallocate(ch)
ch => ch2
elseif (verify(c, XML_WHITESPACE)==0 &
.and.str_vs(ch)=="xml") then
deallocate(ch)
parse_state = XD_MISC
else
call rewind_source(f)
deallocate(ch)
exit
endif
case (XD_SPACE)
if (verify(c, XML_WHITESPACE)==0) then
parse_state = XD_MISC
elseif (c=="?") then
parse_state = XD_END
else
call add_error(es, &
"Missing space in XML declaration")
endif
case (XD_MISC)
if (c=="?") then
parse_state = XD_END
elseif (isXML1_0_NameChar(c)) then
ch => vs_str_alloc(c)
parse_state = XD_PA
elseif (verify(c, XML_WHITESPACE)>0) then
call add_error(es, &
"Unexpected character in XML declaration")
endif
case (XD_PA)
if (isXML1_0_NameChar(c)) then
ch2 => vs_str_alloc(str_vs(ch)//c)
deallocate(ch)
ch => ch2
elseif (verify(c, XML_WHITESPACE//"=")==0) then
select case (str_vs(ch))
case ("version")
select case (xd_par)
case (xd_nothing)
xd_par = xd_version
case default
call add_error(es, &
"Cannot specify version twice in XML declaration")
end select
case ("encoding")
select case (xd_par)
case (xd_nothing)
if (present(standalone)) then
call add_error(es, &
"Must specify version before encoding in XML declaration")
else
xd_par = xd_encoding
endif
case (xd_version)
xd_par = xd_encoding
case (xd_encoding)
call add_error(es, &
"Cannot specify encoding twice in XML declaration")
case (xd_standalone)
call add_error(es, &
"Cannot specify encoding after standalone in XML declaration")
end select
case ("standalone")
if (.not.present(standalone)) &
call add_error(es, &
"Cannot specify standalone in text declaration")
select case (xd_par)
case (xd_nothing)
call add_error(es, &
"Must specify version before standalone in XML declaration")
case (xd_version, xd_encoding)
xd_par = xd_standalone
case (xd_standalone)
call add_error(es, &
"Cannot specify standalone twice in XML declaration")
end select
case default
call add_error(es, &
"Unknown parameter "//str_vs(ch)//" in XML declaration, "//&
"expecting version, encoding or standalone")
end select
deallocate(ch)
if (c=="=") then
parse_state = XD_QUOTE
else
parse_state = XD_EQ
endif
else
call add_error(es, &
"Unexpected character found in XML declaration")
endif
case (XD_EQ)
if (c=="=") then
parse_state = XD_QUOTE
elseif (verify(c, XML_WHITESPACE)>0) then
call add_error(es, &
"Unexpected character found in XML declaration; expecting ""=""")
endif
case (XD_QUOTE)
if (verify(c, "'""")==0) then
q = c
parse_state = XD_PV
ch => vs_str_alloc("")
elseif (verify(c, XML_WHITESPACE)>0) then
call add_error(es, &
"Unexpected character found in XML declaration; expecting "" or '")
endif
case (XD_PV)
if (c==q) then
select case (xd_par)
case (xd_version)
if (str_vs(ch)//"x"=="1.0x") then
f%xml_version = XML1_0
deallocate(ch)
elseif (str_vs(ch)//"x"=="1.1x") then
f%xml_version = XML1_1
deallocate(ch)
else
call add_error(es, &
"Unknown version number "//str_vs(ch)//" found in XML declaration; expecting 1.0 or 1.1")
endif
case (xd_encoding)
if (size(ch)==0) then
call add_error(es, &
"Empty value for encoding not allowed in XML declaration")
elseif (size(ch)==1.and.verify(ch(1), XML_INITIALENCODINGCHARS)>0) then
call add_error(es, &
"Invalid encoding found in XML declaration; illegal characters in encoding name")
elseif (size(ch)>1.and. &
(verify(ch(1), XML_INITIALENCODINGCHARS)>0 &
.or.verify(str_vs(ch(2:)), XML_ENCODINGCHARS)>0)) then
call add_error(es, &
"Invalid encoding found in XML declaration; illegal characters in encoding name")
elseif (.not.allowed_encoding(str_vs(ch))) then
call add_error(es, "Unknown character encoding in XML declaration")
else
f%encoding => ch
f%isUSASCII = isUSASCII(str_vs(ch))
ch => null()
endif
case (xd_standalone)
if (str_vs(ch)//"x"=="yesx") then
standalone = .true.
deallocate(ch)
elseif (str_vs(ch)//"x"=="nox") then
standalone = .false.
deallocate(ch)
else
call add_error(es, &
"Invalid value for standalone found in XML declaration; expecting yes or no")
endif
end select
parse_state = XD_SPACE
else
ch2 => vs_str_alloc(str_vs(ch)//c)
deallocate(ch)
ch => ch2
endif
case (XD_END)
if (c==">") then
exit
else
call add_error(es, &
"Unexpected character found in XML declaration; expecting >")
endif
end select
end do
if (.not.associated(f%encoding)) then
if (present(standalone).or.parse_state/=XD_END) then
f%encoding => vs_str_alloc("utf-8")
else
call add_error(es, "Missing encoding in text declaration")
endif
endif
100 if (associated(ch)) deallocate(ch)
! if there is no XML declaraion, or if parsing caused an error, then
if (parse_state/=XD_END.or.in_error(es)) f%startChar = 1
end subroutine parse_declaration
#endif
end module m_sax_xml_source

22
src/xml/utils/FoX_utils.F90 Normal file
View file

@ -0,0 +1,22 @@
module FoX_utils
use fox_m_utils_uuid
use fox_m_utils_uri
implicit none
private
public :: generate_uuid
public :: URI
public :: parseURI
public :: rebaseURI
public :: copyURI
public :: destroyURI
public :: expressURI
public :: hasFragment
public :: hasScheme
public :: getScheme
public :: getPath
end module FoX_utils

29
src/xml-fortran/Makefile → src/xml/utils/Makefile
View file

@ -1,12 +1,11 @@
reader = xmlreader
source = $(wildcard *.f90)
objects = $(source:.f90=.o)
source = $(wildcard *.F90)
objects = $(source:.F90=.o)
#===============================================================================
# Compiler Options
#===============================================================================
# Ignore unused variables
# Ignore unusd variables
ifeq ($(MACHINE),bluegene)
override F90 = xlf2003
@ -20,11 +19,11 @@ endif
# Targets
#===============================================================================
all: $(reader)
$(reader): $(objects)
$(F90) $(objects) $(LDFLAGS) -o $@
all: $(objects)
mv *.mod ../include
mv *.o ../lib
clean:
@rm -f *.o *.mod $(reader)
@rm -f *.o *.mod
neat:
@rm -f *.o *.mod
@ -32,16 +31,16 @@ neat:
# Rules
#===============================================================================
.SUFFIXES: .f90 .o
.PHONY: all clean neat
.SUFFIXES: .F90 .o
%.o: %.f90
$(F90) $(F90FLAGS) -c $<
.PHONY: clean neat
%.o: %.F90
$(F90) $(F90FLAGS) -c -I../include $<
#===============================================================================
# Dependencies
#===============================================================================
read_xml_primitives.o: xmlparse.o
write_xml_primitives.o: xmlparse.o
xmlreader.o: xmlparse.o
FoX_utils.o: fox_m_utils_uuid.o fox_m_utils_uri.o
fox_m_utils_uuid.o: fox_m_utils_mtprng.o

360
src/xml/utils/fox_m_utils_mtprng.F90 Normal file
View file

@ -0,0 +1,360 @@
module fox_m_utils_mtprng
#ifndef DUMMYLIB
!---------------------------------------------------------------------
! From the Algorithmic Conjurings of Scott Robert Ladd comes...
!---------------------------------------------------------------------
!
! mtprng.f90 (a Fortran 95 module)
!
! An implementation of the Mersenne Twister algorithm for generating
! psuedo-random sequences.
!
! History
! -------
! 1.0.0 Initial release
!
! 1.1.0 6 February 2002
! Updated to support algorithm revisions posted
! by Matsumoto and Nishimura on 26 January 2002
!
! 1.5.0 12 December 2003
! Added to hypatia project
! Minor style changes
! Tightened code
! Now state based; no static variables
! Removed mtprng_rand_real53
!
! 2.0.0 4 January 2004
! Corrected erroneous unsigned bit manipulations
! Doubled resolution by using 64-bit math
! Added mtprng_rand64
! Version for distribution with FoX <http://uszla.me.uk/FoX>
! Very small cosmetic changes to fit FoX naming scheme and
! avoid additional dependencies.
! Toby White <tow@uszla.me.uk>, 2007
!
! ORIGINAL ALGORITHM COPYRIGHT
! ============================
! Copyright (C) 1997,2002 Makoto Matsumoto and Takuji Nishimura.
! Any feedback is very welcome. For any question, comments, see
! http://www.math.keio.ac.jp/matumoto/emt.html or email
! matumoto@math.keio.ac.jp
!---------------------------------------------------------------------
!
! COPYRIGHT NOTICE, DISCLAIMER, and LICENSE:
!
! This notice applies *only* to this specific expression of this
! algorithm, and does not imply ownership or invention of the
! implemented algorithm.
!
! If you modify this file, you may insert additional notices
! immediately following this sentence.
!
! Copyright 2001, 2002, 2004 Scott Robert Ladd.
! All rights reserved, except as noted herein.
!
! This computer program source file is supplied "AS IS". Scott Robert
! Ladd (hereinafter referred to as "Author") disclaims all warranties,
! expressed or implied, including, without limitation, the warranties
! of merchantability and of fitness for any purpose. The Author
! assumes no liability for direct, indirect, incidental, special,
! exemplary, or consequential damages, which may result from the use
! of this software, even if advised of the possibility of such damage.
!
! The Author hereby grants anyone permission to use, copy, modify, and
! distribute this source code, or portions hereof, for any purpose,
! without fee, subject to the following restrictions:
!
! 1. The origin of this source code must not be misrepresented.
!
! 2. Altered versions must be plainly marked as such and must not
! be misrepresented as being the original source.
!
! 3. This Copyright notice may not be removed or altered from any
! source or altered source distribution.
!
! The Author specifically permits (without fee) and encourages the use
! of this source code for entertainment, education, or decoration. If
! you use this source code in a product, acknowledgment is not required
! but would be appreciated.
!
! Acknowledgement:
! This license is based on the wonderful simple license that
! accompanies libpng.
!
!-----------------------------------------------------------------------
!
! For more information on this software package, please visit
! Scott's web site, Coyote Gulch Productions, at:
!
! http://www.coyotegulch.com
!
!-----------------------------------------------------------------------
implicit none
! Kind types for 64-, 32-, 16-, and 8-bit signed integers
integer, parameter :: INT64 = selected_int_kind(18)
integer, parameter :: INT32 = selected_int_kind(9)
integer, parameter :: INT16 = selected_int_kind(4)
integer, parameter :: INT08 = selected_int_kind(2)
! Kind types for IEEE 754/IEC 60559 single- and double-precision reals
integer, parameter :: IEEE32 = selected_real_kind( 6, 37 )
integer, parameter :: IEEE64 = selected_real_kind( 15, 307 )
!------------------------------------------------------------------------------
! Everything is private unless explicitly made public
private
public :: mtprng_state, &
mtprng_init, mtprng_init_by_array, &
mtprng_rand64, mtprng_rand, mtprng_rand_range, &
mtprng_rand_real1, mtprng_rand_real2, mtprng_rand_real3
!------------------------------------------------------------------------------
! Constants
integer(INT32), parameter :: N = 624_INT32
integer(INT32), parameter :: M = 397_INT32
!------------------------------------------------------------------------------
! types
type mtprng_state
integer(INT32) :: mti = -1
integer(INT64), dimension(0:N-1) :: mt
end type
contains
!--------------------------------------------------------------------------
! Initializes the generator with "seed"
subroutine mtprng_init(seed, state)
! arguments
integer(INT32), intent(in) :: seed
type(mtprng_state), intent(out) :: state
! working storage
integer :: i
! save seed
state%mt(0) = seed
! Set the seed using values suggested by Matsumoto & Nishimura, using
! a generator by Knuth. See original source for details.
do i = 1, N - 1
state%mt(i) = iand(4294967295_INT64,1812433253_INT64 * ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64)) + i)
end do
state%mti = N
end subroutine mtprng_init
!--------------------------------------------------------------------------
! Initialize with an array of seeds
subroutine mtprng_init_by_array(init_key, state)
! arguments
integer(INT32), dimension(:), intent(in) :: init_key
type(mtprng_state), intent(out) :: state
! working storage
integer :: key_length
integer :: i
integer :: j
integer :: k
call mtprng_init(19650218_INT32,state)
i = 1
j = 0
key_length = size(init_key)
do k = max(N,key_length), 0, -1
state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1664525_INT64))) + init_key(j) + j
i = i + 1
j = j + 1
if (i >= N) then
state%mt(0) = state%mt(N-1)
i = 1
end if
if (j >= key_length) j = 0
end do
do k = N-1, 0, -1
state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1566083941_INT64))) - i
i = i + 1
if (i>=N) then
state%mt(0) = state%mt(N-1)
i = 1
end if
end do
state%mt(0) = 1073741824_INT64 ! 0x40000000, assuring non-zero initial array
end subroutine mtprng_init_by_array
!--------------------------------------------------------------------------
! Obtain the next 32-bit integer in the psuedo-random sequence
function mtprng_rand64(state) result(r)
! arguments
type(mtprng_state), intent(inout) :: state
!return type
integer(INT64) :: r
! internal constants
integer(INT64), dimension(0:1), parameter :: mag01 = (/ 0_INT64, -1727483681_INT64 /)
! Period parameters
integer(INT64), parameter :: UPPER_MASK = 2147483648_INT64
integer(INT64), parameter :: LOWER_MASK = 2147483647_INT64
! Tempering parameters
integer(INT64), parameter :: TEMPERING_B = -1658038656_INT64
integer(INT64), parameter :: TEMPERING_C = -272236544_INT64
! Note: variable names match those in original example
integer(INT32) :: kk
! Generate N words at a time
if (state%mti >= N) then
! The value -1 acts as a flag saying that the seed has not been set.
if (state%mti == -1) call mtprng_init(4357_INT32,state)
! Fill the mt array
do kk = 0, N - M - 1
r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK))
state%mt(kk) = ieor(ieor(state%mt(kk + M),ishft(r,-1_INT64)),mag01(iand(r,1_INT64)))
end do
do kk = N - M, N - 2
r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK))
state%mt(kk) = ieor(ieor(state%mt(kk + (M - N)),ishft(r,-1_INT64)),mag01(iand(r,1_INT64)))
end do
r = ior(iand(state%mt(N-1),UPPER_MASK),iand(state%mt(0),LOWER_MASK))
state%mt(N-1) = ieor(ieor(state%mt(M-1),ishft(r,-1)),mag01(iand(r,1_INT64)))
! Start using the array from first element
state%mti = 0
end if
! Here is where we actually calculate the number with a series of
! transformations
r = state%mt(state%mti)
state%mti = state%mti + 1
r = ieor(r,ishft(r,-11))
r = iand(4294967295_INT64,ieor(r,iand(ishft(r, 7),TEMPERING_B)))
r = iand(4294967295_INT64,ieor(r,iand(ishft(r,15),TEMPERING_C)))
r = ieor(r,ishft(r,-18))
end function mtprng_rand64
!--------------------------------------------------------------------------
! Obtain the next 32-bit integer in the psuedo-random sequence
function mtprng_rand(state) result(r)
! arguments
type(mtprng_state), intent(inout) :: state
!return type
integer(INT32) :: r
! working storage
integer(INT64) :: x
! done
x = mtprng_rand64(state)
if (x > 2147483647_INT64) then
r = x - 4294967296_INT64
else
r = x
end if
end function mtprng_rand
!---------------------------------------------------------------------------
! Obtain a psuedorandom integer in the range [lo,hi]
function mtprng_rand_range(state, lo, hi) result(r)
! arguments
type(mtprng_state), intent(inout) :: state
integer, intent(in) :: lo
integer, intent(in) :: hi
! return type
integer(INT32) :: r
! Use real value to caluclate range
r = lo + floor((hi - lo + 1.0_IEEE64) * mtprng_rand_real2(state))
end function mtprng_rand_range
!--------------------------------------------------------------------------
! Obtain a psuedorandom real number in the range [0,1], i.e., a number
! greater than or equal to 0 and less than or equal to 1.
function mtprng_rand_real1(state) result(r)
! arguments
type(mtprng_state), intent(inout) :: state
! return type
real(IEEE64) :: r
! Local constant; precalculated to avoid division below
real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967295.0_IEEE64
! compute
r = real(mtprng_rand64(state),IEEE64) * factor
end function mtprng_rand_real1
!--------------------------------------------------------------------------
! Obtain a psuedorandom real number in the range [0,1), i.e., a number
! greater than or equal to 0 and less than 1.
function mtprng_rand_real2(state) result(r)
! arguments
type(mtprng_state), intent(inout) :: state
! return type
real(IEEE64) :: r
! Local constant; precalculated to avoid division below
real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64
! compute
r = real(mtprng_rand64(state),IEEE64) * factor
end function mtprng_rand_real2
!--------------------------------------------------------------------------
! Obtain a psuedorandom real number in the range (0,1), i.e., a number
! greater than 0 and less than 1.
function mtprng_rand_real3(state) result(r)
! arguments
type(mtprng_state), intent(inout) :: state
! return type
real(IEEE64) :: r
! Local constant; precalculated to avoid division below
real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64
r = (real(mtprng_rand64(state),IEEE64) + 0.5_IEEE64) * factor
end function mtprng_rand_real3
#endif
end module fox_m_utils_mtprng

1033
src/xml/utils/fox_m_utils_uri.F90 Normal file
View file

File diff suppressed because it is too large Load diff

247
src/xml/utils/fox_m_utils_uuid.F90 Normal file
View file

@ -0,0 +1,247 @@
module fox_m_utils_uuid
!This generates UUIDs according to RFC 4122
! Only types 1 (time-based) and 4 (pseudo-RNG-based) are implemented.
#ifndef DUMMYLIB
use fox_m_utils_mtprng, only : mtprng_state, mtprng_init, mtprng_rand64
#endif
implicit none
private
#ifndef DUMMYLIB
integer, parameter :: i4b = selected_int_kind(9)
integer, parameter :: i8b = selected_int_kind(18)
character, parameter :: hexdigits(0:15) = &
(/'0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f'/)
type(mtprng_state), save :: rng_state
logical, save :: initialized = .false.
integer, save :: values_save ! must be default for date_and_time
integer(kind=i4b), save :: hires_count = 0
! clock-seq holds a random number constant for the lifetime of the program
! using this module. That's the best we can do per S 4.1.5
integer, save :: clock_seq = 0
#endif
public :: generate_uuid
contains
function generate_uuid(version) result(uuid)
integer, intent(in), optional :: version
character(len=36) :: uuid
#ifdef DUMMYLIB
uuid = ""
#else
integer(kind=i8b) :: timestamp, node
integer(kind=i4b) :: clock_sequence
integer(kind=i4b) :: time_low, time_mid, time_hi_and_version
integer(kind=i4b) :: clk_seq_hi_res, clk_seq_low
integer :: values(8) ! must be default for date_and_time
integer(kind=i4b) :: variant, v
if (.not.initialized) then
! Use the current date and time to init mtprng
! but this gives limited varaibility, so mix
! the result up. Can we do better? In any
! case, this gets passed through a quick
! generator inside mtprng_init.
call date_and_time(values=values)
values(7) = values(7)*1000+values(5)*100+values(3)*10+values(1)
values(8) = values(2)*1000+values(4)*100+values(6)*10+values(8)
call mtprng_init(int(values(7)*10000+values(8), i4b), rng_state)
clock_seq = int(mtprng_rand64(rng_state), i4b)
initialized = .true.
endif
variant = 1
if (present(version)) then
v = version
else
v = 4
endif
select case (v)
case (0)
! Nil UUID - S 4.1.7
uuid = repeat('0',8)//'-'//repeat('0',4)//'-'//repeat('0',4)// &
'-'//repeat('0',4)//'-'//repeat('0',12)
return
case(1)
call date_and_time(values=values)
! In case of too-frequent requests, we will replace time_low
! with the count below ...
if (all(values==values_save)) then
hires_count = hires_count + 1
else
hires_count = 0
endif
case(2-3)
!Unimplemented
uuid = ''
return
case(4)
continue
case(5)
!Unimplemented
uuid = ''
return
case default
!Unspecified
uuid = ''
return
end select
!4.1.4 Timestamp
select case(v)
case(1)
timestamp = get_utc_since_1582(values)
case(4)
timestamp = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 28))
end select
!4.1.5 Clock Sequence
! 14 bits
select case(v)
case(1)
clock_sequence = clock_seq
case(4)
clock_sequence = int(mtprng_rand64(rng_state), i4b)
end select
!4.1.6 Node
! 48 bits
select case(v)
case(1)
node = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 16))
! No MAC address accessible - see section 4.5 !FIXME
case(4)
node = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 16))
end select
time_low = ibits(timestamp, 0, 32)
time_mid = ibits(timestamp, 32, 16)
if (hires_count==0) then
time_hi_and_version = ior(int(ibits(timestamp, 48, 12), i4b), ishft(v, 12))
else
time_hi_and_version = ior(hires_count, ishft(v, 12))
endif
clk_seq_low = ibits(clock_sequence, 0, 8)
clk_seq_hi_res = ior(ibits(clock_sequence, 8, 6), ishft(variant, 6))
uuid = int32ToHexOctets(time_low, 4)//"-"// &
int32ToHexOctets(time_mid, 2)//"-"// &
int32ToHexOctets(time_hi_and_version, 2)//"-"// &
int32ToHexOctets(clk_seq_hi_res, 1)// &
int32ToHexOctets(clk_seq_low, 1)//"-"// &
int64ToHexOctets(node, 6)
contains
function int32ToHexOctets(b, n) result(s)
integer(i4b), intent(in) :: b
integer, intent(in) :: n ! number of octets to print
character(len=2*n) :: s
integer :: i
do i = 0, 2*n-1
s(2*n-i:2*n-i) = hexdigits(ibits(b, i*4, 4))
enddo
end function int32ToHexOctets
function int64ToHexOctets(b, n) result(s)
integer(i8b), intent(in) :: b
integer, intent(in) :: n ! number of octets to print
character(len=2*n) :: s
integer :: i
do i = 0, 2*n-1
s(2*n-i:2*n-i) = hexdigits(ibits(b, i*4, 4))
enddo
end function int64ToHexOctets
#endif
end function generate_uuid
#ifndef DUMMYLIB
function get_utc_since_1582(values) result(ns)
! This subroutine is a little broken. It only works
! for times after 1/1/2006 and takes no account
! of any future leapseconds. It ought to serve regardless.
! It returns the number of 100-ns intervals since 1582-10-15-00-00-00
integer, dimension(8), intent(in) :: values
integer(kind=i8b) :: ns
integer :: days
integer :: years
integer, parameter :: days_in_normal_year(12) = &
(/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
ns = 23_i8b * 1000_i8b * 1000_i8b * 10_i8b ! 23 leap seconds until 24:00:00 31/12/2005
! A count of the 100-nanosecond intervals since the
! beginning of the day.
ns = ns &
! milliseconds
+ int(values(8), i8b) * 10_i8b * 1000_i8b &
! seconds
+ int(values(7), i8b) * 10_i8b * 1000_i8b * 1000_i8b &
! minutes (with timezone adjustment)
+ int(values(6) + values(4), i8b) * 10_i8b * 1000_i8b * 1000_i8b * 60_i8b &
! hours
+ int(values(5), i8b) * 10_i8b * 1000_i8b * 1000_i8b * 60_i8b * 60_i8b
! Number of days this year:
days = sum(days_in_normal_year(:values(2)-1))
days = days + values(3) - 1 !add days in current month
if (values(2)>2 .and. isLeapYear(values(1))) then
days = days + 1
endif
!That's all the time since the turn of this year
days = days + 78 ! From the start of 15th Oct to the end of 31st Dec in 1582
!That's the additional time before the turn of the year 1583
days = days + 102 ! 102 leap years from 1584 to 2000 inclusive
! That's all the intercalataed days until 2000
years = values(1) - 2000 - 1 ! years since 2000 - not including this year
days = days + years/4 - years/100 + years/400 !Add extra leap days to this total:
! That's all out intercalated days - remaining years are all 365 days long.
years = years + 418 ! Add the years from 1583-2000 inclusive back on.
! Multiply by number of time units in one day & add to today's total.
ns = ns + 864000000000_i8b * (int(days,i8b) + 365_i8b * int(years,i8b))
contains
function isLeapYear(y) result(p)
integer, intent(in) :: y
logical :: p
p = (mod(y,4)==0 .and. .not.mod(y,100)==0 .or. mod(y,400)==0)
end function isLeapYear
end function get_utc_since_1582
#endif
end module fox_m_utils_uuid

45
src/xml/wxml/FoX_wxml.F90 Normal file
View file

@ -0,0 +1,45 @@
module FoX_wxml
use m_wxml_core
use m_wxml_overloads
implicit none
private
public :: xmlf_t
public :: xml_OpenFile
public :: xml_Close
public :: xml_NewElement
public :: xml_EndElement
public :: xml_AddXMLDeclaration
public :: xml_AddXMLStylesheet
public :: xml_AddXMLPI
public :: xml_AddComment
public :: xml_AddEntityReference
public :: xml_AddCharacters
public :: xml_AddNewline
public :: xml_AddAttribute
public :: xml_AddPseudoAttribute
public :: xml_DeclareNamespace
public :: xml_UndeclareNamespace
public :: xml_AddDOCTYPE
public :: xml_AddParameterEntity
public :: xml_AddInternalEntity
public :: xml_AddExternalEntity
public :: xml_AddNotation
public :: xml_AddElementToDTD
public :: xml_AddAttlistToDTD
public :: xml_AddPEreferenceToDTD
public :: xmlf_GetPretty_print
public :: xmlf_SetPretty_print
public :: xmlf_GetExtendedData
public :: xmlf_SetExtendedData
public :: xmlf_Name
public :: xmlf_OpenTag
end module FoX_wxml

37
src/templates/Makefile → src/xml/wxml/Makefile
View file

@ -1,15 +1,15 @@
templates = $(wildcard *.xml)
objects = $(templates:.xml=.o)
source = $(wildcard *.F90)
objects = $(source:.F90=.o)
#===============================================================================
# Compiler Options
#===============================================================================
# Add include for subdirectory
# Ignore unusd variables
override F90FLAGS += -I../xml-fortran
# Ignore unused variables
ifeq ($(MACHINE),bluegene)
override F90 = xlf2003
endif
ifeq ($(F90),ifort)
override F90FLAGS += -warn nounused
@ -20,19 +20,28 @@ endif
#===============================================================================
all: $(objects)
mv *.mod ../include
mv *.o ../lib
clean:
@rm -f *.o *.mod *.out *.f90
@rm -f *.o *.mod
neat:
@rm -f *.o *.mod
#===============================================================================
# Rules
#===============================================================================
.SUFFIXES: .f90 .o .xml
.PHONY: all clean
.PRECIOUS: %.f90
.SUFFIXES: .F90 .o
%.f90: %.xml
../xml-fortran/xmlreader $(basename $@)
.PHONY: clean neat
%.o: %.f90
$(F90) $(F90FLAGS) -c $(basename $@).f90
%.o: %.F90
$(F90) $(F90FLAGS) -c -I../include $<
#===============================================================================
# Dependencies
#===============================================================================
FoX_wxml.o: m_wxml_core.o m_wxml_overloads.o
m_wxml_core.o: m_wxml_escape.o
m_wxml_overloads.o: m_wxml_core.o

1877
src/xml/wxml/m_wxml_core.F90 Normal file
View file

File diff suppressed because it is too large Load diff

140
src/xml/wxml/m_wxml_escape.F90 Normal file
View file

@ -0,0 +1,140 @@
module m_wxml_escape
#ifndef DUMMYLIB
!Ensure all characters are safe to go out into XML file.
use fox_m_fsys_format, only: str
use m_common_charset, only: XML1_0
use m_common_error, only: FoX_error, FoX_warning
implicit none
private
integer, parameter :: AMP = iachar('&')
integer, parameter :: LT = iachar('<')
integer, parameter :: GT = iachar('>')
integer, parameter :: QUOT = iachar('"')
integer, parameter :: APOS = iachar("'")
public :: escape_string
public :: escape_string_len
contains
pure function escape_string_len(s) result(c)
character(len=*), intent(in) :: s
integer :: c
integer :: i
c = len(s)
do i = 1, len(s)
select case(iachar(s(i:i)))
case (AMP)
c = c + 4
case (LT)
c = c + 3
case (GT)
c = c + 3
case (QUOT)
c = c + 5
case (APOS)
c = c + 5
case (1:8)
c = c + 3
case (11:12)
c = c + 4
case (14:31)
c = c + 4
case (127:)
c = c + 5
! a char can never contain more than 8 bits = 256 characters, so
! we never need more than 3 chars to represent the int.
end select
enddo
end function escape_string_len
function escape_string(s, version) result (s2)
character(len=*), intent(in) :: s
integer, intent(in) :: version
character(len=escape_string_len(s)) :: s2
integer :: c, i, ic
! We have to do it this way (with achar etc) in case the native
! platform encoding is not ASCII
c = 1
do i = 1, len(s)
ic = iachar(s(i:i))
select case (ic)
case (0)
call FoX_error("Tried to output a NUL character")
case (1:8)
if (version==XML1_0) then
call FoX_error("Tried to output a character invalid under XML 1.0")
else
s2(c:c+3) = "&#"//str(ic)//";"
c = c + 4
endif
case(9:10)
s2(c:c) = achar(ic)
c = c + 1
case(11:12)
if (version==XML1_0) then
call FoX_error("Tried to output a character invalid under XML 1.0")
else
s2(c:c+5) = "&#"//str(ic)//";"
c = c + 5
endif
case(13)
s2(c:c) = achar(13)
c = c + 1
case (14:31)
if (version==XML1_0) then
call FoX_error("Tried to output a character invalid under XML 1.0")
else
s2(c:c+5) = "&#"//str(ic)//";"
c = c + 5
endif
case (32:126)
select case (iachar(s(i:i)))
case (AMP)
s2(c:c+4) = "&amp;"
c = c + 5
case (LT)
s2(c:c+3) = "&lt;"
c = c + 4
case (GT)
s2(c:c+3) = "&gt;"
c = c + 4
case (QUOT)
s2(c:c+5) = "&quot;"
c = c + 6
case (APOS)
s2(c:c+5) = "&apos;"
c = c + 6
case default
s2(c:c) = achar(ic)
c = c + 1
end select
case (127)
s2(c:c+5) = "&#127;"
c = c + 6
case default
!TOHW we should maybe just disallow this ...
call FoX_warning("emitting non-ASCII character. Platform-dependent result!")
s2(c:c+6) = "&#"//str(ic)//";"
c = c + 6
! a char can never contain more than 8 bits = 256 characters, so
! we never need more than 3 chars to represent the int.
! We have to encode it though, because UTF-8 x7F-x9F must be
! encoded, and if they are in the native charset they'll be > 128
end select
enddo
end function escape_string
#endif
end module m_wxml_escape

1028
src/xml/wxml/m_wxml_overloads.F90 Normal file
View file

File diff suppressed because it is too large Load diff

542
src/xml_interface.F90 Normal file
View file

@ -0,0 +1,542 @@
module xml_interface
use constants, only: MAX_LINE_LEN
use error, only: fatal_error
use global, only: message
use fox_dom
implicit none
private
public :: Node
public :: NodeList
public :: open_xmldoc
public :: close_xmldoc
public :: check_for_node
public :: get_node_ptr
public :: get_node_list
public :: get_list_size
public :: get_list_item
public :: get_node_value
public :: get_node_array
public :: get_arraysize_integer
public :: get_arraysize_double
public :: get_arraysize_string
integer, parameter :: ATTR_NODE = 0
integer, parameter :: ELEM_NODE = 1
interface get_node_value
module procedure get_node_value_integer
module procedure get_node_value_long
module procedure get_node_value_double
module procedure get_node_value_string
end interface get_node_value
interface get_node_array
module procedure get_node_array_integer
module procedure get_node_array_double
module procedure get_node_array_string
end interface get_node_array
contains
!===============================================================================
! OPEN_XMLDOC opens and parses an XML and returns a pointer to the document
!===============================================================================
subroutine open_xmldoc(ptr, filename)
character(len=*) :: filename
type(Node), pointer :: ptr
ptr => parseFile(trim(filename)) ! Pointer to the whole XML document
ptr => getDocumentElement(ptr) ! Grabs root element of XML document
end subroutine open_xmldoc
!===============================================================================
! CLOSE_XMLDOC closes and destroys all memory associated with document
!===============================================================================
subroutine close_xmldoc(ptr)
type(Node), pointer :: ptr
ptr => getParentNode(ptr) ! Go from root element ptr to document ptr
call destroy(ptr) ! Deallocates all nodes recursively
end subroutine close_xmldoc
!===============================================================================
! CHECK_FOR_NODE checks for an attribute or sub-element node with the given
! node name. This should only be used for checking a single occurance of a
! sub-element node. To check for sub-element nodes that repeat, use
! get_node_list and get_list_size. This is to minimize number of calls
! to getElementsByTagName.
!===============================================================================
function check_for_node(ptr, node_name) result(found)
character(len=*), intent(in) :: node_name
logical :: found
type(Node), pointer, intent(in) :: ptr
type(Node), pointer :: temp_ptr
type(NodeList), pointer :: elem_list
! Default that we found it and attribute
found = .true.
! Get the attribute node
temp_ptr => getAttributeNode(ptr, trim(node_name))
! Check if node exists
if (associated(temp_ptr)) return
! Check for a sub-element
elem_list => getElementsByTagName(ptr, trim(node_name))
! Get the length of the list
if (getLength(elem_list) == 0) then
found = .false.
return
end if
end function check_for_node
!===============================================================================
! GET_NODE_PTR returns a Node pointer to an attribute or sub-element node.
! Note, this should only be used for sub-element nodes that occur only once.
! For repeated nodes, use get_node_list and then get_item_item.
!===============================================================================
subroutine get_node_ptr(in_ptr, node_name, out_ptr, found)
character(len=*), intent(in) :: node_name
logical, intent(out), optional :: found
type(Node), pointer, intent(in) :: in_ptr
type(Node), pointer, intent(out) :: out_ptr
logical :: found_
type(NodeList), pointer :: elem_list => null()
! Set found to false
found_ = .false.
! Check for a sub-element
elem_list => getElementsByTagName(in_ptr, trim(node_name))
! Get the length of the list
if (getLength(elem_list) == 0) return
! Point to the new element
out_ptr => item(elem_list, 0)
found_ = .true.
! Check to output found
if (present(found)) found = found_
end subroutine get_node_ptr
!===============================================================================
! GET_NODE_LIST is used to get a pointer to a list of sub-element nodes
!===============================================================================
subroutine get_node_list(in_ptr, node_name, out_ptr)
character(len=*), intent(in) :: node_name
type(Node), pointer, intent(in) :: in_ptr
type(NodeList), pointer, intent(out) :: out_ptr
! Check for a sub-element
out_ptr => getElementsByTagName(in_ptr, trim(node_name))
end subroutine get_node_list
!===============================================================================
! GET_LIST_SIZE is used to get the number of elements from a node list
!===============================================================================
function get_list_size(in_ptr) result(n_size)
integer :: n_size
type(NodeList), pointer, intent(in) :: in_ptr
! Get the size of the list
n_size = getLength(in_ptr)
end function get_list_size
!===============================================================================
! GET_LIST_ITEM is used to select a specific item from a node list
!===============================================================================
subroutine get_list_item(in_ptr, idx, out_ptr)
integer, intent(in) :: idx
type(NodeList), pointer, intent(in) :: in_ptr
type(Node), pointer, intent(out) :: out_ptr
! Check for a sub-element
out_ptr => item(in_ptr, idx - 1)
end subroutine get_list_item
!===============================================================================
! GET_NODE_VALUE_INTEGER returns a integer value from an attribute or node
!===============================================================================
subroutine get_node_value_integer(ptr, node_name, result_int)
character(len=*), intent(in) :: node_name
integer :: result_int
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_int)
else
call extractDataContent(temp_ptr, result_int)
end if
end subroutine get_node_value_integer
!===============================================================================
! GET_NODE_VALUE_LONG returns an 8-byte integer from attribute or node
!===============================================================================
subroutine get_node_value_long(ptr, node_name, result_long)
character(len=*), intent(in) :: node_name
integer(8) :: result_long
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_long)
else
call extractDataContent(temp_ptr, result_long)
end if
end subroutine get_node_value_long
!===============================================================================
! GET_NODE_VALUE_DOUBLE returns a double precision real from attr. or node
!===============================================================================
subroutine get_node_value_double(ptr, node_name, result_double)
character(len=*), intent(in) :: node_name
real(8) :: result_double
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_double)
else
call extractDataContent(temp_ptr, result_double)
end if
end subroutine get_node_value_double
!===============================================================================
! GET_NODE_ARRAY_INTEGER returns a 1-D array of integers
!===============================================================================
subroutine get_node_array_integer(ptr, node_name, result_int)
character(len=*), intent(in) :: node_name
integer :: result_int(:)
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_int)
else
call extractDataContent(temp_ptr, result_int)
end if
end subroutine get_node_array_integer
!===============================================================================
! GET_NODE_ARRAY_DOUBLE returns a 1-D array of double precision reals
!===============================================================================
subroutine get_node_array_double(ptr, node_name, result_double)
character(len=*), intent(in) :: node_name
real(8) :: result_double(:)
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_double)
else
call extractDataContent(temp_ptr, result_double)
end if
end subroutine get_node_array_double
!===============================================================================
! GET_NODE_ARRAY_STRING returns a 1-D array of strings
!===============================================================================
subroutine get_node_array_string(ptr, node_name, result_string)
character(len=*), intent(in) :: node_name
character(len=*) :: result_string(:)
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_string)
else
call extractDataContent(temp_ptr, result_string)
end if
end subroutine get_node_array_string
!===============================================================================
! GET_NODE_VALUE_STRING returns a single string from attr. or node
!===============================================================================
subroutine get_node_value_string(ptr, node_name, result_str)
character(len=*), intent(in) :: node_name
character(len=*) :: result_str
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_str)
else
call extractDataContent(temp_ptr, result_str)
end if
end subroutine get_node_value_string
!===============================================================================
! GET_NODE_ARRAYSIZE_INTEGER returns the size of the integer array
!===============================================================================
function get_arraysize_integer(ptr, node_name) result(n)
character(len=*), intent(in) :: node_name
integer :: n
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Get the size
n = countrts(getTextContent(temp_ptr), 0)
end function get_arraysize_integer
!===============================================================================
! GET_NODE_ARRAYSIZE_DOUBLE returns the size of double prec. real array
!===============================================================================
function get_arraysize_double(ptr, node_name) result(n)
character(len=*), intent(in) :: node_name
integer :: n
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Get the size
n = countrts(getTextContent(temp_ptr), 0.0_8)
end function get_arraysize_double
!===============================================================================
! GET_NODE_ARRAYSIZE_STRING returns the size of string array
!===============================================================================
function get_arraysize_string(ptr, node_name) result(n)
character(len=*), intent(in) :: node_name
integer :: n
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
message = "Node " // node_name // " not part of Node " // &
getNodeName(ptr) // "."
call fatal_error()
end if
! Get the size
n = countrts(getTextContent(temp_ptr), 'a')
end function get_arraysize_string
!===============================================================================
! GET_NODE private routine that gets a pointer to a specific node
!===============================================================================
subroutine get_node(in_ptr, node_name, out_ptr, node_type, found)
character(len=*), intent(in) :: node_name
integer, intent(out) :: node_type
logical, intent(out) :: found
type(Node), pointer, intent(in) :: in_ptr
type(Node), pointer, intent(out) :: out_ptr
type(NodeList), pointer :: elem_list
! Default that we found it and attribute
found = .true.
node_type = ATTR_NODE
! Get the attribute node
out_ptr => getAttributeNode(in_ptr, trim(node_name))
! Check if node exists
if (associated(out_ptr)) return
! Check for a sub-element
elem_list => getElementsByTagName(in_ptr, trim(node_name))
! Get the length of the list
if (getLength(elem_list) == 0) then
found = .false.
return
end if
! Point to the new element
node_type = ELEM_NODE
out_ptr => item(elem_list, 0)
end subroutine get_node
end module xml_interface

2
tests/test_output/settings.xml
View file

@ -1,7 +1,7 @@
<?xml version="1.0"?>
<settings>
<output>summary cross_sections</output>
<output summary="true" cross_sections="true" />
<eigenvalue>
<batches>10</batches>