diff --git a/.gitignore b/.gitignore index f67c611db..023c4f2c1 100644 --- a/.gitignore +++ b/.gitignore @@ -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 \ No newline at end of file +results_error.dat diff --git a/docs/source/usersguide/input.rst b/docs/source/usersguide/input.rst index 9ec51ca21..7a61ba2b5 100644 --- a/docs/source/usersguide/input.rst +++ b/docs/source/usersguide/input.rst @@ -198,19 +198,26 @@ tally data, this option can significantly improve the parallel efficiency. -------------------- The ```` 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. - summary cross_sections + *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. ```` Element ------------------------- diff --git a/schemas.xml b/schemas.xml index 982979001..465b9b398 100644 --- a/schemas.xml +++ b/schemas.xml @@ -1,10 +1,10 @@ - - - - - - - + + + + + + + diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index eeb538fc1..b1c339921 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -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 + diff --git a/src/Makefile b/src/Makefile index 4300d42e6..03c370e07 100644 --- a/src/Makefile +++ b/src/Makefile @@ -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 diff --git a/src/cmfd_input.F90 b/src/cmfd_input.F90 index d893d7bc7..ac3d59824 100644 --- a/src/cmfd_input.F90 +++ b/src/cmfd_input.F90 @@ -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 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 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 must be the same as & - &the number of entries on ." - call fatal_error() + if (m % n_dimension /= get_arraysize_double(node_mesh, "lower_left")) then + message = "Number of entries on must be the same as & + &the number of entries on ." + 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 and 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 and 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 and 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 and 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 must be the same as the & - &number of entries on ." - 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 must be the same as the & + &number of entries on ." + call fatal_error() + end if - ! Check for negative widths - if (any(mesh_ % width < ZERO)) then - message = "Cannot have a negative 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 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 must be the same as & - &the number of entries on ." - 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 must be the same as & + &the number of entries on ." + call fatal_error() + end if - ! Check that upper-right is above lower-left - if (any(mesh_ % upper_right < mesh_ % lower_left)) then - message = "The coordinates must be greater than the & - & 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 coordinates must be greater than the & + & 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 diff --git a/src/input_xml.F90 b/src/input_xml.F90 index 41dac3f06..e8d602c35 100644 --- a/src/input_xml.F90 +++ b/src/input_xml.F90 @@ -15,6 +15,7 @@ module input_xml starts_with, ends_with use tally_header, only: TallyObject, TallyFilter use tally_initialize, only: add_tallies + use xml_interface implicit none save @@ -47,15 +48,28 @@ contains subroutine read_settings_xml() - use xml_data_settings_t - - integer :: i ! loop index + character(MAX_LINE_LEN) :: temp_str + integer :: i integer :: n integer :: coeffs_reqd + integer :: temp_int + integer :: temp_int_array3(3) + integer, allocatable :: temp_int_array(:) + integer(8) :: temp_long logical :: file_exists character(MAX_FILE_LEN) :: env_variable character(MAX_WORD_LEN) :: type character(MAX_LINE_LEN) :: filename + type(Node), pointer :: doc => null() + type(Node), pointer :: node_mode => null() + type(Node), pointer :: node_source => null() + type(Node), pointer :: node_dist => null() + type(Node), pointer :: node_cutoff => null() + type(Node), pointer :: node_entropy => null() + type(Node), pointer :: node_ufs => null() + type(Node), pointer :: node_sp => null() + type(Node), pointer :: node_output => null() + type(Node), pointer :: node_verb => null() ! Display output message message = "Reading settings XML file..." @@ -69,84 +83,73 @@ contains call fatal_error() end if - ! Initialize XML scalar variables - cross_sections_ = '' - output_path_ = '' - verbosity_ = 0 - threads_ = NONE - energy_grid_ = 'union' - seed_ = 0_8 - source_ % file = '' - source_ % space % type = '' - source_ % angle % type = '' - source_ % energy % type = '' - ! Parse settings.xml file - call read_xml_file_settings_t(filename) + call open_xmldoc(doc, filename) ! Find cross_sections.xml file -- the first place to look is the ! settings.xml file. If no file is found there, then we check the ! CROSS_SECTIONS environment variable - - if (len_trim(cross_sections_) == 0 .and. run_mode /= MODE_PLOTTING) then - ! No cross_sections.xml file specified in settings.xml, check environment - ! variable - call get_environment_variable("CROSS_SECTIONS", env_variable) - if (len_trim(env_variable) == 0) then - message = "No cross_sections.xml file was specified in settings.xml & - &or in the CROSS_SECTIONS environment variable." - call fatal_error() + if (run_mode /= MODE_PLOTTING) then + if (.not. check_for_node(doc, "cross_sections") .and. & + run_mode /= MODE_PLOTTING) then + ! No cross_sections.xml file specified in settings.xml, check + ! environment variable + call get_environment_variable("CROSS_SECTIONS", env_variable) + if (len_trim(env_variable) == 0) then + message = "No cross_sections.xml file was specified in settings.xml & + &or in the CROSS_SECTIONS environment variable." + call fatal_error() + else + path_cross_sections = trim(env_variable) + end if else - path_cross_sections = trim(env_variable) + call get_node_value(doc, "cross_sections", path_cross_sections) end if - else - path_cross_sections = trim(cross_sections_) end if ! Set output directory if a path has been specified on the ! element - if (len_trim(output_path_) > 0) then - path_output = output_path_ + if (check_for_node(doc, "output_path")) then + call get_node_value(doc, "output_path", path_output) if (.not. ends_with(path_output, "/")) & path_output = trim(path_output) // "/" end if - ! Make sure that either criticality or fixed source was specified - if (eigenvalue_ % batches == 0 .and. fixed_source_ % batches == 0 & - .and. criticality_ % batches == 0) then - message = "Number of batches on or & - &tag was zero." + ! Make sure that either eigenvalue or fixed source was specified + if (.not.check_for_node(doc, "eigenvalue") .and. & + .not.check_for_node(doc, "fixed_source")) then + message = " or not specified." call fatal_error() end if - ! Check for old tag - if (criticality_ % batches > 0) then - eigenvalue_ = criticality_ - message = "The element has been deprecated and & - &replaced by ." - call warning() - end if - ! Eigenvalue information - if (eigenvalue_ % batches > 0) then + if (check_for_node(doc, "eigenvalue")) then ! Set run mode if (run_mode == NONE) run_mode = MODE_EIGENVALUE + ! Get pointer to eigenvalue XML block + call get_node_ptr(doc, "eigenvalue", node_mode) + ! Check number of particles - if (len_trim(eigenvalue_ % particles) == 0) then - message = "Need to specify number of particles per cycles." + if (.not.check_for_node(node_mode, "particles")) then + message = "Need to specify number of particles per generation." call fatal_error() end if + ! Get number of particles + call get_node_value(node_mode, "particles", temp_long) + ! If the number of particles was specified as a command-line argument, we ! don't set it here - if (n_particles == 0) n_particles = str_to_int(eigenvalue_ % particles) + if (n_particles == 0) n_particles = temp_long ! Copy batch and generation information - n_batches = eigenvalue_ % batches - n_inactive = eigenvalue_ % inactive - n_active = n_batches - n_inactive - gen_per_batch = eigenvalue_ % generations_per_batch + call get_node_value(node_mode, "batches", n_batches) + call get_node_value(node_mode, "inactive", n_inactive) + n_active = n_batches - n_inactive + if (check_for_node(node_mode, "generations_per_batch")) then + call get_node_value(node_mode, "generations_per_batch", gen_per_batch) + end if ! Allocate array for batch keff and entropy allocate(k_generation(n_batches*gen_per_batch)) @@ -155,23 +158,29 @@ contains end if ! Fixed source calculation information - if (fixed_source_ % batches > 0) then + if (check_for_node(doc, "fixed_source")) then ! Set run mode if (run_mode == NONE) run_mode = MODE_FIXEDSOURCE + ! Get pointer to fixed_source XML block + call get_node_ptr(doc, "fixed_source", node_mode) + ! Check number of particles - if (len_trim(fixed_source_ % particles) == 0) then - message = "Need to specify number of particles per cycles." + if (.not.check_for_node(node_mode, "particles")) then + message = "Need to specify number of particles per batch." call fatal_error() end if + ! Get number of particles + call get_node_value(node_mode, "particles", temp_long) + ! If the number of particles was specified as a command-line argument, we ! don't set it here - if (n_particles == 0) n_particles = str_to_int(fixed_source_ % particles) + if (n_particles == 0) n_particles = temp_long ! Copy batch information - n_batches = fixed_source_ % batches - n_active = fixed_source_ % batches + call get_node_value(node_mode, "batches", n_batches) + n_active = n_batches n_inactive = 0 gen_per_batch = 1 end if @@ -189,10 +198,15 @@ contains end if ! Copy random number seed if specified - if (seed_ > 0) seed = seed_ + if (check_for_node(doc, "seed")) call get_node_value(doc, "seed", seed) ! Energy grid methods - select case (energy_grid_) + if (check_for_node(doc, "energy_grid")) then + call get_node_value(doc, "energy_grid", temp_str) + else + temp_str = 'union' + end if + select case (trim(temp_str)) case ('nuclide') grid_method = GRID_NUCLIDE case ('union') @@ -201,18 +215,21 @@ contains message = "Lethargy mapped energy grid not yet supported." call fatal_error() case default - message = "Unknown energy grid method: " // energy_grid_ + message = "Unknown energy grid method: " // trim(temp_str) call fatal_error() end select ! Verbosity - if (verbosity_ > 0) verbosity = verbosity_ + if (check_for_node(doc, "verbosity")) then + call get_node_ptr(doc, "verbosity", node_verb) + call get_node_value(node_verb, "value", verbosity) + end if ! Number of OpenMP threads - if (threads_ /= NONE) then + if (check_for_node(doc, "threads")) then #ifdef OPENMP if (n_threads == NONE) then - n_threads = threads_ + call get_node_value(doc, "threads", n_threads) if (n_threads < 1) then message = "Invalid number of threads: " // to_str(n_threads) call fatal_error() @@ -228,9 +245,18 @@ contains ! ========================================================================== ! EXTERNAL SOURCE - if (source_ % file /= '') then + ! Get pointer to source + if (check_for_node(doc, "source")) then + call get_node_ptr(doc, "source", node_source) + else + message = "No source specified in settings XML file." + call fatal_error() + end if + + ! Check for external source file + if (check_for_node(node_source, "file")) then ! Copy path of source file - path_source = source_ % file + call get_node_value(node_source, "file", path_source) ! Check if source file exists inquire(FILE=path_source, EXIST=file_exists) @@ -241,12 +267,19 @@ contains end if else + ! Spatial distribution for external source - if (source_ % space % type /= '') then - ! Read type of spatial distribution - type = source_ % space % type + if (check_for_node(node_source, "space")) then + + ! Get pointer to spatial distribution + call get_node_ptr(node_source, "space", node_dist) + + ! Check for type of spatial distribution + type = '' + if (check_for_node(node_dist, "type")) & + call get_node_value(node_dist, "type", type) call lower_case(type) - select case (type) + select case (trim(type)) case ('box') external_source % type_space = SRC_SPACE_BOX coeffs_reqd = 6 @@ -255,13 +288,13 @@ contains coeffs_reqd = 3 case default message = "Invalid spatial distribution for external source: " & - // trim(source_ % space % type) + // trim(type) call fatal_error() end select ! Determine number of parameters specified - if (associated(source_ % space % parameters)) then - n = size(source_ % space % parameters) + if (check_for_node(node_dist, "parameters")) then + n = get_arraysize_double(node_dist, "parameters") else n = 0 end if @@ -277,19 +310,26 @@ contains call fatal_error() elseif (n > 0) then allocate(external_source % params_space(n)) - external_source % params_space = source_ % space % parameters + call get_node_array(node_dist, "parameters", & + external_source % params_space) end if else - message = "No spatial distribution specified for external source!" + message = "No spatial distribution specified for external source." call fatal_error() end if ! Determine external source angular distribution - if (source_ % angle % type /= '') then - ! Read type of angular distribution - type = source_ % angle % type + if (check_for_node(node_source, "angle")) then + + ! Get pointer to angular distribution + call get_node_ptr(node_source, "angle", node_dist) + + ! Check for type of angular distribution + type = '' + if (check_for_node(node_dist, "type")) & + call get_node_value(node_dist, "type", type) call lower_case(type) - select case (type) + select case (trim(type)) case ('isotropic') external_source % type_angle = SRC_ANGLE_ISOTROPIC coeffs_reqd = 0 @@ -300,13 +340,13 @@ contains external_source % type_angle = SRC_ANGLE_TABULAR case default message = "Invalid angular distribution for external source: " & - // trim(source_ % angle % type) + // trim(type) call fatal_error() end select ! Determine number of parameters specified - if (associated(source_ % angle % parameters)) then - n = size(source_ % angle % parameters) + if (check_for_node(node_dist, "parameters")) then + n = get_arraysize_double(node_dist, "parameters") else n = 0 end if @@ -322,7 +362,8 @@ contains call fatal_error() elseif (n > 0) then allocate(external_source % params_angle(n)) - external_source % params_angle = source_ % angle % parameters + call get_node_array(node_dist, "parameters", & + external_source % params_angle) end if else ! Set default angular distribution isotropic @@ -330,11 +371,17 @@ contains end if ! Determine external source energy distribution - if (source_ % energy % type /= '') then - ! Read type of energy distribution - type = source_ % energy % type + if (check_for_node(node_source, "energy")) then + + ! Get pointer to energy distribution + call get_node_ptr(node_source, "energy", node_dist) + + ! Check for type of energy distribution + type = '' + if (check_for_node(node_dist, "type")) & + call get_node_value(node_dist, "type", type) call lower_case(type) - select case (type) + select case (trim(type)) case ('monoenergetic') external_source % type_energy = SRC_ENERGY_MONO coeffs_reqd = 1 @@ -348,13 +395,13 @@ contains external_source % type_energy = SRC_ENERGY_TABULAR case default message = "Invalid energy distribution for external source: " & - // trim(source_ % energy % type) + // trim(type) call fatal_error() end select ! Determine number of parameters specified - if (associated(source_ % energy % parameters)) then - n = size(source_ % energy % parameters) + if (check_for_node(node_dist, "parameters")) then + n = get_arraysize_double(node_dist, "parameters") else n = 0 end if @@ -370,7 +417,8 @@ contains call fatal_error() elseif (n > 0) then allocate(external_source % params_energy(n)) - external_source % params_energy = source_ % energy % parameters + call get_node_array(node_dist, "parameters", & + external_source % params_energy) end if else ! Set default energy distribution to Watt fission spectrum @@ -381,33 +429,47 @@ contains end if ! Survival biasing - call lower_case(survival_) - if (survival_ == 'true' .or. survival_ == '1') survival_biasing = .true. + if (check_for_node(doc, "survival_biasing")) then + call get_node_value(doc, "survival_biasing", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') & + survival_biasing = .true. + end if ! Probability tables - call lower_case(ptables_) - if (ptables_ == 'false' .or. ptables_ == '0') urr_ptables_on = .false. + if (check_for_node(doc, "ptables")) then + call get_node_value(doc, "ptables", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'false' .or. trim(temp_str) == '0') & + urr_ptables_on = .false. + end if ! Cutoffs - if (size(cutoff_) > 0) then - weight_cutoff = cutoff_(1) % weight - weight_survive = cutoff_(1) % weight_avg + if (check_for_node(doc, "cutoff")) then + call get_node_ptr(doc, "cutoff", node_cutoff) + call get_node_value(node_cutoff, "weight", weight_cutoff) + call get_node_value(node_cutoff, "weight_avg", weight_survive) end if ! Particle trace - if (associated(trace_)) then - trace_batch = trace_(1) - trace_gen = trace_(2) - trace_particle = trace_(3) + if (check_for_node(doc, "trace")) then + call get_node_array(doc, "trace", temp_int_array3) + trace_batch = temp_int_array3(1) + trace_gen = temp_int_array3(2) + trace_particle = int(temp_int_array3(3), 8) end if ! Shannon Entropy mesh - if (size(entropy_) > 0) then + if (check_for_node(doc, "entropy")) then + + ! Get pointer to entropy node + call get_node_ptr(doc, "entropy", node_entropy) + ! Check to make sure enough values were supplied - if (size(entropy_(1) % lower_left) /= 3) then + if (get_arraysize_double(node_entropy, "lower_left") /= 3) then message = "Need to specify (x,y,z) coordinates of lower-left corner & &of Shannon entropy mesh." - elseif (size(entropy_(1) % upper_right) /= 3) then + elseif (get_arraysize_double(node_entropy, "upper_right") /= 3) then message = "Need to specify (x,y,z) coordinates of upper-right corner & &of Shannon entropy mesh." end if @@ -418,8 +480,10 @@ contains allocate(entropy_mesh % upper_right(3)) ! Copy values - entropy_mesh % lower_left = entropy_(1) % lower_left - entropy_mesh % upper_right = entropy_(1) % upper_right + call get_node_array(node_entropy, "lower_left", & + entropy_mesh % lower_left) + call get_node_array(node_entropy, "upper_right", & + entropy_mesh % upper_right) ! Check on values provided if (.not. all(entropy_mesh % upper_right > entropy_mesh % lower_left)) then @@ -430,10 +494,10 @@ contains ! Check if dimensions were specified -- if not, they will be calculated ! automatically upon first entry into shannon_entropy + if (check_for_node(node_entropy, "dimension")) then - if (associated(entropy_(1) % dimension)) then ! If so, make sure proper number of values were given - if (size(entropy_(1) % dimension) /= 3) then + if (get_arraysize_integer(node_entropy, "dimension") /= 3) then message = "Dimension of entropy mesh must be given as three & &integers." call fatal_error() @@ -444,7 +508,7 @@ contains allocate(entropy_mesh % dimension(3)) ! Copy dimensions - entropy_mesh % dimension = entropy_(1) % dimension + call get_node_array(node_entropy, "dimension", entropy_mesh % dimension) end if ! Turn on Shannon entropy calculation @@ -452,15 +516,19 @@ contains end if ! Uniform fission source weighting mesh - if (size(uniform_fs_) > 0) then + if (check_for_node(doc, "uniform_fs")) then + + ! Get pointer to ufs node + call get_node_ptr(doc, "uniform_fs", node_ufs) + ! Check to make sure enough values were supplied - if (size(uniform_fs_(1) % lower_left) /= 3) then + if (get_arraysize_double(node_ufs, "lower_left") /= 3) then message = "Need to specify (x,y,z) coordinates of lower-left corner & &of UFS mesh." - elseif (size(uniform_fs_(1) % upper_right) /= 3) then + elseif (get_arraysize_double(node_ufs, "upper_right") /= 3) then message = "Need to specify (x,y,z) coordinates of upper-right corner & &of UFS mesh." - elseif (size(uniform_fs_(1) % dimension) /= 3) then + elseif (get_arraysize_integer(node_ufs, "dimension") /= 3) then message = "Dimension of UFS mesh must be given as three integers." call fatal_error() end if @@ -476,11 +544,11 @@ contains allocate(ufs_mesh % dimension(3)) ! Copy dimensions - ufs_mesh % dimension = uniform_fs_(1) % dimension + call get_node_array(node_ufs, "dimension", ufs_mesh % dimension) ! Copy values - ufs_mesh % lower_left = uniform_fs_(1) % lower_left - ufs_mesh % upper_right = uniform_fs_(1) % upper_right + call get_node_array(node_ufs, "lower_left", ufs_mesh % lower_left) + call get_node_array(node_ufs, "upper_right", ufs_mesh % upper_right) ! Check on values provided if (.not. all(ufs_mesh % upper_right > ufs_mesh % lower_left)) then @@ -505,25 +573,32 @@ contains end if ! Check if the user has specified to write state points - if (size(state_point_) > 0) then + if (check_for_node(doc, "state_point")) then + + ! Get pointer to state_point node + call get_node_ptr(doc, "state_point", node_sp) + ! Determine number of batches at which to store state points - if (associated(state_point_(1) % batches)) then - n_state_points = size(state_point_(1) % batches) + if (check_for_node(node_sp, "batches")) then + n_state_points = get_arraysize_integer(node_sp, "batches") else n_state_points = 0 end if if (n_state_points > 0) then ! User gave specific batches to write state points + allocate(temp_int_array(n_state_points)) + call get_node_array(node_sp, "batches", temp_int_array) do i = 1, n_state_points - call statepoint_batch % add(state_point_(1) % batches(i)) + call statepoint_batch % add(temp_int_array(i)) end do - - elseif (state_point_(1) % interval /= 0) then + deallocate(temp_int_array) + elseif (check_for_node(node_sp, "interval")) then ! User gave an interval for writing state points - n_state_points = n_batches / state_point_(1) % interval + call get_node_value(node_sp, "interval", temp_int) + n_state_points = n_batches / temp_int do i = 1, n_state_points - call statepoint_batch % add(state_point_(1) % interval * i) + call statepoint_batch % add(temp_int * i) end do else ! If neither were specified, write state point at last batch @@ -538,25 +613,32 @@ contains end if ! Check if the user has specified to write state points - if (size(source_point_) > 0) then + if (check_for_node(doc, "source_point")) then + + ! Get pointer to source_point node + call get_node_ptr(doc, "source_point", node_sp) + ! Determine number of batches at which to store state points - if (associated(state_point_(1) % batches)) then - n_source_points = size(source_point_(1) % batches) + if (check_for_node(node_sp, "batches")) then + n_source_points = get_arraysize_integer(node_sp, "batches") else n_source_points = 0 end if if (n_source_points > 0) then ! User gave specific batches to write state points + allocate(temp_int_array(n_source_points)) + call get_node_array(node_sp, "batches", temp_int_array) do i = 1, n_source_points - call sourcepoint_batch % add(source_point_(1) % batches(i)) + call sourcepoint_batch % add(temp_int_array(i)) end do - - elseif (source_point_(1) % interval /= 0) then + deallocate(temp_int_array) + elseif (check_for_node(node_sp, "interval")) then ! User gave an interval for writing state points - n_source_points = n_batches / source_point_(1) % interval + call get_node_value(node_sp, "interval", temp_int) + n_source_points = n_batches / temp_int do i = 1, n_source_points - call sourcepoint_batch % add(source_point_(1) % interval * i) + call sourcepoint_batch % add(temp_int * i) end do else ! If neither were specified, write state point at last batch @@ -567,15 +649,24 @@ contains end if ! Check if the user has specified to write binary source file - call lower_case(source_point_(1) % source_separate) - call lower_case(source_point_(1) % source_write) - call lower_case(source_point_(1) % overwrite_latest) - if (source_point_(1) % source_separate == 'true' .or. & - source_point_(1) % source_separate == '1') source_separate = .true. - if (source_point_(1) % source_write == 'false' .or. & - source_point_(1) % source_write == '0') source_write = .false. - if (source_point_(1) % overwrite_latest == 'true' .or. & - source_point_(1) % overwrite_latest == '1') source_latest = .true. + if (check_for_node(node_sp, "source_separate")) then + call get_node_value(node_sp, "source_separate", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') source_separate = .true. + end if + if (check_for_node(node_sp, "source_write")) then + call get_node_value(node_sp, "source_write", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') source_separate = .true. + end if + if (check_for_node(node_sp, "overwrite_latest")) then + call get_node_value(node_sp, "overwrite_latest", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') source_latest = .true. + end if else ! If no tag was present, by default we keep source bank in ! statepoint file and write it out at statepoints intervals @@ -588,44 +679,71 @@ contains ! Check if the user has specified to not reduce tallies at the end of every ! batch - call lower_case(no_reduce_) - if (no_reduce_ == 'true' .or. no_reduce_ == '1') reduce_tallies = .false. + if (check_for_node(doc, "no_reduce")) then + call get_node_value(doc, "no_reduce", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') & + reduce_tallies = .false. + end if ! Check if the user has specified to use confidence intervals for ! uncertainties rather than standard deviations - call lower_case(confidence_intervals_) - if (confidence_intervals_ == 'true' .or. & - confidence_intervals_ == '1') confidence_intervals = .true. + if (check_for_node(doc, "confidence_intervals")) then + call get_node_value(doc, "confidence_intervals", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') confidence_intervals = .true. + end if ! Check for output options - if (associated(output_)) then - do i = 1, size(output_) - call lower_case(output_(i)) - select case (output_(i)) - case ('summary') - output_summary = .true. - case ('cross_sections') - output_xs = .true. - case ('tallies') - output_tallies = .true. - case ('none') - output_summary = .false. - output_xs = .false. - output_tallies = .false. - end select - end do + if (check_for_node(doc, "output")) then + + ! Get pointer to output node + call get_node_ptr(doc, "output", node_output) + + ! Check for summary option + if (check_for_node(node_output, "summary")) then + call get_node_value(node_output, "summary", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') output_summary = .true. + end if + + ! Check for cross sections option + if (check_for_node(node_output, "cross_sections")) then + call get_node_value(node_output, "cross_sections", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') output_xs = .true. + end if + + ! Check for ASCII tallies output option + if (check_for_node(node_output, "tallies")) then + call get_node_value(node_output, "tallies", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'false' .or. & + trim(temp_str) == '0') output_tallies = .false. + end if end if ! Check for cmfd run - call lower_case(run_cmfd_) - if (run_cmfd_ == 'true' .or. run_cmfd_ == '1') then - cmfd_run = .true. + if (check_for_node(doc, "run_cmfd")) then + call get_node_value(doc, "run_cmfd", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') then + cmfd_run = .true. #ifndef PETSC - message = 'CMFD is not available, recompile OpenMC with PETSc' - call fatal_error() + if (master) then + message = 'CMFD is not available, compile OpenMC with PETSc' + call fatal_error() + end if #endif + end if end if + ! Close settings XML file + call close_xmldoc(doc) + end subroutine read_settings_xml !=============================================================================== @@ -635,8 +753,6 @@ contains subroutine read_geometry_xml() - use xml_data_geometry_t - integer :: i, j, k, m integer :: n integer :: n_x, n_y, n_z @@ -644,6 +760,8 @@ contains integer :: n_cells_in_univ integer :: coeffs_reqd integer :: mid + integer :: temp_int_array3(3) + integer, allocatable :: temp_int_array(:) real(8) :: phi, theta, psi logical :: file_exists logical :: boundary_exists @@ -652,6 +770,13 @@ contains type(Cell), pointer :: c => null() type(Surface), pointer :: s => null() type(Lattice), pointer :: lat => null() + type(Node), pointer :: doc => null() + type(Node), pointer :: node_cell => null() + type(Node), pointer :: node_surf => null() + type(Node), pointer :: node_lat => null() + type(NodeList), pointer :: node_cell_list => null() + type(NodeList), pointer :: node_surf_list => null() + type(NodeList), pointer :: node_lat_list => null() ! Display output message message = "Reading geometry XML file..." @@ -669,10 +794,13 @@ contains end if ! Parse geometry.xml file - call read_xml_file_geometry_t(filename) + call open_xmldoc(doc, filename) + + ! Get pointer to list of XML + call get_node_list(doc, "cell", node_cell_list) ! Get number of tags - n_cells = size(cell_) + n_cells = get_list_size(node_cell_list) ! Check for no cells if (n_cells == 0) then @@ -692,10 +820,26 @@ contains do i = 1, n_cells c => cells(i) + ! Get pointer to i-th cell node + call get_list_item(node_cell_list, i, node_cell) + ! Copy data into cells - c % id = cell_(i) % id - c % universe = cell_(i) % universe - c % fill = cell_(i) % fill + if (check_for_node(node_cell, "id")) then + call get_node_value(node_cell, "id", c % id) + else + message = "Must specify id of cell in geometry XML file." + call fatal_error() + end if + if (check_for_node(node_cell, "universe")) then + call get_node_value(node_cell, "universe", c % universe) + else + c % universe = NONE + end if + if (check_for_node(node_cell, "fill")) then + call get_node_value(node_cell, "fill", c % fill) + else + c % fill = NONE + end if ! Check to make sure 'id' hasn't been used if (cell_dict % has_key(c % id)) then @@ -704,7 +848,9 @@ contains end if ! Read material - word = cell_(i) % material + word = '' + if (check_for_node(node_cell, "material")) & + call get_node_value(node_cell, "material", word) call lower_case(word) select case(word) case ('void') @@ -712,7 +858,7 @@ contains case ('') ! This case is called if no material was specified - c % material = 0 + c % material = NONE case default c % material = int(str_to_int(word), 4) @@ -739,20 +885,20 @@ contains end if ! Check to make sure that surfaces were specified - if (.not. associated(cell_(i) % surfaces)) then + if (.not. check_for_node(node_cell, "surfaces")) then message = "No surfaces specified for cell " // & trim(to_str(c % id)) call fatal_error() end if ! Allocate array for surfaces and copy - n = size(cell_(i) % surfaces) + n = get_arraysize_integer(node_cell, "surfaces") c % n_surfaces = n allocate(c % surfaces(n)) - c % surfaces = cell_(i) % surfaces + call get_node_array(node_cell, "surfaces", c % surfaces) ! Rotation matrix - if (associated(cell_(i) % rotation)) then + if (check_for_node(node_cell, "rotation")) then ! Rotations can only be applied to cells that are being filled with ! another universe if (c % fill == NONE) then @@ -762,7 +908,7 @@ contains end if ! Read number of rotation parameters - n = size(cell_(i) % rotation) + n = get_arraysize_double(node_cell, "rotation") if (n /= 3) then message = "Incorrect number of rotation parameters on cell " // & to_str(c % id) @@ -770,9 +916,10 @@ contains end if ! Copy rotation angles in x,y,z directions - phi = -cell_(i) % rotation(1) * PI/180.0 - theta = -cell_(i) % rotation(2) * PI/180.0 - psi = -cell_(i) % rotation(3) * PI/180.0 + call get_node_array(node_cell, "rotation", temp_int_array3) + phi = -temp_int_array3(1) * PI/180.0_8 + theta = -temp_int_array3(2) * PI/180.0_8 + psi = -temp_int_array3(3) * PI/180.0_8 ! Calculate rotation matrix based on angles given allocate(c % rotation(3,3)) @@ -787,7 +934,7 @@ contains end if ! Translation vector - if (associated(cell_(i) % translation)) then + if (check_for_node(node_cell, "translation")) then ! Translations can only be applied to cells that are being filled with ! another universe if (c % fill == NONE) then @@ -797,7 +944,7 @@ contains end if ! Read number of translation parameters - n = size(cell_(i) % translation) + n = get_arraysize_double(node_cell, "translation") if (n /= 3) then message = "Incorrect number of translation parameters on cell " & // to_str(c % id) @@ -806,7 +953,7 @@ contains ! Copy translation vector allocate(c % translation(3)) - c % translation = cell_(i) % translation + call get_node_array(node_cell, "translation", c % translation) end if ! Add cell to dictionary @@ -815,7 +962,7 @@ contains ! For cells, we also need to check if there's a new universe -- ! also for every cell add 1 to the count of cells for the ! specified universe - universe_num = cell_(i) % universe + universe_num = c % universe if (.not. cells_in_univ_dict % has_key(universe_num)) then n_universes = n_universes + 1 n_cells_in_univ = 1 @@ -834,8 +981,11 @@ contains ! applied to a surface boundary_exists = .false. + ! get pointer to list of xml + call get_node_list(doc, "surface", node_surf_list) + ! Get number of tags - n_surfaces = size(surface_) + n_surfaces = get_list_size(node_surf_list) ! Check for no surfaces if (n_surfaces == 0) then @@ -849,8 +999,16 @@ contains do i = 1, n_surfaces s => surfaces(i) + ! Get pointer to i-th surface node + call get_list_item(node_surf_list, i, node_surf) + ! Copy data into cells - s % id = surface_(i) % id + if (check_for_node(node_surf, "id")) then + call get_node_value(node_surf, "id", s % id) + else + message = "Must specify id of surface in geometry XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (surface_dict % has_key(s % id)) then @@ -860,7 +1018,9 @@ contains end if ! Copy and interpret surface type - word = surface_(i) % type + word = '' + if (check_for_node(node_surf, "type")) & + call get_node_value(node_surf, "type", word) call lower_case(word) select case(trim(word)) case ('x-plane') @@ -897,7 +1057,7 @@ contains s % type = SURF_CONE_Z coeffs_reqd = 4 case default - message = "Invalid surface type: " // trim(surface_(i) % type) + message = "Invalid surface type: " // trim(word) call fatal_error() end select @@ -905,7 +1065,7 @@ contains ! have been specified for the given type of surface. Then copy ! surface coordinates. - n = size(surface_(i) % coeffs) + n = get_arraysize_double(node_surf, "coeffs") if (n < coeffs_reqd) then message = "Not enough coefficients specified for surface: " // & trim(to_str(s % id)) @@ -916,11 +1076,13 @@ contains call fatal_error() else allocate(s % coeffs(n)) - s % coeffs = surface_(i) % coeffs + call get_node_array(node_surf, "coeffs", s % coeffs) end if ! Boundary conditions - word = surface_(i) % boundary + word = '' + if (check_for_node(node_surf, "boundary")) & + call get_node_value(node_surf, "boundary", word) call lower_case(word) select case (trim(word)) case ('transmission', 'transmit', '') @@ -952,15 +1114,26 @@ contains ! ========================================================================== ! READ LATTICES FROM GEOMETRY.XML + ! Get pointer to list of XML + call get_node_list(doc, "lattice", node_lat_list) + ! Allocate lattices array - n_lattices = size(lattice_) + n_lattices = get_list_size(node_lat_list) allocate(lattices(n_lattices)) do i = 1, n_lattices lat => lattices(i) + ! Get pointer to i-th lattice + call get_list_item(node_lat_list, i, node_lat) + ! ID of lattice - lat % id = lattice_(i) % id + if (check_for_node(node_lat, "id")) then + call get_node_value(node_lat, "id", lat % id) + else + message = "Must specify id of lattice in geometry XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (lattice_dict % has_key(lat % id)) then @@ -970,7 +1143,9 @@ contains end if ! Read lattice type - word = lattice_(i) % type + word = '' + if (check_for_node(node_lat, "type")) & + call get_node_value(node_lat, "type", word) call lower_case(word) select case (trim(word)) case ('rect', 'rectangle', 'rectangular') @@ -978,12 +1153,12 @@ contains case ('hex', 'hexagon', 'hexagonal') lat % type = LATTICE_HEX case default - message = "Invalid lattice type: " // trim(lattice_(i) % type) + message = "Invalid lattice type: " // trim(word) call fatal_error() end select ! Read number of lattice cells in each dimension - n = size(lattice_(i) % dimension) + n = get_arraysize_integer(node_lat, "dimension") if (n /= 2 .and. n /= 3) then message = "Lattice must be two or three dimensions." call fatal_error() @@ -991,27 +1166,29 @@ contains lat % n_dimension = n allocate(lat % dimension(n)) - lat % dimension = lattice_(i) % dimension + call get_node_array(node_lat, "dimension", lat % dimension) ! Read lattice lower-left location - if (size(lattice_(i) % dimension) /= size(lattice_(i) % lower_left)) then + if (size(lat % dimension) /= & + get_arraysize_double(node_lat, "lower_left")) then message = "Number of entries on must be the same as & &the number of entries on ." call fatal_error() end if allocate(lat % lower_left(n)) - lat % lower_left = lattice_(i) % lower_left + call get_node_array(node_lat, "lower_left", lat % lower_left) ! Read lattice widths - if (size(lattice_(i) % width) /= size(lattice_(i) % lower_left)) then + if (size(lat % dimension) /= & + get_arraysize_double(node_lat, "width")) then message = "Number of entries on must be the same as & &the number of entries on ." call fatal_error() end if allocate(lat % width(n)) - lat % width = lattice_(i) % width + call get_node_array(node_lat, "width", lat % width) ! Copy number of dimensions n_x = lat % dimension(1) @@ -1024,28 +1201,36 @@ contains allocate(lat % universes(n_x, n_y, n_z)) ! Check that number of universes matches size - if (size(lattice_(i) % universes) /= n_x*n_y*n_z) then + n = get_arraysize_integer(node_lat, "universes") + if (n /= n_x*n_y*n_z) then message = "Number of universes on does not match size of & &lattice " // trim(to_str(lat % id)) // "." call fatal_error() end if + allocate(temp_int_array(n)) + call get_node_array(node_lat, "universes", temp_int_array) + ! Read universes do m = 1, n_z do k = 0, n_y - 1 do j = 1, n_x - lat % universes(j, n_y - k, m) = lattice_(i) % & - universes(j + n_x*k + n_x*n_y*(m-1)) + lat % universes(j, n_y - k, m) = & + temp_int_array(j + n_x*k + n_x*n_y*(m-1)) end do end do end do + deallocate(temp_int_array) ! Read material for area outside lattice - mid = lattice_(i) % outside - if (mid == 0 .or. mid == MATERIAL_VOID) then - lat % outside = MATERIAL_VOID - else - lat % outside = mid + lat % outside = MATERIAL_VOID + if (check_for_node(node_lat, "outside")) then + call get_node_value(node_lat, "outside", mid) + if (mid == 0 .or. mid == MATERIAL_VOID) then + lat % outside = MATERIAL_VOID + else + lat % outside = mid + end if end if ! Add lattice to dictionary @@ -1053,6 +1238,9 @@ contains end do + ! Close geometry XML file + call close_xmldoc(doc) + end subroutine read_geometry_xml !=============================================================================== @@ -1060,9 +1248,7 @@ contains ! for errors and placing properly-formatted data in the right data structures !=============================================================================== - subroutine read_materials_xml - - use xml_data_materials_t + subroutine read_materials_xml() integer :: i ! loop index for materials integer :: j ! loop index for nuclides @@ -1072,17 +1258,27 @@ contains integer :: index_nuclide ! index in nuclides integer :: index_sab ! index in sab_tables real(8) :: val ! value entered for density + real(8) :: temp_dble ! temporary double prec. real logical :: file_exists ! does materials.xml exist? logical :: sum_density ! density is taken to be sum of nuclide densities character(12) :: name ! name of isotope, e.g. 92235.03c character(12) :: alias ! alias of nuclide, e.g. U-235.03c character(MAX_WORD_LEN) :: units ! units on density character(MAX_LINE_LEN) :: filename ! absolute path to materials.xml + character(MAX_LINE_LEN) :: temp_str ! temporary string when reading type(ListChar) :: list_names ! temporary list of nuclide names type(ListReal) :: list_density ! temporary list of nuclide densities type(Material), pointer :: mat => null() - type(nuclide_xml), pointer :: nuc => null() - type(sab_xml), pointer :: sab => null() + type(Node), pointer :: doc => null() + type(Node), pointer :: node_mat => null() + type(Node), pointer :: node_dens => null() + type(Node), pointer :: node_nuc => null() + type(Node), pointer :: node_ele => null() + type(Node), pointer :: node_sab => null() + type(NodeList), pointer :: node_mat_list => null() + type(NodeList), pointer :: node_nuc_list => null() + type(NodeList), pointer :: node_ele_list => null() + type(NodeList), pointer :: node_sab_list => null() ! Display output message message = "Reading materials XML file..." @@ -1097,16 +1293,20 @@ contains end if ! Initialize default cross section variable - default_xs_ = "" + default_xs = "" ! Parse materials.xml file - call read_xml_file_materials_t(filename) + call open_xmldoc(doc, filename) ! Copy default cross section if present - default_xs = default_xs_ + if (check_for_node(doc, "default_xs")) & + call get_node_value(doc, "default_xs", default_xs) + + ! Get pointer to list of XML + call get_node_list(doc, "material", node_mat_list) ! Allocate cells array - n_materials = size(material_) + n_materials = get_list_size(node_mat_list) allocate(materials(n_materials)) ! Initialize count for number of nuclides/S(a,b) tables @@ -1116,8 +1316,16 @@ contains do i = 1, n_materials mat => materials(i) + ! Get pointer to i-th material node + call get_list_item(node_mat_list, i, node_mat) + ! Copy material id - mat % id = material_(i) % id + if (check_for_node(node_mat, "id")) then + call get_node_value(node_mat, "id", mat % id) + else + message = "Must specify id of material in materials XML file" + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (material_dict % has_key(mat % id)) then @@ -1135,9 +1343,20 @@ contains ! ======================================================================= ! READ AND PARSE TAG - ! Copy value and units - val = material_(i) % density % value - units = material_(i) % density % units + ! Get pointer to density element + if (check_for_node(node_mat, "density")) then + call get_node_ptr(node_mat, "density", node_dens) + else + message = "Must specify density element in material " // & + trim(to_str(mat % id)) + call fatal_error() + end if + + ! Initialize value to zero + val = ZERO + + ! Copy units + call get_node_value(node_dens, "units", units) if (units == 'sum') then ! If the user gave the units as 'sum', then the total density of the @@ -1147,6 +1366,9 @@ contains sum_density = .true. else + ! Copy value + call get_node_value(node_dens, "value", val) + ! Check for erroneous density sum_density = .false. if (val <= ZERO) then @@ -1167,7 +1389,7 @@ contains case ('atom/cm3', 'atom/cc') mat % density = 1.0e-24 * val case default - message = "Unkwown units '" // trim(material_(i) % density % units) & + message = "Unkwown units '" // trim(units) & // "' specified on material " // trim(to_str(mat % id)) call fatal_error() end select @@ -1177,101 +1399,118 @@ contains ! READ AND PARSE TAGS ! Check to ensure material has at least one nuclide - if (.not. associated(material_(i) % nuclides) .and. & - .not. associated(material_(i) % elements)) then + if (.not. check_for_node(node_mat, "nuclide") .and. & + .not. check_for_node(node_mat, "element")) then message = "No nuclides or natural elements specified on material " // & trim(to_str(mat % id)) call fatal_error() end if + ! Get pointer list of XML + call get_node_list(node_mat, "nuclide", node_nuc_list) + ! Create list of nuclides based on those specified plus natural elements - INDIVIDUAL_NUCLIDES: do j = 1, size(material_(i) % nuclides) + INDIVIDUAL_NUCLIDES: do j = 1, get_list_size(node_nuc_list) ! Combine nuclide identifier and cross section and copy into names - nuc => material_(i) % nuclides(j) + call get_list_item(node_nuc_list, j, node_nuc) ! Check for empty name on nuclide - if (len_trim(nuc % name) == 0) then + if (.not.check_for_node(node_nuc, "name")) then message = "No name specified on nuclide in material " // & trim(to_str(mat % id)) call fatal_error() end if ! Check for cross section - if (len_trim(nuc % xs) == 0) then + if (.not.check_for_node(node_nuc, "xs")) then if (default_xs == '') then message = "No cross section specified for nuclide in material " & // trim(to_str(mat % id)) call fatal_error() else - nuc % xs = default_xs + name = trim(default_xs) end if end if ! store full name - name = trim(nuc % name) // "." // trim(nuc % xs) + call get_node_value(node_nuc, "name", temp_str) + if (check_for_node(node_nuc, "xs")) & + call get_node_value(node_nuc, "xs", name) + name = trim(temp_str) // "." // trim(name) ! save name and density to list call list_names % append(name) ! Check if no atom/weight percents were specified or if both atom and ! weight percents were specified - if (nuc % ao == ZERO .and. nuc % wo == ZERO) then + if (.not.check_for_node(node_nuc, "ao") .and. & + .not.check_for_node(node_nuc, "wo")) then message = "No atom or weight percent specified for nuclide " // & trim(name) call fatal_error() - elseif (nuc % ao /= ZERO .and. nuc % wo /= ZERO) then + elseif (check_for_node(node_nuc, "ao") .and. & + check_for_node(node_nuc, "wo")) then message = "Cannot specify both atom and weight percents for a & &nuclide: " // trim(name) call fatal_error() end if ! Copy atom/weight percents - if (nuc % ao /= ZERO) then - call list_density % append(nuc % ao) + if (check_for_node(node_nuc, "ao")) then + call get_node_value(node_nuc, "ao", temp_dble) + call list_density % append(temp_dble) else - call list_density % append(-nuc % wo) + call get_node_value(node_nuc, "wo", temp_dble) + call list_density % append(-temp_dble) end if end do INDIVIDUAL_NUCLIDES ! ======================================================================= ! READ AND PARSE TAGS - NATURAL_ELEMENTS: do j = 1, size(material_(i) % elements) - nuc => material_(i) % elements(j) + ! Get pointer list of XML + call get_node_list(node_mat, "element", node_ele_list) + + NATURAL_ELEMENTS: do j = 1, get_list_size(node_ele_list) + call get_list_item(node_ele_list, j, node_ele) ! Check for empty name on natural element - if (len_trim(nuc % name) == 0) then + if (.not.check_for_node(node_ele, "name")) then message = "No name specified on nuclide in material " // & trim(to_str(mat % id)) call fatal_error() end if + call get_node_value(node_ele, "name", name) ! Check for cross section - if (len_trim(nuc % xs) == 0) then + if (.not.check_for_node(node_ele, "xs")) then if (default_xs == '') then message = "No cross section specified for nuclide in material " & // trim(to_str(mat % id)) call fatal_error() else - nuc % xs = default_xs + temp_str = trim(default_xs) end if end if ! Check if no atom/weight percents were specified or if both atom and ! weight percents were specified - if (nuc % ao == ZERO .and. nuc % wo == ZERO) then - message = "No atom or weight percent specified for nuclide " // & + if (.not.check_for_node(node_ele, "ao") .and. & + .not.check_for_node(node_ele, "wo")) then + message = "No atom or weight percent specified for element " // & trim(name) call fatal_error() - elseif (nuc % ao /= ZERO .and. nuc % wo /= ZERO) then + elseif (check_for_node(node_ele, "ao") .and. & + check_for_node(node_ele, "wo")) then message = "Cannot specify both atom and weight percents for a & - &nuclide: " // trim(name) + &element: " // trim(name) call fatal_error() end if ! Expand element into naturally-occurring isotopes - if (nuc % ao /= ZERO) then - call expand_natural_element(nuc % name, nuc % xs, nuc % ao, & + if (check_for_node(node_ele, "ao")) then + call get_node_value(node_ele, "ao", temp_dble) + call expand_natural_element(name, temp_str, temp_dble, & list_names, list_density) else message = "The ability to expand a natural element based on weight & @@ -1292,7 +1531,7 @@ contains ALL_NUCLIDES: do j = 1, mat % n_nuclides ! Check that this nuclide is listed in the cross_sections.xml file - name = list_names % get_item(j) + name = trim(list_names % get_item(j)) if (.not. xs_listing_dict % has_key(name)) then message = "Could not find nuclide " // trim(name) // & " in cross_sections.xml file!" @@ -1348,7 +1587,10 @@ contains ! ======================================================================= ! READ AND PARSE TAG FOR S(a,b) DATA - n_sab = size(material_(i) % sab) + ! Get pointer list to XML + call get_node_list(node_mat, "sab", node_sab_list) + + n_sab = get_list_size(node_sab_list) if (n_sab > 0) then ! Set number of S(a,b) tables mat % n_sab = n_sab @@ -1363,10 +1605,17 @@ contains do j = 1, n_sab ! Get pointer to S(a,b) table - sab => material_(i) % sab(j) + call get_list_item(node_sab_list, j, node_sab) ! Determine name of S(a,b) table - name = trim(sab % name) // "." // trim(sab % xs) + if (.not.check_for_node(node_sab, "name") .or. & + .not.check_for_node(node_sab, "xs")) then + message = "Need to specify and for S(a,b) table." + call fatal_error() + end if + call get_node_value(node_sab, "name", name) + call get_node_value(node_sab, "xs", temp_str) + name = trim(name) // "." // trim(temp_str) mat % sab_names(j) = name ! Check that this nuclide is listed in the cross_sections.xml file @@ -1380,16 +1629,13 @@ contains ! listing index_list = xs_listing_dict % get_key(name) name = xs_listings(index_list) % name - alias = xs_listings(index_list) % alias ! If this S(a,b) table hasn't been encountered yet, we need to add its ! name and alias to the sab_dict if (.not. sab_dict % has_key(name)) then - index_sab = index_sab + 1 + index_sab = index_sab + 1 mat % i_sab_tables(j) = index_sab - call sab_dict % add_key(name, index_sab) - call sab_dict % add_key(alias, index_sab) else mat % i_sab_tables(j) = sab_dict % get_key(name) end if @@ -1404,6 +1650,9 @@ contains n_nuclides_total = index_nuclide n_sab_tables = index_sab + ! Close materials XML file + call close_xmldoc(doc) + end subroutine read_materials_xml !=============================================================================== @@ -1411,9 +1660,7 @@ contains ! for errors and placing properly-formatted data in the right data structures !=============================================================================== - subroutine read_tallies_xml - - use xml_data_tallies_t + subroutine read_tallies_xml() integer :: i ! loop over user-specified tallies integer :: j ! loop over words @@ -1429,14 +1676,25 @@ contains integer :: n_order ! Scattering order requested integer :: n_order_pos ! Position of Scattering order in score name string integer :: MT ! user-specified MT for score + integer :: iarray3(3) ! temporary integer array logical :: file_exists ! does tallies.xml file exist? + real(8) :: rarray3(3) ! temporary double prec. array character(MAX_LINE_LEN) :: filename character(MAX_WORD_LEN) :: word character(MAX_WORD_LEN) :: score_name + character(MAX_WORD_LEN) :: temp_str + character(MAX_WORD_LEN), allocatable :: sarray(:) type(ElemKeyValueCI), pointer :: pair_list => null() type(TallyObject), pointer :: t => null() type(StructuredMesh), pointer :: m => null() type(TallyFilter), allocatable :: filters(:) ! temporary filters + type(Node), pointer :: doc => null() + type(Node), pointer :: node_mesh => null() + type(Node), pointer :: node_tal => null() + type(Node), pointer :: node_filt => null() + type(NodeList), pointer :: node_mesh_list => null() + type(NodeList), pointer :: node_tal_list => null() + type(NodeList), pointer :: node_filt_list => null() ! Check if tallies.xml exists filename = trim(path_input) // "tallies.xml" @@ -1451,33 +1709,33 @@ contains call write_message(5) ! Parse tallies.xml file - call read_xml_file_tallies_t(filename) + call open_xmldoc(doc, filename) ! ========================================================================== ! DETERMINE SIZE OF ARRAYS AND ALLOCATE + ! Get pointer list to XML + call get_node_list(doc, "mesh", node_mesh_list) + + ! Get pointer list to XML + call get_node_list(doc, "tally", node_tal_list) + ! Check for user meshes - if (.not. associated(mesh_)) then - n_user_meshes = 0 + n_user_meshes = get_list_size(node_mesh_list) + if (cmfd_run) then + n_meshes = n_user_meshes + n_cmfd_meshes else - n_user_meshes = size(mesh_) - if (cmfd_run) then - n_meshes = n_user_meshes + n_cmfd_meshes - else - n_meshes = n_user_meshes - end if + n_meshes = n_user_meshes end if ! Allocate mesh array if (n_meshes > 0) allocate(meshes(n_meshes)) ! Check for user tallies - if (.not. associated(tally_)) then - n_user_tallies = 0 + n_user_tallies = get_list_size(node_tal_list) + if (n_user_tallies == 0) then message = "No tallies present in tallies.xml file!" call warning() - else - n_user_tallies = size(tally_) end if ! Allocate tally array @@ -1486,8 +1744,12 @@ contains end if ! Check for setting - call lower_case(separate_) - if (separate_ == 'true' .or. separate_ == '1') assume_separate = .true. + if (check_for_node(doc, "assume_separate")) then + call get_node_value(doc, "assume_separate", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') & + assume_separate = .true. + end if ! ========================================================================== ! READ MESH DATA @@ -1495,8 +1757,16 @@ contains do i = 1, n_user_meshes m => meshes(i) - ! copy mesh id - m % id = mesh_(i) % id + ! Get pointer to mesh node + call get_list_item(node_mesh_list, i, node_mesh) + + ! Copy mesh id + if (check_for_node(node_mesh, "id")) then + call get_node_value(node_mesh, "id", m % id) + else + message = "Must specify id for mesh in tally XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (mesh_dict % has_key(m % id)) then @@ -1506,19 +1776,22 @@ contains end if ! Read mesh type - call lower_case(mesh_(i) % type) - select case (mesh_(i) % type) + temp_str = '' + if (check_for_node(node_mesh, "type")) & + call get_node_value(node_mesh, "type", temp_str) + call lower_case(temp_str) + select case (trim(temp_str)) case ('rect', 'rectangle', 'rectangular') m % type = LATTICE_RECT case ('hex', 'hexagon', 'hexagonal') m % type = LATTICE_HEX case default - message = "Invalid mesh type: " // trim(mesh_(i) % type) + message = "Invalid mesh type: " // trim(temp_str) call fatal_error() end select ! Determine number of dimensions for mesh - n = size(mesh_(i) % 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() @@ -1532,74 +1805,79 @@ contains allocate(m % upper_right(n)) ! Check that dimensions are all greater than zero - if (any(mesh_(i) % dimension <= 0)) then + call get_node_array(node_mesh, "dimension", iarray3(1:n)) + if (any(iarray3(1:n) <= 0)) then message = "All entries on the element for a tally mesh & &must be positive." call fatal_error() end if ! Read dimensions in each direction - m % dimension = mesh_(i) % dimension + m % dimension = iarray3(1:n) ! Read mesh lower-left corner location - if (m % n_dimension /= size(mesh_(i) % lower_left)) then + if (m % n_dimension /= get_arraysize_double(node_mesh, "lower_left")) then message = "Number of entries on must be the same as & &the number of entries on ." call fatal_error() end if - m % lower_left = mesh_(i) % 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_(i) % upper_right) .and. & - associated(mesh_(i) % width)) then + ! 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 and on a & &tally mesh." call fatal_error() end if ! Make sure either upper-right or width was specified - if (.not. associated(mesh_(i) % upper_right) .and. & - .not. associated(mesh_(i) % width)) then + if (.not.check_for_node(node_mesh, "upper_right") .and. & + .not.check_for_node(node_mesh, "width")) then message = "Must specify either and on a & &tally mesh." call fatal_error() end if - if (associated(mesh_(i) % width)) then + if (check_for_node(node_mesh, "width")) then ! Check to ensure width has same dimensions - if (size(mesh_(i) % width) /= size(mesh_(i) % lower_left)) then + if (get_arraysize_double(node_mesh, "width") /= & + get_arraysize_double(node_mesh, "lower_left")) then message = "Number of entries on must be the same as the & &number of entries on ." call fatal_error() end if ! Check for negative widths - if (any(mesh_(i) % width < ZERO)) then + call get_node_array(node_mesh, "width", rarray3(1:n)) + if (any(rarray3(1:n) < ZERO)) then message = "Cannot have a negative on a tally mesh." call fatal_error() end if ! Set width and upper right coordinate - m % width = mesh_(i) % width + m % width = rarray3(1:n) m % upper_right = m % lower_left + m % dimension * m % width - elseif (associated(mesh_(i) % upper_right)) then + elseif (check_for_node(node_mesh, "upper_right")) then ! Check to ensure width has same dimensions - if (size(mesh_(i) % upper_right) /= size(mesh_(i) % lower_left)) then + if (get_arraysize_double(node_mesh, "upper_right") /= & + get_arraysize_double(node_mesh, "lower_left")) then message = "Number of entries on must be the same as & &the number of entries on ." call fatal_error() end if ! Check that upper-right is above lower-left - if (any(mesh_(i) % upper_right < mesh_(i) % lower_left)) then + call get_node_array(node_mesh, "upper_right", rarray3(1:n)) + if (any(rarray3(1:n) < m % lower_left)) then message = "The coordinates must be greater than the & & coordinates on a tally mesh." call fatal_error() end if ! Set width and upper right coordinate - m % upper_right = mesh_(i) % upper_right + m % upper_right = rarray3(1:n) m % width = (m % upper_right - m % lower_left) / m % dimension end if @@ -1617,6 +1895,9 @@ contains ! Get pointer to tally t => tallies(i) + ! Get pointer to tally xml node + call get_list_item(node_tal_list, i, node_tal) + ! Set tally type to volume by default t % type = TALLY_VOLUME @@ -1629,7 +1910,12 @@ contains t % estimator = ESTIMATOR_TRACKLENGTH ! Copy material id - t % id = tally_(i) % id + if (check_for_node(node_tal, "id")) then + call get_node_value(node_tal, "id", t % id) + else + message = "Must specify id for tally in tally XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (tally_dict % has_key(t % id)) then @@ -1639,7 +1925,9 @@ contains end if ! Copy tally label - t % label = tally_(i) % label + t % label = '' + if (check_for_node(node_tal, "label")) & + call get_node_value(node_tal, "label", t % label) ! ======================================================================= ! READ DATA FOR FILTERS @@ -1648,29 +1936,47 @@ contains ! element followed by sub-elements , , etc. This checks for ! the old format and if it is present, raises an error - if (size(tally_(i) % filters) > 0) then - message = "Tally filters should be specified with multiple & - &elements. Did you forget to change your element?" - call fatal_error() - end if +! if (get_number_nodes(node_tal, "filters") > 0) then +! message = "Tally filters should be specified with multiple & +! &elements. Did you forget to change your element?" +! call fatal_error() +! end if - if (associated(tally_(i) % filter)) then - ! Determine number of filters - n_filters = size(tally_(i) % filter) + ! Get pointer list to XML and get number of filters + call get_node_list(node_tal, "filter", node_filt_list) + n_filters = get_list_size(node_filt_list) + + if (n_filters /= 0) then ! Allocate filters array t % n_filters = n_filters allocate(t % filters(n_filters)) READ_FILTERS: do j = 1, n_filters + ! Get pointer to filter xml node + call get_list_item(node_filt_list, j, node_filt) + ! Convert filter type to lower case - call lower_case(tally_(i) % filter(j) % type) + temp_str = '' + if (check_for_node(node_filt, "type")) & + call get_node_value(node_filt, "type", temp_str) + call lower_case(temp_str) ! Determine number of bins - n_words = size(tally_(i) % filter(j) % bins) + if (check_for_node(node_filt, "bins")) then + if (trim(temp_str) == 'energy' .or. & + trim(temp_str) == 'energyout') then + n_words = get_arraysize_double(node_filt, "bins") + else + n_words = get_arraysize_integer(node_filt, "bins") + end if + else + message = "Bins not set in filter on tally " // trim(to_str(t % id)) + call fatal_error() + end if ! Determine type of filter - select case (tally_(i) % filter(j) % type) + select case (temp_str) case ('cell') ! Set type of filter t % filters(j) % type = FILTER_CELL @@ -1680,10 +1986,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('cellborn') ! Set type of filter @@ -1694,10 +1997,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('material') ! Set type of filter @@ -1708,10 +2008,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('universe') ! Set type of filter @@ -1722,10 +2019,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('surface') message = "Surface filter is not yet supported!" @@ -1739,10 +2033,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('mesh') ! Set type of filter @@ -1755,7 +2046,7 @@ contains end if ! Determine id of mesh - id = int(str_to_int(tally_(i) % filter(j) % bins(1)),4) + call get_node_value(node_filt, "bins", id) ! Get pointer to mesh if (mesh_dict % has_key(id)) then @@ -1785,10 +2076,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % real_bins(n_words)) - do k = 1, n_words - t % filters(j) % real_bins(k) = str_to_real(& - tally_(i) % filter(j) % bins(k)) - end do + call get_node_array(node_filt, "bins", t % filters(j) % real_bins) case ('energyout') ! Set type of filter @@ -1799,18 +2087,15 @@ contains ! Allocate and store bins allocate(t % filters(j) % real_bins(n_words)) - do k = 1, n_words - t % filters(j) % real_bins(k) = str_to_real(& - tally_(i) % filter(j) % bins(k)) - end do + call get_node_array(node_filt, "bins", t % filters(j) % real_bins) ! Set to analog estimator t % estimator = ESTIMATOR_ANALOG case default ! Specified tally filter is invalid, raise error - message = "Unknown filter type '" // trim(tally_(i) % & - filter(j) % type) // "' on tally " // & + message = "Unknown filter type '" // & + trim(temp_str) // "' on tally " // & trim(to_str(t % id)) // "." call fatal_error() @@ -1839,8 +2124,13 @@ contains ! ======================================================================= ! READ DATA FOR NUCLIDES - if (associated(tally_(i) % nuclides)) then - if (tally_(i) % nuclides(1) == 'all') then + if (check_for_node(node_tal, "nuclides")) then + + ! Allocate a temporary string array for nuclides and copy values over + allocate(sarray(get_arraysize_string(node_tal, "nuclides"))) + call get_node_array(node_tal, "nuclides", sarray) + + if (trim(sarray(1)) == 'all') then ! Handle special case all allocate(t % nuclide_bins(n_nuclides_total + 1)) @@ -1856,25 +2146,25 @@ contains t % all_nuclides = .true. else ! Any other case, e.g. U-235 Pu-239 - n_words = size(tally_(i) % nuclides) + n_words = get_arraysize_string(node_tal, "nuclides") allocate(t % nuclide_bins(n_words)) do j = 1, n_words ! Check if total material was specified - if (tally_(i) % nuclides(j) == 'total') then + if (trim(sarray(j)) == 'total') then t % nuclide_bins(j) = -1 cycle end if ! Check if xs specifier was given - if (ends_with(tally_(i) % nuclides(j), 'c')) then - word = tally_(i) % nuclides(j) + if (ends_with(sarray(j), 'c')) then + word = sarray(j) else if (default_xs == '') then ! No default cross section specified, search through nuclides pair_list => nuclide_dict % keys() do while (associated(pair_list)) if (starts_with(pair_list % key, & - tally_(i) % nuclides(j))) then + sarray(j))) then word = pair_list % key(1:150) exit end if @@ -1886,14 +2176,14 @@ contains ! Check if no nuclide was found if (.not. associated(pair_list)) then message = "Could not find the nuclide " // trim(& - tally_(i) % nuclides(j)) // " specified in tally " & + sarray(j)) // " specified in tally " & // trim(to_str(t % id)) // " in any material." call fatal_error() end if deallocate(pair_list) else ! Set nuclide to default xs - word = trim(tally_(i) % nuclides(j)) // "." // default_xs + word = trim(sarray(j)) // "." // default_xs end if end if @@ -1912,6 +2202,9 @@ contains t % n_nuclide_bins = n_words end if + ! Deallocate temporary string array + deallocate(sarray) + else ! No were specified -- create only one bin will be added ! for the total material. @@ -1923,18 +2216,20 @@ contains ! ======================================================================= ! READ DATA FOR SCORES - if (associated(tally_(i) % scores)) then + if (check_for_node(node_tal, "scores")) then ! Loop through scores and determine if a scatter-p# input was used ! to allow for proper pre-allocating of t % score_bins ! This scheme allows multiple scatter-p# to be requested by the user ! if so desired - n_words = size(tally_(i) % scores) + n_words = get_arraysize_string(node_tal, "scores") + allocate(sarray(n_words)) + call get_node_array(node_tal, "scores", sarray) n_new = 0 do j = 1, n_words - call lower_case(tally_(i) % scores(j)) + call lower_case(sarray(j)) ! Find if scores(j) is of the form 'scatter-p' ! If so, get the number and do a select case on that. - score_name = tally_(i) % scores(j) + score_name = trim(sarray(j)) if (starts_with(score_name,'scatter-p')) then n_order_pos = scan(score_name,'0123456789') n_order = int(str_to_int( & @@ -1947,7 +2242,7 @@ contains trim(to_str(SCATT_ORDER_MAX)) call warning() n_order = SCATT_ORDER_MAX - tally_(i) % scores(j) = SCATT_ORDER_MAX_PNSTR + sarray(j) = SCATT_ORDER_MAX_PNSTR end if n_new = n_new + n_order end if @@ -1964,7 +2259,7 @@ contains ! Get the input string in scores(l) but if scatter-n or scatter-pn ! then strip off the n, and store it as an integer to be used later ! Peform the select case on this modified (number removed) string - score_name = tally_(i) % scores(l) + score_name = sarray(l) if (starts_with(score_name,'scatter-p')) then n_order_pos = scan(score_name,'0123456789') n_order = int(str_to_int( & @@ -1995,7 +2290,7 @@ contains score_name = "scatter-n" end if - select case (score_name) + select case (trim(score_name)) case ('flux') ! Prohibit user from tallying flux for an individual nuclide if (.not. (t % n_nuclide_bins == 1 .and. & @@ -2150,14 +2445,14 @@ contains t % score_bins(j) = MT else message = "Invalid MT on : " // & - trim(tally_(i) % scores(j)) + trim(sarray(j)) call fatal_error() end if else ! Specified score was not an integer message = "Unknown scoring function: " // & - trim(tally_(i) % scores(j)) + trim(sarray(j)) call fatal_error() end if @@ -2165,6 +2460,9 @@ contains end do t % n_score_bins = n_scores t % n_user_score_bins = n_words + + ! Deallocate temporary string array of scores + deallocate(sarray) else message = "No specified on tally " // trim(to_str(t % id)) & // "." @@ -2175,8 +2473,10 @@ contains ! SET TALLY ESTIMATOR ! Check if user specified estimator - if (len_trim(tally_(i) % estimator) > 0) then - select case(tally_(i) % estimator) + if (check_for_node(node_tal, "estimator")) then + temp_str = '' + call get_node_value(node_tal, "estimator", temp_str) + select case(trim(temp_str)) case ('analog') t % estimator = ESTIMATOR_ANALOG @@ -2193,7 +2493,7 @@ contains t % estimator = ESTIMATOR_TRACKLENGTH case default - message = "Invalid estimator '" // trim(tally_(i) % estimator) & + message = "Invalid estimator '" // trim(temp_str) & // "' on tally " // to_str(t % id) call fatal_error() end select @@ -2204,21 +2504,31 @@ contains end do READ_TALLIES + ! Close XML document + call close_xmldoc(doc) + end subroutine read_tallies_xml !=============================================================================== ! READ_PLOTS_XML reads data from a plots.xml file !=============================================================================== - subroutine read_plots_xml - - use xml_data_plots_t + subroutine read_plots_xml() integer i, j - integer n_cols, col_id + integer n_cols, col_id, n_comp, n_masks + integer, allocatable :: iarray(:) logical :: file_exists ! does plots.xml file exist? character(MAX_LINE_LEN) :: filename ! absolute path to plots.xml + character(MAX_LINE_LEN) :: temp_str type(ObjectPlot), pointer :: pl => null() + type(Node), pointer :: doc => null() + type(Node), pointer :: node_plot => null() + type(Node), pointer :: node_col => null() + type(Node), pointer :: node_mask => null() + type(NodeList), pointer :: node_plot_list => null() + type(NodeList), pointer :: node_col_list => null() + type(NodeList), pointer :: node_mask_list => null() ! Check if plots.xml exists filename = trim(path_input) // "plots.xml" @@ -2233,17 +2543,28 @@ contains call write_message(5) ! Parse plots.xml file - call read_xml_file_plots_t(filename) + call open_xmldoc(doc, filename) + + ! Get list pointer to XML + call get_node_list(doc, "plot", node_plot_list) ! Allocate plots array - n_plots = size(plot_) + n_plots = get_list_size(node_plot_list) allocate(plots(n_plots)) READ_PLOTS: do i = 1, n_plots pl => plots(i) + ! Get pointer to plot XML node + call get_list_item(node_plot_list, i, node_plot) + ! Copy data into plots - pl % id = plot_(i) % id + if (check_for_node(node_plot, "id")) then + call get_node_value(node_plot, "id", pl % id) + else + message = "Must specify plot id in plots XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (plot_dict % has_key(pl % id)) then @@ -2253,40 +2574,46 @@ contains end if ! Copy plot type - select case (plot_(i) % type) + temp_str = 'slice' + if (check_for_node(node_plot, "type")) & + call get_node_value(node_plot, "type", temp_str) + call lower_case(temp_str) + select case (trim(temp_str)) case ("slice") pl % type = PLOT_TYPE_SLICE case ("voxel") pl % type = PLOT_TYPE_VOXEL case default - message = "Unsupported plot type '" // trim(plot_(i) % type) & + message = "Unsupported plot type '" // trim(temp_str) & // "' in plot " // trim(to_str(pl % id)) call fatal_error() end select ! Set output file path + filename = "plot" + if (check_for_node(node_plot, "filename")) & + call get_node_value(node_plot, "filename", filename) select case (pl % type) case (PLOT_TYPE_SLICE) pl % path_plot = trim(path_input) // trim(to_str(pl % id)) // & - "_" // trim(plot_(i) % filename) // ".ppm" + "_" // trim(filename) // ".ppm" case (PLOT_TYPE_VOXEL) pl % path_plot = trim(path_input) // trim(to_str(pl % id)) // & - "_" // trim(plot_(i) % filename) // ".voxel" + "_" // trim(filename) // ".voxel" end select ! Copy plot pixel size if (pl % type == PLOT_TYPE_SLICE) then - if (size(plot_(i) % pixels) == 2) then - pl % pixels(1) = plot_(i) % pixels(1) - pl % pixels(2) = plot_(i) % pixels(2) + if (get_arraysize_integer(node_plot, "pixels") == 2) then + call get_node_array(node_plot, "pixels", pl % pixels(1:2)) else message = " must be length 2 in slice plot " // & trim(to_str(pl % id)) call fatal_error() end if else if (pl % type == PLOT_TYPE_VOXEL) then - if (size(plot_(i) % pixels) == 3) then - pl % pixels = plot_(i) % pixels + if (get_arraysize_integer(node_plot, "pixels") == 3) then + call get_node_array(node_plot, "pixels", pl % pixels(1:3)) else message = " must be length 3 in voxel plot " // & trim(to_str(pl % id)) @@ -2295,14 +2622,14 @@ contains end if ! Copy plot background color - if (associated(plot_(i) % background)) then + if (check_for_node(node_plot, "background")) then if (pl % type == PLOT_TYPE_VOXEL) then message = "Background color ignored in voxel plot " // & trim(to_str(pl % id)) call warning() end if - if (size(plot_(i) % background) == 3) then - pl % not_found % rgb = plot_(i) % background + if (get_arraysize_integer(node_plot, "background") == 3) then + call get_node_array(node_plot, "background", pl % not_found % rgb) else message = "Bad background RGB " & // "in plot " // trim(to_str(pl % id)) @@ -2314,7 +2641,11 @@ contains ! Copy plot basis if (pl % type == PLOT_TYPE_SLICE) then - select case (plot_(i) % basis) + temp_str = 'xy' + if (check_for_node(node_plot, "basis")) & + call get_node_value(node_plot, "basis", temp_str) + call lower_case(temp_str) + select case (trim(temp_str)) case ("xy") pl % basis = PLOT_BASIS_XY case ("xz") @@ -2322,15 +2653,15 @@ contains case ("yz") pl % basis = PLOT_BASIS_YZ case default - message = "Unsupported plot basis '" // plot_(i) % basis & + message = "Unsupported plot basis '" // trim(temp_str) & // "' in plot " // trim(to_str(pl % id)) call fatal_error() end select end if ! Copy plotting origin - if (size(plot_(i) % origin) == 3) then - pl % origin = plot_(i) % origin + if (get_arraysize_double(node_plot, "origin") == 3) then + call get_node_array(node_plot, "origin", pl % origin) else message = "Origin must be length 3 " & // "in plot " // trim(to_str(pl % id)) @@ -2339,17 +2670,16 @@ contains ! Copy plotting width if (pl % type == PLOT_TYPE_SLICE) then - if (size(plot_(i) % width) == 2) then - pl % width(1) = plot_(i) % width(1) - pl % width(2) = plot_(i) % width(2) + if (get_arraysize_double(node_plot, "width") == 2) then + call get_node_array(node_plot, "width", pl % width(1:2)) else message = " must be length 2 in slice plot " // & trim(to_str(pl % id)) call fatal_error() end if else if (pl % type == PLOT_TYPE_VOXEL) then - if (size(plot_(i) % width) == 3) then - pl % width = plot_(i) % width + if (get_arraysize_double(node_plot, "width") == 3) then + call get_node_array(node_plot, "width", pl % width(1:3)) else message = " must be length 3 in voxel plot " // & trim(to_str(pl % id)) @@ -2358,7 +2688,11 @@ contains end if ! Copy plot color type and initialize all colors randomly - select case (plot_(i) % color) + temp_str = "cell" + if (check_for_node(node_plot, "color")) & + call get_node_value(node_plot, "color", temp_str) + call lower_case(temp_str) + select case (trim(temp_str)) case ("cell") pl % color_by = PLOT_COLOR_CELLS @@ -2380,13 +2714,17 @@ contains end do case default - message = "Unsupported plot color type '" // plot_(i) % color & + message = "Unsupported plot color type '" // trim(temp_str) & // "' in plot " // trim(to_str(pl % id)) call fatal_error() end select + ! Get the number of nodes and get a list of them + call get_node_list(node_plot, "col_spec", node_col_list) + n_cols = get_list_size(node_col_list) + ! Copy user specified colors - if (associated(plot_(i) % col_spec_)) then + if (n_cols /= 0) then if (pl % type == PLOT_TYPE_VOXEL) then message = "Color specifications ignored in voxel plot " // & @@ -2394,21 +2732,33 @@ contains call warning() end if - n_cols = size(plot_(i) % col_spec_) do j = 1, n_cols - if (size(plot_(i) % col_spec_(j) % rgb) /= 3) then + + ! Get pointer to color spec XML node + call get_list_item(node_col_list, j, node_col) + + ! Check and make sure 3 values are specified for RGB + if (get_arraysize_double(node_col, "rgb") /= 3) then message = "Bad RGB " & // "in plot " // trim(to_str(pl % id)) call fatal_error() end if - col_id = plot_(i) % col_spec_(j) % id + ! Ensure that there is an id for this color specification + if (check_for_node(node_col, "id")) then + call get_node_value(node_col, "id", col_id) + else + message = "Must specify id for color specification in plot " // & + trim(to_str(pl % id)) + call fatal_error() + end if + ! Add RGB if (pl % color_by == PLOT_COLOR_CELLS) then if (cell_dict % has_key(col_id)) then col_id = cell_dict % get_key(col_id) - pl % colors(col_id) % rgb = plot_(i) % col_spec_(j) % rgb + call get_node_array(node_col, "rgb", pl % colors(col_id) % rgb) else message = "Could not find cell " // trim(to_str(col_id)) // & " specified in plot " // trim(to_str(pl % id)) @@ -2419,7 +2769,7 @@ contains if (material_dict % has_key(col_id)) then col_id = material_dict % get_key(col_id) - pl % colors(col_id) % rgb = plot_(i) % col_spec_(j) % rgb + call get_node_array(node_col, "rgb", pl % colors(col_id) % rgb) else message = "Could not find material " // trim(to_str(col_id)) // & " specified in plot " // trim(to_str(pl % id)) @@ -2431,7 +2781,9 @@ contains end if ! Deal with masks - if (associated(plot_(i) % mask_)) then + call get_node_list(node_plot, "mask", node_mask_list) + n_masks = get_list_size(node_mask_list) + if (n_masks /= 0) then if (pl % type == PLOT_TYPE_VOXEL) then message = "Mask ignored in voxel plot " // & @@ -2439,23 +2791,36 @@ contains call warning() end if - select case(size(plot_(i) % mask_)) + select case(n_masks) case default message = "Mutliple masks" // & " specified in plot " // trim(to_str(pl % id)) call fatal_error() - case (0) case (1) - + + ! Get pointer to mask + call get_list_item(node_mask_list, 1, node_mask) + + ! Determine how many components there are and allocate + n_comp = 0 + n_comp = get_arraysize_integer(node_mask, "components") + if (n_comp == 0) then + message = "Missing in mask of plot " // & + trim(to_str(pl % id)) + call fatal_error() + end if + allocate(iarray(n_comp)) + call get_node_array(node_mask, "components", iarray) + ! First we need to change the user-specified identifiers to indices ! in the cell and material arrays - do j=1,size(plot_(i) % mask_(1) % components) - col_id = plot_(i) % mask_(1) % components(j) + do j=1, n_comp + col_id = iarray(j) if (pl % color_by == PLOT_COLOR_CELLS) then if (cell_dict % has_key(col_id)) then - plot_(i) % mask_(1) % components(j) = cell_dict % get_key(col_id) + iarray(j) = cell_dict % get_key(col_id) else message = "Could not find cell " // trim(to_str(col_id)) // & " specified in the mask in plot " // trim(to_str(pl % id)) @@ -2465,7 +2830,7 @@ contains else if (pl % color_by == PLOT_COLOR_MATS) then if (material_dict % has_key(col_id)) then - plot_(i) % mask_(1) % components(j) = material_dict % get_key(col_id) + iarray(j) = material_dict % get_key(col_id) else message = "Could not find material " // trim(to_str(col_id)) // & " specified in the mask in plot " // trim(to_str(pl % id)) @@ -2477,10 +2842,18 @@ contains ! Alter colors based on mask information do j=1,size(pl % colors) - if (.not. any(j .eq. plot_(i) % mask_(1) % components)) then - pl % colors(j) % rgb = plot_(i) % mask_(1) % background + if (.not. any(j .eq. iarray)) then + if (check_for_node(node_mask, "background")) then + call get_node_array(node_mask, "background", pl % colors(j) % rgb) + else + message = "Missing in mask of plot " // & + trim(to_str(pl % id)) + call fatal_error() + end if end if end do + + deallocate(iarray) end select @@ -2491,6 +2864,9 @@ contains end do READ_PLOTS + ! Close plots XML file + call close_xmldoc(doc) + end subroutine read_plots_xml !=============================================================================== @@ -2500,15 +2876,17 @@ contains subroutine read_cross_sections_xml() - use xml_data_cross_sections_t - integer :: i ! loop index integer :: filetype ! default file type integer :: recl ! default record length integer :: entries ! default number of entries logical :: file_exists ! does cross_sections.xml exist? character(MAX_WORD_LEN) :: directory ! directory with cross sections + character(MAX_LINE_LEN) :: temp_str type(XsListing), pointer :: listing => null() + type(Node), pointer :: doc => null() + type(Node), pointer :: node_ace => null() + type(NodeList), pointer :: node_ace_list => null() ! Check if cross_sections.xml exists inquire(FILE=path_cross_sections, EXIST=file_exists) @@ -2522,18 +2900,12 @@ contains message = "Reading cross sections XML file..." call write_message(5) - ! Initialize variables that may go unused - directory_ = "" - filetype_ = "" - record_length_ = 0 - entries_ = 0 - ! Parse cross_sections.xml file - call read_xml_file_cross_sections_t(path_cross_sections) + call open_xmldoc(doc, path_cross_sections) - if (len_trim(directory_) > 0) then + if (check_for_node(doc, "directory")) then ! Copy directory information if present - directory = trim(directory_) + call get_node_value(doc, "directory", directory) else ! If no directory is listed in cross_sections.xml, by default select the ! directory in which the cross_sections.xml file resides @@ -2542,40 +2914,53 @@ contains end if ! determine whether binary/ascii - if (filetype_ == 'ascii') then + temp_str = '' + if (check_for_node(doc, "filetype")) & + call get_node_value(doc, "filetype", temp_str) + if (trim(temp_str) == 'ascii') then filetype = ASCII - elseif (filetype_ == 'binary') then + elseif (trim(temp_str) == 'binary') then filetype = BINARY - elseif (len_trim(filetype_) == 0) then + elseif (len_trim(temp_str) == 0) then filetype = ASCII else - message = "Unknown filetype in cross_sections.xml: " // trim(filetype_) + message = "Unknown filetype in cross_sections.xml: " // trim(temp_str) call fatal_error() end if ! copy default record length and entries for binary files - recl = record_length_ - entries = entries_ + if (filetype == BINARY) then + call get_node_value(doc, "record_length", recl) + call get_node_value(doc, "entries", entries) + end if + + ! Get node list of all + call get_node_list(doc, "ace_table", node_ace_list) + n_listings = get_list_size(node_ace_list) ! Allocate xs_listings array - if (.not. associated(ace_tables_)) then + if (n_listings == 0) then message = "No ACE table listings present in cross_sections.xml file!" call fatal_error() else - n_listings = size(ace_tables_) allocate(xs_listings(n_listings)) end if do i = 1, n_listings listing => xs_listings(i) + ! Get pointer to ace table XML node + call get_list_item(node_ace_list, i, node_ace) + ! copy a number of attributes - listing % name = trim(ace_tables_(i) % name) - listing % alias = trim(ace_tables_(i) % alias) - listing % zaid = ace_tables_(i) % zaid - listing % awr = ace_tables_(i) % awr - listing % kT = ace_tables_(i) % temperature - listing % location = ace_tables_(i) % location + call get_node_value(node_ace, "name", listing % name) + if (check_for_node(node_ace, "alias")) & + call get_node_value(node_ace, "alias", listing % alias) + call get_node_value(node_ace, "zaid", listing % zaid) + call get_node_value(node_ace, "awr", listing % awr) + if (check_for_node(node_ace, "temperature")) & + call get_node_value(node_ace, "temperature", listing % kT) + call get_node_value(node_ace, "location", listing % location) ! determine type of cross section if (ends_with(listing % name, 'c')) then @@ -2586,34 +2971,46 @@ contains ! set filetype, record length, and number of entries listing % filetype = filetype - listing % recl = recl - listing % entries = entries + if (filetype == BINARY) then + listing % recl = recl + listing % entries = entries + end if ! determine metastable state - if (ace_tables_(i) % metastable == 0) then + if (.not.check_for_node(node_ace, "metastable")) then listing % metastable = .false. else listing % metastable = .true. end if ! determine path of cross section table - if (starts_with(ace_tables_(i) % path, '/')) then - listing % path = ace_tables_(i) % path + if (check_for_node(node_ace, "path")) then + call get_node_value(node_ace, "path", temp_str) + else + message = "Path missing for isotope " // listing % name + call fatal_error() + end if + + if (starts_with(temp_str, '/')) then + listing % path = trim(temp_str) else if (ends_with(directory,'/')) then - listing % path = trim(directory) // trim(ace_tables_(i) % path) + listing % path = trim(directory) // trim(temp_str) else - listing % path = trim(directory) // '/' // trim(ace_tables_(i) % path) + listing % path = trim(directory) // '/' // trim(temp_str) end if end if ! create dictionary entry for both name and alias call xs_listing_dict % add_key(listing % name, i) - if (listing % alias /= '') then + if (check_for_node(node_ace, "alias")) then call xs_listing_dict % add_key(listing % alias, i) end if end do + ! Close cross sections XML file + call close_xmldoc(doc) + end subroutine read_cross_sections_xml !=============================================================================== diff --git a/src/templates/cmfd.rnc b/src/relaxng/cmfd.rnc similarity index 100% rename from src/templates/cmfd.rnc rename to src/relaxng/cmfd.rnc diff --git a/src/templates/cross_sections.rnc b/src/relaxng/cross_sections.rnc similarity index 100% rename from src/templates/cross_sections.rnc rename to src/relaxng/cross_sections.rnc diff --git a/src/templates/geometry.rnc b/src/relaxng/geometry.rnc similarity index 100% rename from src/templates/geometry.rnc rename to src/relaxng/geometry.rnc diff --git a/src/templates/materials.rnc b/src/relaxng/materials.rnc similarity index 100% rename from src/templates/materials.rnc rename to src/relaxng/materials.rnc diff --git a/src/templates/plots.rnc b/src/relaxng/plots.rnc similarity index 100% rename from src/templates/plots.rnc rename to src/relaxng/plots.rnc diff --git a/src/templates/settings.rnc b/src/relaxng/settings.rnc similarity index 94% rename from src/templates/settings.rnc rename to src/relaxng/settings.rnc index fda258385..99f64d1b4 100644 --- a/src/templates/settings.rnc +++ b/src/relaxng/settings.rnc @@ -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" } }? & diff --git a/src/templates/tallies.rnc b/src/relaxng/tallies.rnc similarity index 100% rename from src/templates/tallies.rnc rename to src/relaxng/tallies.rnc diff --git a/src/templates/cmfd_t.xml b/src/templates/cmfd_t.xml deleted file mode 100644 index 0e49e0e5a..000000000 --- a/src/templates/cmfd_t.xml +++ /dev/null @@ -1,34 +0,0 @@ - - diff --git a/src/templates/cross_sections_t.xml b/src/templates/cross_sections_t.xml deleted file mode 100644 index 0852b8504..000000000 --- a/src/templates/cross_sections_t.xml +++ /dev/null @@ -1,26 +0,0 @@ - - diff --git a/src/templates/geometry_t.xml b/src/templates/geometry_t.xml deleted file mode 100644 index 539a23f6b..000000000 --- a/src/templates/geometry_t.xml +++ /dev/null @@ -1,39 +0,0 @@ - - diff --git a/src/templates/materials_t.xml b/src/templates/materials_t.xml deleted file mode 100644 index 99950e035..000000000 --- a/src/templates/materials_t.xml +++ /dev/null @@ -1,44 +0,0 @@ - - diff --git a/src/templates/plots_t.xml b/src/templates/plots_t.xml deleted file mode 100644 index b3b86fc44..000000000 --- a/src/templates/plots_t.xml +++ /dev/null @@ -1,32 +0,0 @@ - - diff --git a/src/templates/settings_t.xml b/src/templates/settings_t.xml deleted file mode 100644 index 60b959c67..000000000 --- a/src/templates/settings_t.xml +++ /dev/null @@ -1,76 +0,0 @@ - - diff --git a/src/templates/tallies_t.xml b/src/templates/tallies_t.xml deleted file mode 100644 index cf653968d..000000000 --- a/src/templates/tallies_t.xml +++ /dev/null @@ -1,37 +0,0 @@ - - diff --git a/src/utils/build_dependencies.py b/src/utils/build_dependencies.py index 19ac97885..2a42b0745 100755 --- a/src/utils/build_dependencies.py +++ b/src/utils/build_dependencies.py @@ -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)) diff --git a/src/xml-fortran/read_from_buffer.inc b/src/xml-fortran/read_from_buffer.inc deleted file mode 100644 index 0cb6ee959..000000000 --- a/src/xml-fortran/read_from_buffer.inc +++ /dev/null @@ -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 - diff --git a/src/xml-fortran/read_xml_array.inc b/src/xml-fortran/read_xml_array.inc deleted file mode 100644 index a88086e74..000000000 --- a/src/xml-fortran/read_xml_array.inc +++ /dev/null @@ -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 diff --git a/src/xml-fortran/read_xml_primitives.f90 b/src/xml-fortran/read_xml_primitives.f90 deleted file mode 100644 index 1fb63d57b..000000000 --- a/src/xml-fortran/read_xml_primitives.f90 +++ /dev/null @@ -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 diff --git a/src/xml-fortran/read_xml_scalar.inc b/src/xml-fortran/read_xml_scalar.inc deleted file mode 100644 index b28ba3c7a..000000000 --- a/src/xml-fortran/read_xml_scalar.inc +++ /dev/null @@ -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 diff --git a/src/xml-fortran/read_xml_word.inc b/src/xml-fortran/read_xml_word.inc deleted file mode 100644 index 4c1848dcf..000000000 --- a/src/xml-fortran/read_xml_word.inc +++ /dev/null @@ -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 diff --git a/src/xml-fortran/write_xml_primitives.f90 b/src/xml-fortran/write_xml_primitives.f90 deleted file mode 100644 index 7d2cf90ba..000000000 --- a/src/xml-fortran/write_xml_primitives.f90 +++ /dev/null @@ -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, '' - -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)), '' - -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)), '' - -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), '' - -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' - else - write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & - '<', trim(tag), '>false' - 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)), & - '' - -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)), & - '' - -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)), & - '' - -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)), & - '' - -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)), & - '' - -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)), & - '' - -end subroutine write_to_xml_line_array - -end module write_xml_primitives diff --git a/src/xml-fortran/xml-fortran.LICENSE b/src/xml-fortran/xml-fortran.LICENSE deleted file mode 100644 index cd0ba2912..000000000 --- a/src/xml-fortran/xml-fortran.LICENSE +++ /dev/null @@ -1,37 +0,0 @@ -Note: The official xml-fortran repository on sourceforge - 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. diff --git a/src/xml-fortran/xmlparse.f90 b/src/xml-fortran/xmlparse.f90 deleted file mode 100644 index eb522078a..000000000 --- a/src/xml-fortran/xmlparse.f90 +++ /dev/null @@ -1,1076 +0,0 @@ -!=============================================================================== -! XMLPARSE - Simple, limited XML parser in Fortran -! -! General information: -! The module reads XML files by: -! - Identifying the tag and all attributes and data belonging -! to the tag. -! - Returning to the calling subprogram to let it take care of -! the tag, attributes and data. -! - If the tag is actually an ending tag, then this is flagged -! too. -! - Handling all the data is left to the calling subprogram, -! the module merely facilitates in the parsing. -! -! Note: -! The module in its current version has a number of limitations: -! - It does not handle escape sequences (like >. to signify -! a ">" sign) -! - It does not handle tags with attributes that are spread -! over more than one line -! - The maximum length of a line is 1000 characters -! - It may report too many lines of data (empty lines) -! - No DOM support nor support for an object tree -! - It is probably not very robust in detecting malformed XML files -! -! Some questions: -! - What to do with leading blanks? -! -! Update - several ideas: -! - Introduce at least two options (via xml_options): -! - ignore_whitespace - remove leading blanks and leading and trailing -! empty lines from the PCDATA -! - no_data_truncation - consider truncation of data (more -! attributes or lines of character data than -! can be stored) a read error -! - Introduce convenience functions and subroutines: -! - xml_ok() - all is well, reading can continue -! - xml_data_trunc() - was there truncation of the data? -! - xml_find_attrib() - find an attribute by name -! -! Further ideas: -! - simple checking via a table: parent, tag, id, min, max -!=============================================================================== - -module xmlparse - - implicit none - - integer, parameter :: XML_BUFFER_LENGTH = 10000 - -!=============================================================================== -! XML_PARSE defines the data type that holds the parser information -!=============================================================================== - - type XML_PARSE - integer :: lun ! LU-number of the XML-file - integer :: level ! Indentation level (output) - integer :: lineno ! Line in file - logical :: ignore_whitespace ! Ignore leading blanks etc. - logical :: no_data_truncation ! Do not allow data truncation - logical :: too_many_attribs ! More attributes than could be stored? - logical :: too_many_data ! More lines of data than could be stored? - logical :: eof ! End of file? - logical :: error ! Invalid XML file or other error? - character(len=XML_BUFFER_LENGTH) :: line ! Buffer - end type XML_PARSE - -!=============================================================================== -! Global options -!=============================================================================== - - integer, parameter :: XML_STDOUT = -1 - integer, private :: report_lun_ = XML_STDOUT - logical, private :: report_errors_ = .false. - logical, private :: report_details_ = .false. - -!=============================================================================== -! Global data (the ampersand must come first) -!=============================================================================== - - character(len=10), dimension(2,3), save, private :: entities = & - reshape( (/ '& ', '&', & - '> ', '> ', & - '< ', '< ' /), (/2,3/) ) - -!=============================================================================== -! Auxiliary routines - private -!=============================================================================== - - private :: xml_compress_ - private :: xml_put_open_tag_ - private :: xml_put_element_ - private :: xml_put_close_tag_ - private :: xml_replace_entities_ - private :: xml_remove_tabs_ - -!=============================================================================== -! Interfaces to reporting routines -!=============================================================================== - - private :: xml_report_details_int_ - private :: xml_report_details_string_ - private :: xml_report_errors_int_ - private :: xml_report_errors_string_ - - interface xml_report_details - module procedure xml_report_details_int_ - module procedure xml_report_details_string_ - end interface - interface xml_report_errors - module procedure xml_report_errors_int_ - module procedure xml_report_errors_string_ - module procedure xml_report_errors_extern_ - end interface - -contains - -!=============================================================================== -! XML_REPORT_DETAILS_INT_ -- -! Routine to write a text with an integer value -! Arguments: -! text Text to be written -! int Integer value to be added -!=============================================================================== - -subroutine xml_report_details_int_( text, int ) - character(len=*), intent(in) :: text - integer, intent(in) :: int - - if ( report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), int - else - write(report_lun_,*) trim(text), int - endif - endif -end subroutine xml_report_details_int_ - -!=============================================================================== -! XML_REPORT_DETAILS_STRING_ -- -! Routine to write a text with a string value -! Arguments: -! text Text to be written -! string String to be added -!=============================================================================== - -subroutine xml_report_details_string_( text, string ) - character(len=*), intent(in) :: text - character(len=*), intent(in) :: string - - if ( report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), ' ', trim(string) - else - write(report_lun_,*) trim(text), ' ', trim(string) - endif - endif -end subroutine xml_report_details_string_ - -!=============================================================================== -! XML_REPORT_ERRORS_INT_ -- -! Routine to write an error message text with an integer value -! Arguments: -! text Text to be written -! int Integer value to be added -! lineno Line number in the file -!=============================================================================== - -subroutine xml_report_errors_int_( text, int, lineno ) - character(len=*), intent(in) :: text - integer, intent(in) :: int - integer, optional, intent(in) :: lineno - - if ( report_errors_ .or. report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), int - if ( present(lineno) ) then - write(*,*) ' At or near line', lineno - endif - else - write(report_lun_,*) trim(text), int - if ( present(lineno) ) then - write(report_lun_,*) ' At or near line', lineno - endif - endif - endif -end subroutine xml_report_errors_int_ - -!=============================================================================== -! XML_REPORT_ERRORS_STRING_ -- -! Routine to write an error message text with a string value -! Arguments: -! text Text to be written -! string String to be added -! lineno Line number in the file -!=============================================================================== - -subroutine xml_report_errors_string_( text, string, lineno ) - character(len=*), intent(in) :: text - character(len=*), intent(in) :: string - integer, optional, intent(in) :: lineno - - if ( report_errors_ .or. report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), ' ', trim(string) - if ( present(lineno) ) then - write(*,*) ' At or near line', lineno - endif - else - write(report_lun_,*) trim(text), ' ', trim(string) - if ( present(lineno) ) then - write(report_lun_,*) ' At or near line', lineno - endif - endif - endif -end subroutine xml_report_errors_string_ - -!=============================================================================== -! XML_REPORT_ERRORS_EXTERN_ -- -! Routine to write an error message text with a string value -! Arguments: -! info Structure holding information on the XML-file -! text Text to be written -! Note: -! This routine is meant for use by routines outside -! this module -!=============================================================================== - -subroutine xml_report_errors_extern_( info, text ) - type(XML_PARSE), intent(in) :: info - character(len=*), intent(in) :: text - - if ( report_errors_ .or. report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), ' - at or near line', info%lineno - else - write(report_lun_,*) trim(text), ' - at or near line', info%lineno - endif - end if - -end subroutine xml_report_errors_extern_ - -!=============================================================================== -! XML_OPEN -- -! Routine to open an XML file for reading or writing -! Arguments: -! info Structure holding information on the XML-file -! fname Name of the file -! mustread The file will be read (.true.) or written (.false.) -!=============================================================================== - -subroutine xml_open( info, fname, mustread ) - character(len=*), intent(in) :: fname - logical, intent(in) :: mustread - type(XML_PARSE), intent(out) :: info - - integer :: i - integer :: k - integer :: kend - integer :: ierr - logical :: opend - logical :: exists - - info%lun = 10 - info%ignore_whitespace = .false. - info%no_data_truncation = .false. - info%too_many_attribs = .false. - info%too_many_data = .false. - info%eof = .false. - info%error = .false. - info%level = -1 - info%lineno = 0 - - do i = 10,99 - inquire( unit = i, opened = opend ) - if ( .not. opend ) then - info%lun = i - inquire( file = fname, exist = exists ) - if ( .not. exists .and. mustread ) then - call xml_report_errors( 'XML_OPEN: file does not exist:', trim(fname)) - info%lun = -1 - info%error = .true. - else - open( unit = info%lun, file = fname ) - call xml_report_details( 'XML_OPEN: opened file ', trim(fname) ) - call xml_report_details( 'at LU-number: ', info%lun ) - endif - exit - endif - enddo - if ( .not. info%error .and. mustread ) then - k = 1 - do while ( k >= 1 ) - read( info%lun, '(a)', iostat = ierr ) info%line - - ! If we encounter a blank line, skip it and read the next line - if (len_trim(info%line) == 0) cycle - - call xml_remove_tabs_(info%line) - if ( ierr == 0 ) then - info%line = adjustl( info%line ) - k = index( info%line, ' appears on a single line! - ! - if ( k >= 1 ) then - kend = index( info%line, '?>' ) - if ( kend <= 0 ) then - call xml_report_errors( 'XML_OPEN: error reading file with LU-number: ', info%lun ) - call xml_report_errors( 'Line starting with ""', ' ' ) - info%error = .true. - exit - endif - endif - else - call xml_report_errors( 'XML_OPEN: error reading file with LU-number: ', info%lun ) - call xml_report_errors( 'Possibly no line starting with "' - endif -end subroutine xml_open - -!=============================================================================== -! XML_CLOSE -- -! Routine to close an XML file -! Arguments: -! info Structure holding information on the XML-file -!=============================================================================== - -subroutine xml_close( info ) - type(XML_PARSE), intent(inout) :: info - - close( info%lun ) - - ! - ! Only clean up the LU-number, so that the calling program - ! can examine the last condition - ! - call xml_report_details( 'XML_CLOSE: Closing file with LU-number ', info%lun ) - info%lun = -1 -end subroutine xml_close - -!=============================================================================== -! XML_GET -- -! Routine to get the next bit of information from an XML file -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -!=============================================================================== - -subroutine xml_get( info, tag, endtag, attribs, no_attribs, & - data, no_data ) - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(out) :: tag - logical, intent(out) :: endtag - character(len=*), intent(out), dimension(:,:) :: attribs - integer, intent(out) :: no_attribs - character(len=*), intent(out), dimension(:) :: data - integer, intent(out) :: no_data - - integer :: kspace - integer :: kend - integer :: kcend - integer :: keq - integer :: kfirst - integer :: ksecond - integer :: idxat - integer :: idxdat - integer :: ierr - logical :: close_bracket - logical :: comment_tag - character(len=XML_BUFFER_LENGTH) :: nextline - - ! - ! Initialise the output - ! - endtag = .false. - no_attribs = 0 - no_data = 0 - - info%too_many_attribs = .false. - info%too_many_data = .false. - - if ( info%lun < 0 ) then - call xml_report_details( 'XML_GET on closed file ', ' ' ) - return - endif - - ! - ! From the previous call or the call to xmlopen we have - ! the line that we need to parse already in memory: - ! - ! - comment_tag = .false. - close_bracket = .false. - kspace = index( info%line, ' ' ) - kend = index( info%line, '>' ) - kcend = index( info%line, '-->' ) - do while ( kend <= 0 ) - read( info%lun, '(a)', iostat = ierr ) nextline - call xml_remove_tabs_(nextline) - info%lineno = info%lineno + 1 - - if ( ierr == 0 ) then - info%line = trim(info%line) // ' ' // adjustl(nextline) - else - info%error = .true. - call xml_report_errors( 'XML_GET - end of tag not found ', & - '(buffer too small?)', info%lineno ) - call xml_close( info ) - return - endif - kend = index( info%line, '>' ) - enddo - if ( kend > kspace ) then - kend = kspace - else if (info%line(1:4) == '' ) then - endtag = .true. - tag = info%line(4:kend-1) - else if ( info%line(1:2) == '' ) - if ( keq > kend ) keq = 0 ! Guard against multiple tags - ! with attributes on one line - - ! - ! No attributes any more? - ! - if ( keq < 1 ) then - kend = index( info%line, '/>' ) - if ( kend >= 1 ) then - kend = kend + 1 ! To go beyond the ">" character - endtag = .true. - else - kend = index( info%line, '>' ) - if ( kend < 1 ) then - call xml_report_errors( 'XML_GET - wrong ending of tag ', & - trim(info%line), info%lineno ) - info%error = .true. ! Wrong ending of line! - call xml_close( info ) - return - else - close_bracket = .true. - endif - endif - if ( kend >= 1 ) then - info%line = adjustl( info%line(kend+1:) ) - endif - exit - endif - - idxat = idxat + 1 - if ( idxat <= size(attribs,2) ) then - no_attribs = idxat - attribs(1,idxat) = adjustl(info%line(1:keq-1)) ! Use adjustl() to avoid - ! multiple spaces, etc - info%line = adjustl( info%line(keq+1:) ) - - ! - ! We have almost found the start of the attribute's value - ! - kfirst = index( info%line, '"' ) - if ( kfirst < 1 ) then - call xml_report_errors( 'XML_GET - malformed attribute-value pair: ', & - trim(info%line), info%lineno ) - info%error = .true. ! Wrong form of attribute-value pair - call xml_close( info ) - return - endif - - ksecond = index( info%line(kfirst+1:), '"' ) + kfirst - if ( ksecond < 1 ) then - call xml_report_errors( 'XML_GET - malformed attribute-value pair: ', & - trim(info%line), info%lineno ) - info%error = .true. ! Wrong form of attribute-value pair - call xml_close( info ) - return - endif - - attribs(2,idxat) = info%line(kfirst+1:ksecond-1) - info%line = adjustl( info%line(ksecond+1:) ) - endif - - if ( idxat > size(attribs,2) ) then - call xml_report_errors( 'XML_GET - more attributes than could be stored: ', & - trim(info%line), info%lineno ) - info%too_many_attribs = .true. - info%line = ' ' - exit - endif - enddo - - ! - ! Now read the data associated with the current tag - ! - all the way to the next "<" character - ! - ! To do: reduce the number of data lines - empty ones - ! at the end should not count. - ! - do - if ( comment_tag ) then - kend = index( info%line, '-->' ) - else - kend = index( info%line, '<' ) - endif - idxdat = idxdat + 1 - if ( idxdat <= size(data) ) then - no_data = idxdat - if ( kend >= 1 ) then - data(idxdat) = info%line(1:kend-1) - info%line = info%line(kend:) - else - data(idxdat) = info%line - endif - else - call xml_report_errors( 'XML_GET - more data lines than could be stored: ', & - trim(info%line), info%lineno ) - info%too_many_data = .true. - exit - endif - - ! - ! No more data? Otherwise, read on - ! - if ( kend >= 1 ) then - exit - else - read( info%lun, '(a)', iostat = ierr ) info%line - call xml_remove_tabs_(info%line) - info%lineno = info%lineno + 1 - - if ( ierr < 0 ) then - call xml_report_details( 'XML_GET - end of file found - LU-number: ', & - info%lun ) - info%eof = .true. - elseif ( ierr > 0 ) then - call xml_report_errors( 'XML_GET - error reading file with LU-number ', & - info%lun, info%lineno ) - info%error = .true. - endif - if ( ierr /= 0 ) then - exit - endif - endif - enddo - - ! - ! Compress the data? - ! - if ( info%ignore_whitespace ) then - call xml_compress_( data, no_data ) - endif - - ! - ! Replace the entities, if any - ! - call xml_replace_entities_( data, no_data ) - - call xml_report_details( 'XML_GET - number of attributes: ', no_attribs ) - call xml_report_details( 'XML_GET - number of data lines: ', no_data ) - -end subroutine xml_get - -!=============================================================================== -! XML_PUT -- -! Routine to write a tag with the associated data to an XML file -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -! type Type of action: -! open - just the opening tag with attributes -! elem - complete element -! close - just the closing tag -!=============================================================================== - -subroutine xml_put(info, tag, attribs, no_attribs, & - data, no_data, type) - - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(in) :: tag - character(len=*), intent(in), dimension(:,:) :: attribs - integer, intent(in) :: no_attribs - character(len=*), intent(in), dimension(:) :: data - integer, intent(in) :: no_data - character(len=*) :: type - - select case(type) - case('open') - call xml_put_open_tag_(info, tag, attribs, no_attribs) - case('elem') - call xml_put_element_(info, tag, attribs, no_attribs, & - data, no_data) - case('close') - call xml_put_close_tag_(info, tag) - end select - -end subroutine xml_put - -!=============================================================================== -! XML_PUT_OPEN_TAG_ -- -! Routine to write the opening tag with the attributes -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -!=============================================================================== - -subroutine xml_put_open_tag_(info, tag, attribs, no_attribs) - - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(in) :: tag - character(len=*), intent(in), dimension(:,:) :: attribs - integer, intent(in) :: no_attribs - - integer :: i - character(len=300), parameter :: indent = ' ' - - write( info%lun, '(3a)', advance = 'no' ) & - indent(1:3*info%level), '<', adjustl(tag) - do i=1,no_attribs - if (attribs(2,i)/='') then - write( info%lun, '(5a)', advance = 'no' ) & - ' ',trim(attribs(1,i)),'="', trim(attribs(2,i)),'"' - endif - enddo - write( info%lun, '(a)' ) '>' - info%level = info%level + 1 - -end subroutine xml_put_open_tag_ - -!=============================================================================== -! XML_PUT_ELEMENT_ -- -! Routine to write the complete element -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -!=============================================================================== - -subroutine xml_put_element_(info, tag, attribs, no_attribs, & - data, no_data) - - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(in) :: tag - character(len=*), intent(in), dimension(:,:) :: attribs - integer, intent(in) :: no_attribs - character(len=*), intent(in), dimension(:) :: data - integer, intent(in) :: no_data - - logical :: logic - character(len=1) :: aa - integer :: i, ii - - character(len=300), parameter :: indent = ' ' - - if ( (no_attribs==0 .and. no_data==0) ) then - return - else - logic = .true. - do ii = 1,no_attribs - logic = logic .and. (attribs(2,ii)=='') - enddo - do ii = 1,no_data - logic = logic .and. (data(ii)=='') - enddo - if ( logic ) then - return - else - write( info%lun, '(3a)', advance = 'no' ) & - indent(1:3*info%level), '<', adjustl(tag) - do i = 1,no_attribs - if (attribs(2,i)/='') then - write( info%lun, '(5a)', advance = 'no' ) & - ' ',trim(attribs(1,i)),'="', trim(attribs(2,i)),'"' - endif - enddo - if ( no_attribs>0 .and. no_data==0 ) then - aa='a' - elseif ( (no_attribs>0 .and. no_data>0) .or. & - (no_attribs==0 .and. no_data>0) ) then - aa='b' - else - write(*,*) no_attribs, no_data - endif - endif - endif - - select case(aa) - case('a') - write( info%lun, '(a)' ) '/>' - case('b') - write( info%lun, '(a)',advance='no' ) '>' - write( info%lun, '(2a)', advance='no') ( ' ', trim(data(i)), i=1,no_data ) - write( info%lun, '(4a)' ) ' ','' - end select - -end subroutine xml_put_element_ - -!=============================================================================== -! XML_PUT_CLOSE_TAG_ -- -! Routine to write the closing tag -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -!=============================================================================== - -subroutine xml_put_close_tag_(info, tag) - - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(in) :: tag - - character(len=300), parameter :: indent = ' ' - - info%level = info%level - 1 - write(info%lun, '(4a)') indent(1:3*info%level), '' - -end subroutine xml_put_close_tag_ - -!=============================================================================== -! XML_COMPRESS_ -- -! Routine to remove empty lines from the character data -! Arguments: -! data Lines of character data found -! no_data (Nett) number of lines of character data -!=============================================================================== - -subroutine xml_compress_( data, no_data ) - character(len=*), intent(inout), dimension(:) :: data - integer, intent(inout) :: no_data - - integer :: i - integer :: j - logical :: empty - - j = 0 - empty = .true. - do i = 1,no_data - if ( len_trim(data(i)) /= 0 .or. .not. empty ) then - j = j + 1 - data(j) = adjustl(data(i)) - empty = .false. - endif - enddo - - no_data = j - - do i = no_data,1,-1 - if ( len_trim(data(i)) /= 0 ) then - exit - else - no_data = no_data - 1 - endif - enddo - -end subroutine xml_compress_ - -!=============================================================================== -! XML_REPLACE_ENTITIES_ -- -! Routine to replace entities such as > by their -! proper character representation -! Arguments: -! data Lines of character data found -! no_data (Nett) number of lines of character data -!=============================================================================== - -subroutine xml_replace_entities_( data, no_data ) - character(len=*), intent(inout), dimension(:) :: data - integer, intent(inout) :: no_data - - integer :: i - integer :: j - integer :: j2 - integer :: k - integer :: pos - logical :: found - - do i = 1,no_data - j = 1 - do - do k = 1,size(entities,2) - found = .false. - pos = index( data(i)(j:), trim(entities(2,k)) ) - if ( pos > 0 ) then - found = .true. - j = j + pos - 1 - j2 = j + len_trim(entities(2,k)) - data(i)(j:) = trim(entities(1,k)) // data(i)(j2:) - j = j2 - endif - enddo - if ( .not. found ) exit - enddo - enddo - -end subroutine xml_replace_entities_ - -!=============================================================================== -! XML_OPTIONS -- -! Routine to handle the parser options -! Arguments: -! info Structure holding information on the XML-file -! ignore_whitespace Ignore whitespace (leading blanks, empty lines) or not -! no_data_truncation Consider truncation of strings an error or not -! report_lun LU-number for reporting information -! report_errors Write messages about errors or not -! report_details Write messages about all kinds of actions or not -!=============================================================================== - -subroutine xml_options( info, ignore_whitespace, no_data_truncation, & - report_lun, report_errors, & - report_details ) - type(XML_PARSE), intent(inout) :: info - logical, intent(in), optional :: ignore_whitespace - logical, intent(in), optional :: no_data_truncation - - integer, intent(in), optional :: report_lun - logical, intent(in), optional :: report_errors - logical, intent(in), optional :: report_details - - if ( present(ignore_whitespace) ) then - info%ignore_whitespace = ignore_whitespace - endif - if ( present(no_data_truncation) ) then - info%no_data_truncation = no_data_truncation - endif - if ( present(report_lun) ) then - report_lun_ = report_lun - endif - if ( present(report_errors) ) then - report_errors_ = report_errors - endif - if ( present(report_details) ) then - report_details_ = report_details - endif -end subroutine xml_options - -!=============================================================================== -! XML_OK -- -! Function that returns whether all was okay or not -! Arguments: -! info Structure holding information on the XML-file -! Returns: -! .true. if there was no error, .false. otherwise -!=============================================================================== - -logical function xml_ok( info ) - type(XML_PARSE), intent(in) :: info - - xml_ok = info%eof .or. info%error .or. & - ( info%no_data_truncation .and. & - ( info%too_many_attribs .or. info%too_many_data ) ) - xml_ok = .not. xml_ok -end function xml_ok - -!=============================================================================== -! XML_ERROR -- -! Function that returns whether there was an error -! Arguments: -! info Structure holding information on the XML-file -! Returns: -! .true. if there was an error, .false. if there was none -!=============================================================================== - -logical function xml_error( info ) - type(XML_PARSE), intent(in) :: info - - xml_error = info%error .or. & - ( info%no_data_truncation .and. & - ( info%too_many_attribs .or. info%too_many_data ) ) -end function xml_error - -!=============================================================================== -! XML_DATA_TRUNC -- -! Function that returns whether data were truncated or not -! Arguments: -! info Structure holding information on the XML-file -! Returns: -! .true. if data were truncated, .false. otherwise -!=============================================================================== - -logical function xml_data_trunc( info ) - type(XML_PARSE), intent(in) :: info - - xml_data_trunc = info%too_many_attribs .or. info%too_many_data -end function xml_data_trunc - -!=============================================================================== -! XML_FIND_ATTRIB -!=============================================================================== - -integer function xml_find_attrib( attribs, no_attribs, name, value ) - character(len=*), dimension(:,:) :: attribs - integer :: no_attribs - character(len=*) :: name - character(len=*) :: value - - integer :: i - - xml_find_attrib = -1 - do i = 1,no_attribs - if ( name == attribs(1,i) ) then - value = attribs(2,i) - xml_find_attrib = i - exit - endif - enddo - -end function xml_find_attrib - -!=============================================================================== -! XML_PROCESS -- -! Routine to read the XML file as a whole and distribute processing -! the contents over three user-defined subroutines -! Arguments: -! filename Name of the file to process -! attribs Array for holding the attributes -! data Array for holding the character data -! startfunc Subroutine to handle the start of elements -! datafunc Subroutine to handle the character data -! endfunc Subroutine to handle the end of elements -! error Indicates if there was an error or not -! Note: -! The routine is declared recursive to allow inclusion of XML files -! (common with XSD schemas). This extends to the auxiliary routines. -!=============================================================================== - -recursive & -subroutine xml_process( filename, attribs, data, startfunc, datafunc, endfunc, lunrep, error ) - character(len=*) :: filename - character(len=*), dimension(:,:) :: attribs - character(len=*), dimension(:) :: data - integer :: lunrep - logical :: error - - interface - recursive subroutine startfunc( tag, attribs, error ) - character(len=*) :: tag - character(len=*), dimension(:,:) :: attribs - logical :: error - end subroutine - end interface - - interface - recursive subroutine datafunc( tag, data, error ) - character(len=*) :: tag - character(len=*), dimension(:) :: data - logical :: error - end subroutine - end interface - - interface - recursive subroutine endfunc( tag, error ) - character(len=*) :: tag - logical :: error - end subroutine - end interface - - type(XML_PARSE) :: info - character(len=80) :: tag - logical :: endtag - integer :: noattribs - integer :: nodata - - call xml_options( info, report_lun = lunrep, report_details = .false. ) - call xml_open( info, filename, .true. ) - - error = .false. - do - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( .not. xml_ok(info) ) then - exit - endif - - if ( xml_error(info) ) then - write(lunrep,*) 'Error reading XML file!' - error = .true. - exit - endif - - if ( .not. endtag .or. noattribs /= 0 ) then - call startfunc( tag, attribs(:,1:noattribs), error ) - if ( error ) exit - - call datafunc( tag, data(1:nodata), error ) - if ( error ) exit - endif - - if ( endtag ) then - call endfunc( tag, error ) - if ( error ) exit - endif - enddo - call xml_close( info ) -end subroutine xml_process - -!=============================================================================== -! XML_REMOVE_TABS_ -- -! Routine to change any horizontal tab characters to spaces when reading a -! new line of data -! Arguments: -! line Line of character data to modify -!=============================================================================== - -subroutine xml_remove_tabs_(line) - character(len=*), intent(inout) :: line - - integer :: i - - do i = 1, len_trim(line) - if (line(i:i) == achar(9)) then - line(i:i) = ' ' - end if - end do - -end subroutine xml_remove_tabs_ - -end module xmlparse diff --git a/src/xml-fortran/xmlreader.f90 b/src/xml-fortran/xmlreader.f90 deleted file mode 100644 index 390324b63..000000000 --- a/src/xml-fortran/xmlreader.f90 +++ /dev/null @@ -1,1241 +0,0 @@ -!=============================================================================== -! XMLREADER: -! Read an XML-file that contains a template for the data and the XML files -! that will be used in a program and generate a module with reading routines. -! -! TODO: -! - Private routines! -! - Error for unknown data types -! - Length for character items -!=============================================================================== - -program xmlreader - use XMLPARSE - implicit none - - character(len=60) :: fname - type(XML_PARSE) :: info - - character(len=80) :: tag - character(len=80) :: starttag - logical :: endtag - character(len=80), dimension(1:2,1:20) :: attribs - integer :: noattribs - character(len=1000), dimension(1:1000) :: data - integer :: nodata - integer :: i - integer :: j - integer, parameter :: notmps = 6 ! Number of temporary files needed! - integer :: ludef - integer :: ludeflt - integer :: luinit - integer :: lusubs - integer :: luprolog - integer :: lustart - integer :: luloop - integer :: luend - integer :: lumain - integer :: luwrite - integer :: luwritp - integer :: luwrv - integer :: argc - logical :: prolog_written - logical :: comp - logical :: error - logical :: begin_loop = .true. - logical :: begin_main_loop = .true. - logical :: begin_component = .false. - logical :: strict - logical :: global_type - logical :: dyn_strings - - character(len=32) :: root_name - character(len=32) :: global_name - character(len=32) :: typename - character(len=32), dimension(1:20) :: placeholder - integer :: no_placeholders - - character(len=50) :: declare - character(len=50), dimension(:,:), pointer :: types - character(len=50), dimension(:,:), pointer :: new_types - - ! TODO: arrays of integers etc, in addition to integer-arrays - see: word - integer, parameter :: notypes_predefined = 27 - character(len=50), dimension(1:4,1:notypes_predefined) :: predefined_types - integer :: notypes = notypes_predefined - data ((predefined_types(i,j) , i=1,4), j=1,notypes_predefined ) / & -'logical' ,' logical' , 'read_xml_logical', 'write_to_xml_logical', & -'logical-1dim' ,' logical, dimension(:), pointer' , 'read_xml_logical_1dim', 'write_to_xml_logical_1dim', & -'logical-array' ,' logical, dimension(:), pointer' , 'read_xml_logical_array', 'write_to_xml_logical_array', & -'logical-shape' ,' logical, dimension(SHAPE)' , 'read_xml_logical_array', 'write_to_xml_logical_array', & -'integer' ,' integer' , 'read_xml_integer', 'write_to_xml_integer', & -'integer-1dim' ,' integer, dimension(:), pointer' , 'read_xml_integer_1dim', 'write_to_xml_integer_1dim', & -'integer-array' ,' integer, dimension(:), pointer' , 'read_xml_integer_array', 'write_to_xml_integer_array', & -'integer-shape' ,' integer, dimension(SHAPE)' , 'read_xml_integer_array', 'write_to_xml_integer_array', & -'real' ,' real' , 'read_xml_real' , 'write_to_xml_real' , & -'real-1dim' ,' real, dimension(:), pointer' , 'read_xml_real_1dim', 'write_to_xml_real_1dim', & -'real-array' ,' real, dimension(:), pointer' , 'read_xml_real_array', 'write_to_xml_real_array', & -'real-shape' ,' real, dimension(SHAPE)' , 'read_xml_real_array', 'write_to_xml_real_array', & -'double' ,' real(kind=kind(1.0d0))' , 'read_xml_double', 'write_to_xml_double', & -'double-1dim' ,' real(kind=kind(1.0d0)), dimension(:), pointer' , & - 'read_xml_double_1dim', 'write_to_xml_double_1dim', & -'double-array' ,' real(kind=kind(1.0d0)), dimension(:), pointer' , & - 'read_xml_double_array', 'write_to_xml_double_array', & -'double-shape' ,' real(kind=kind(1.0d0)), dimension(SHAPE)' , & - 'read_xml_double_array', 'write_to_xml_double_array', & -'word' ,' character(len=?)' , 'read_xml_word', 'write_to_xml_word', & -'word-1dim' ,' character(len=?), dimension(:), pointer' , 'read_xml_word_1dim', 'write_to_xml_word_1dim', & -'word-array' ,' character(len=?), dimension(:), pointer' , 'read_xml_word_array', 'write_to_xml_word_array', & -'word-shape' ,' character(len=?), dimension(SHAPE)' , 'read_xml_word_array', 'write_to_xml_word_array', & -'line' ,' character(len=?)' , 'read_xml_line', 'write_to_xml_line', & -'line-1dim' ,' character(len=?), dimension(:), pointer' , 'read_xml_line_1dim', 'write_to_xml_line_1dim', & -'line-array' ,' character(len=?), dimension(:), pointer' , 'read_xml_line_array', 'write_to_xml_line_array', & -'line-shape' ,' character(len=?), dimension(SHAPE)' , 'read_xml_line_array', 'write_to_xml_line_array', & -'character' ,' character(len=?)' , 'read_xml_line', 'write_to_xml_line', & -'character-array',' character(len=?), dimension(:), pointer' , 'read_xml_line_array', 'write_to_xml_line_array', & -'character-shape',' character(len=?), dimension(SHAPE)' , 'read_xml_line_array', 'write_to_xml_line_array' / - - allocate( types(1:4,1:notypes) ) - types = predefined_types(:,1:notypes) - - ! - ! Read the global options file, if present - ! - strict = .false. - global_type = .false. - dyn_strings = .true. - call get_global_options( attribs, noattribs, strict, global_type, global_name, & - root_name, dyn_strings ) - - ! - ! Open the input file and read the name of the template. - ! Load the template into a tree and then generate it all - ! in stages - ! - argc = COMMAND_ARGUMENT_COUNT() - if (argc > 0) then - call GET_COMMAND_ARGUMENT(1, fname) - else - open(UNIT=10, FILE='xmlreader.inp') - read(UNIT=10, FMT='(a)') fname - close(UNIT=10) - end if - - open( 20, file = 'xmlreader.out' ) - call xml_options( info, report_lun = 20, report_details = .true. ) - - prolog_written = .false. - ! - ! Set the defaults - ! - global_type = .false. - global_name = fname - root_name = fname - - ludef = 21 - lusubs = 22 - luinit = 23 - luwritp = 24 - luwrv = luwritp - open( ludef, file = trim(fname)//'.f90' ) - open( lusubs, status = 'scratch' ) - open( luinit, status = 'scratch' ) - open( luwritp, status = 'scratch' ) - call open_tmp_files( 31 ) - - lumain = luloop - - ! Read the template file and act as we go along: - ! - write the declarations - ! - write the main reading routine - ! - write the individual reading routines - ! - the root element is needed because of the definition of XML files, - ! but we ignore it. - ! - call xml_open( info, trim(fname)//'.xml', .true. ) - - error = .false. - comp = .false. - no_placeholders = 0 - - call xml_get( info, starttag, endtag, attribs, noattribs, data, nodata ) - - do - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - write(20,*) 'tag: ',tag - write(20,*) 'attribs: ',noattribs - if ( noattribs > 0 ) then - write(20,'(4a)') ( ' ', trim(attribs(1,i)), ' = ', trim(attribs(2,i)), i=1,noattribs ) - endif - write(20,*) 'data: ',nodata - if ( nodata > 0 ) then - write(20,'(3a)') ( ' >', trim(data(i)), '<', i=1,nodata ) - endif - if ( xml_error(info) ) then - write(*,*) 'Error reading template file!' - !stop - exit - endif - - ! - ! When encountering the endtag, then close the - ! current definition - ! - if ( endtag .and. noattribs == 0 ) then - select case ( tag ) - case ( 'typedef' ) - call close_typedef( begin_component ) - case ( 'placeholder' ) - !if ( comp ) then - ! call close_placeholder - !endif - !comp = .false. - call close_placeholder - luwrv = luwritp - case default - ! - ! Have we found the end of the definition? - ! - if ( tag == starttag ) then - exit - endif - end select - - if ( xml_ok(info) ) then - cycle - else - exit - endif - - endif - - ! - ! Opening tags: dispatch on the actual tag - ! - select case( tag ) - case( 'options' ) - call set_options( attribs, noattribs, strict, global_type, & - global_name, root_name, dyn_strings ) - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - else - write(20,*) 'Options element should be the first child of the root element',& - 'Otherwise it has no effect!' - endif - - if ( strict ) then - write( lumain, '(a)' ) ' strict_ = .true.' - else - write( lumain, '(a)' ) ' strict_ = .false.' - endif - - case( 'comment', '!--' ) - ! Do nothing - - case( 'placeholder' ) - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - endif - if ( begin_loop .or. begin_main_loop ) then - begin_main_loop = .false. - call add_begin_loop( .true., .false. ) - endif - call add_placeholder(dyn_strings) - begin_component = .false. - luwrv = luwrite - - case( 'typedef' ) - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - endif - call add_typedef(dyn_strings) - - case( 'variable' ) - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - endif - if ( begin_loop .or. begin_main_loop ) then - begin_main_loop = .false. - call add_begin_loop( .true., begin_component ) - endif - call add_variable( component=comp ) - - case( 'component' ) - ! - ! Components of derived types are treated in much the - ! same way as ordinary variables - with one syntactic - ! difference - ! - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - endif - if ( begin_loop ) then - call add_begin_loop( .true., .true. ) - endif - call add_variable( component=.true. ) - begin_component = .true. - - case default - write(20,*) 'Unknown tag: ',trim(tag) - write(20,*) '-- terminating the program!' - stop - end select - end do - - ! - ! Now finish it all - ! - write( luend, '(a)' ) & - & ' if ( present(errout) ) errout = error', & - & ' call xml_close(info)', & - & 'end subroutine', & - & ' ' - write( luwritp, '(a)' ) & - & ' write(info%lun,''(a)'') ''''', & - & ' call xml_close(info)', & - & 'end subroutine', & - & ' ' - - call append_files( luprolog ) - call merge_files - - write( ludef, '(/,a)' ) & - & 'end subroutine', & - & 'end module' - - if ( error ) then - write(*,*) 'Errors found in the definition - please check!' - endif - stop -contains - -!=============================================================================== -! GET_GLOBAL_OPTIONS -- -! Routine to get the global options from the configuration file -! Arguments: -! strict Option to make the parser check for unknown tags -! global_type Option to generate an overall derived type -! global_name Name of that overall derived type (if requested) -! root_name Name of the root element of the XML file -! dyn_strings Whether to use dynamic strings or not -!=============================================================================== - -subroutine get_global_options( attribs, noattribs, strict, global_type, global_name, & - root_name, dyn_strings ) - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - logical, intent(inout) :: strict - logical, intent(inout) :: global_type - character(len=*), intent(inout) :: global_name - character(len=*), intent(inout) :: root_name - logical, intent(inout) :: dyn_strings - - character(len=20) :: tag - character(len=20), dimension(1) :: data - integer :: nodata - logical :: exists - logical :: endtag - type(XML_PARSE) :: info - - inquire( file = 'xmlreader.conf', exist = exists ) - if ( exists ) then - call xml_open( info, 'xmlreader.conf', .true. ) - do while ( xml_ok(info) ) - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( tag == 'xmlreader' ) then - call set_options( attribs, noattribs, strict, global_type, & - global_name, root_name, dyn_strings ) - endif - enddo - call xml_close( info ) - endif -end subroutine get_global_options - -!=============================================================================== -! SET_OPTIONS -- -! Routine to set the options that influence the parser -! Arguments: -! attribs List of attributes -! noattribs Number of attributes -! strict Option to make the parser check for unknown tags -! global_type Option to generate an overall derived type -! global_name Name of that overall derived type (if requested) -! root_name Name of the root element of the XML file -! dyn_strings Whether to use dynamic strings or not -!=============================================================================== - -subroutine set_options( attribs, noattribs, strict, global_type, global_name, root_name, dyn_strings ) - character(len=*), dimension(:,:), intent(in) :: attribs - integer, intent(in) :: noattribs - logical, intent(inout) :: strict - logical, intent(inout) :: global_type - character(len=*), intent(inout) :: global_name - character(len=*), intent(inout) :: root_name - logical, intent(inout) :: dyn_strings - - integer :: i - - do i = 1,noattribs - select case (attribs(1,i)) - case ('strict') - if ( attribs(2,i) == 'yes' ) then - strict = .true. - else - strict = .false. - endif - case ('globaltype') - if ( attribs(2,i) == 'yes' ) then - global_type = .true. - else - global_type = .false. - endif - case ('globalname') - global_name = attribs(2,i) - case ('rootname') - root_name = attribs(2,i) - case ('dynamicstrings') - if ( attribs(2,i) == 'yes' ) then - dyn_strings = .true. - else - dyn_strings = .false. - endif - case default - write(20,*) 'Unknown option: ',trim(attribs(1,i)), ' - ignored' - end select - enddo -end subroutine set_options - -!=============================================================================== -! OPEN_TMP_FILES -- -! Routine to open the temporary files -! Arguments: -! lufirst First LU-number to use -!=============================================================================== - -subroutine open_tmp_files( lufirst ) - integer, intent(in) :: lufirst - - luprolog = lufirst - lustart = lufirst + 1 - luloop = lufirst + 2 - luend = lufirst + 3 - ludeflt = lufirst + 4 - luwrite = lufirst + 5 - open( luprolog, status = 'scratch' ) - open( lustart, status = 'scratch' ) - open( luloop, status = 'scratch' ) - open( luend, status = 'scratch' ) - open( ludeflt, status = 'scratch' ) - open( luwrite, status = 'scratch' ) -end subroutine open_tmp_files - -!=============================================================================== -! CLOSE_TMP_FILES -- -! Routine to close the temporary files -! Arguments: -! None -!=============================================================================== - -subroutine close_tmp_files - close( luprolog ) - close( lustart ) - close( luloop ) - close( luend ) - close( ludeflt ) - close( luwrite ) - - luprolog = luprolog - notmps - lustart = lustart - notmps - luloop = luloop - notmps - luend = luend - notmps - ludeflt = ludeflt - notmps - luwrite = luwrite - notmps -end subroutine close_tmp_files - -!=============================================================================== -! APPEND_TMP_FILES -- -! Routine to append the contents of the temporary files -! Arguments: -! lufirst First LU-number to use -!=============================================================================== - -subroutine append_files( lufirst ) - integer, intent(in) :: lufirst - - integer :: lu - integer :: io - character(len=120) :: line - - ! - ! If we have not written a subroutine yet, then - ! now is the time to close the overall initialisation - ! routine - ! -- no longer needed - ! - !if ( .not. contains ) then - ! write( lusubs, '(a,/)' ) 'end subroutine' - ! contains = .true. - !endif - - ! - ! Copy the contents of the scratch files - ! - do lu = lufirst,lufirst+notmps-1 - rewind( lu ) - do - read( lu, '(a)', iostat=io ) line - if ( io /= 0 ) exit - write( lusubs, '(a)' ) trim(line) - enddo - rewind( lu ) - enddo -end subroutine append_files - -!=============================================================================== -! MERGE_FILES -- -! Routine to merge all temporary files into the definite file -! Arguments: -! None -!=============================================================================== - -subroutine merge_files - - integer :: io - character(len=120) :: line - - ! - ! Copy the contents of the "subroutines" file - ! - rewind( lusubs ) - do - read( lusubs, '(a)', iostat=io ) line - if ( io /= 0 ) exit - write( ludef, '(a)' ) trim(line) - enddo - - ! - ! Copy the contents of the "write xml file subroutine" file - ! - rewind( luwritp ) - do - read( luwritp, '(a)', iostat=io ) line - if ( io /= 0 ) exit - write( ludef, '(a)' ) trim(line) - enddo - - ! - ! Copy the contents of the "initialisation subroutine" file - ! - rewind( luinit ) - do - read( luinit, '(a)', iostat=io ) line - if ( io /= 0 ) exit - write( ludef, '(a)' ) trim(line) - enddo -end subroutine merge_files - -!=============================================================================== -! WRITE_PROLOG -- -! Routine to write the beginning of the module -! Arguments: -! None -!=============================================================================== - -subroutine write_prolog - write( ludef, '(a)' ) & - & 'module xml_data_' // trim(fname), & - & ' use READ_XML_PRIMITIVES', & - & ' use WRITE_XML_PRIMITIVES', & - & ' use XMLPARSE', & - & ' implicit none', & - & ' save', & - & ' integer, private :: lurep_', & - & ' logical, private :: strict_' - - write( luprolog, '(a)' ) & - & 'subroutine read_xml_file_'//trim(fname)//'(fname, lurep, errout)' , & - & ' character(len=*), intent(in) :: fname' , & - & ' integer, intent(in), optional :: lurep' , & - & ' logical, intent(out), optional :: errout' , & - & ' ' , & - & ' type(XML_PARSE) :: info' , & - & ' logical :: error' , & - & ' character(len=80) :: tag' , & - & ' character(len=80) :: starttag' , & - & ' logical :: endtag' , & - & ' character(len=250), dimension(1:2,1:20) :: attribs' , & - & ' integer :: noattribs' , & - & ' character(len=1000), dimension(1:1000) :: data' , & - & ' integer :: nodata' - - write( lusubs, '(a)' ) & - & 'contains' - write( luinit, '(a)' ) & - & 'subroutine init_xml_file_'//trim(fname) - - write( luwritp, '(a)' ) & - & 'subroutine write_xml_file_'//trim(fname)//'(fname, lurep)' , & - & ' character(len=*), intent(in) :: fname' , & - & ' integer, intent(in), optional :: lurep' , & - & ' ' , & - & ' type(XML_PARSE) :: info' , & - & ' integer :: indent = 0', & - & ' ' , & - & ' call xml_open( info, fname, .false. )' , & - & ' call xml_options( info, report_errors=.true.)' , & - & ' if ( present(lurep) ) then' , & - & ' call xml_options( info, report_errors=.true.)' , & - & ' endif' , & - & ' write(info%lun,''(a)'') &' , & - & ' ''<' // trim(root_name) // '>''' - - write( lumain, '(a)' ) & - & ' ', & - & ' call init_xml_file_'//trim(fname), & - & ' call xml_open( info, fname, .true. )', & - & ' call xml_options( info, report_errors=.false., ignore_whitespace=.true.)', & - & ' lurep_ = 0', & - & ' if ( present(lurep) ) then', & - & ' lurep_ = lurep', & - & ' call xml_options( info, report_lun=lurep )', & - & ' endif', & - & ' do', & - & ' call xml_get( info, starttag, endtag, attribs, noattribs, &', & - & ' data, nodata)', & - & ' if ( starttag /= ''!--'' ) exit', & - & ' enddo', & - & ' if ( starttag /= "' // trim(root_name) // '" ) then', & - & ' call xml_report_errors( info, &', & - & ' ''XML-file should have root element "' // trim(root_name) // '"'')', & - & ' error = .true.', & - & ' call xml_close(info)', & - & ' return', & - & ' endif' - - call add_end_loop -end subroutine write_prolog - -!=============================================================================== -! ADD_BEGIN_LOOP -- -! Routine to write the start of the reading loop -! Arguments: -! checktag Whether code for checking the tag is required -! component Whether this is an ordinary variable or a component -! in a derived type -!=============================================================================== - -subroutine add_begin_loop( checktag, component ) - logical :: checktag - logical :: component - - if ( component ) then - write( luloop, '(a)' ) & - & ' call init_xml_type_'//trim(typename)//'(dvar)', & - & ' has_dvar = .true.' - endif - - begin_loop = .false. - - if ( component ) then - write( luloop, '(a)' ) & - & ' error = .false.' ,& - & ' att_ = 0' ,& - & ' noatt_ = noattribs+1' ,& - & ' endtag_org = endtag' ,& - & ' do', & - & ' if ( nodata /= 0 ) then' ,& - & ' noattribs = 0' ,& - & ' tag = starttag' ,& - & ' elseif ( att_ < noatt_ .and. noatt_ > 1 ) then' ,& - & ' att_ = att_ + 1' ,& - & ' if ( att_ <= noatt_-1 ) then' ,& - & ' tag = attribs(1,att_)' ,& - & ' data(1) = attribs(2,att_)' ,& - & ' noattribs = 0' ,& - & ' nodata = 1' ,& - & ' endtag = .false.' ,& - & ' else' ,& - & ' tag = starttag' ,& - & ' noattribs = 0' ,& - & ' nodata = 0' ,& - & ' endtag = .true.' ,& - & ' cycle' ,& - & ' endif' ,& - & ' else', & - & ' if ( endtag_org ) then', & - & ' return', & - & ' else', & - & ' call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )' ,& - & ' if ( xml_error(info) ) then' ,& - & ' write(lurep_,*) ''Error reading input file!''',& - & ' error = .true.' ,& - & ' return' ,& - & ' endif' ,& - & ' endif' ,& - & ' endif' - else - write( luloop, '(a)' ) & - & ' error = .false.' ,& - & ' do', & - & ' call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )' ,& - & ' if ( xml_error(info) ) then' ,& - & ' write(lurep_,*) ''Error reading input file!''' ,& - & ' error = .true.' ,& - & ' return' ,& - & ' endif' - endif - if ( checktag ) then - write( luloop, '(a)' ) & - & ' if ( endtag .and. tag == starttag ) then' ,& - & ' exit' ,& - & ' endif' - endif - write( luloop, '(a)' ) & - & ' if ( endtag .and. noattribs == 0 ) then' ,& - & ' if ( xml_ok(info) ) then' ,& - & ' cycle' ,& - & ' else' ,& - & ' exit' ,& - & ' endif' ,& - & ' endif' ,& - & ' select case( tag )' -end subroutine add_begin_loop - -!=============================================================================== -! ADD_END_LOOP -- -! Routine to write the end of the reading loop -! Arguments: -! None -!=============================================================================== - -subroutine add_end_loop - - write( luend, '(a)' ) & - & ' case (''comment'', ''!--'')' ,& - & ' ! Simply ignore', & - & ' case default' ,& - & ' if ( strict_ ) then', & - & ' error = .true.', & - & ' call xml_report_errors( info, &', & - & ' ''Unknown or wrongly placed tag: '' // trim(tag))',& - & ' endif' - - write( luend, '(a)' ) & - & ' end select' ,& - & ' nodata = 0' ,& - & ' if ( .not. xml_ok(info) ) exit' , & - & ' end do' -end subroutine add_end_loop - -!=============================================================================== -! ADD_VARIABLE -- -! Routine to write the definition of variables or components of -! derived types -! Arguments: -! component Whether this is an ordinary variable or a component -! in a derived type -!=============================================================================== - -subroutine add_variable( component ) - logical :: component - - integer :: idx1 - integer :: idx2 - integer :: idx3 - integer :: idx4 - integer :: idx5 - integer :: idx6 - integer :: idx7 - integer :: k - integer :: vdim - - character(len=32) :: varname - character(len=40) :: varcomp - character(len=40) :: varshape - character(len=100) :: vardefault - character(len=32) :: vartype - character(len=32) :: vartag - character(len=10) :: dim - character(len=10) :: strlength - character(len=32) :: initptr - - idx1 = xml_find_attrib( attribs, noattribs, 'name', varname ) - idx2 = xml_find_attrib( attribs, noattribs, 'type', vartype ) - strlength = "--" - idx5 = xml_find_attrib( attribs, noattribs, 'length', strlength ) - if ( idx1 <= 0 ) then - write( 20, * ) 'Variable/component found which has no name' - error = .true. - endif - if ( idx2 <= 0 ) then - write( 20, * ) 'Variable/component found which has no type - ',trim(varname) - error = .true. - else - dim = '--' - idx7 = xml_find_attrib( attribs, noattribs, 'dimension', dim ) - idx6 = xml_find_attrib( attribs, noattribs, 'shape', varshape ) - if ( idx7 >= 1 ) then - if ( dim == '1' ) then - idx3 = xml_find_attrib( types, notypes, vartype, declare ) - if ( idx3 > notypes_predefined ) then - vartype = trim(vartype) // '-array' - else - vartype = trim(vartype) // '-1dim' - endif - else - error = .true. - write(20,*) 'Dimension not supported: ',dim - endif - endif - if ( idx6 >= 1 ) then - vartype = trim(vartype) // '-shape' - vdim = 1 - if ( index(varshape, ',') > 0 ) then - vdim = 2 - endif - endif - - idx3 = xml_find_attrib( types, notypes, vartype, declare ) - if ( idx3 <= 0 ) then - write( 20, * ) & - 'Variable/component with unknown type - ',trim(varname) - error = .true. - endif - endif - - idx4 = xml_find_attrib( attribs, noattribs, 'default', vardefault ) - - if ( component ) then - varcomp = 'dvar%'//varname - else - varcomp = varname - endif - - idx1 = xml_find_attrib( attribs, noattribs, 'tag', vartag ) - if ( idx1 < 1 ) then - vartag = varname - endif - - if ( .not. error ) then - if ( index( declare, "pointer" ) > 0 ) then - initptr = " => null()" - else - initptr = "" - endif - - k = index( declare, 'SHAPE' ) - if ( k > 0 ) then - declare = declare(1:k-1) // trim(varshape) // declare(k+5:) - endif - - if ( index( declare, "?" ) <= 0 ) then - write( ludef, '(4a)' ) declare, ' :: ', trim(varname), trim(initptr) - else - if ( strlength == "--" ) then - strlength = "1" ! Hm, error is better? - endif - idx5 = index( declare, "?" ) - write( ludef, '(6a)' ) declare(1:idx5-1), trim(strlength), declare(idx5+1:), & - ' :: ', trim(varname), trim(initptr) - endif - - if ( idx6 > 0 ) then - k = index( types(2,idx3-1), '?' ) - if ( k <= 0 ) then - write( luprolog, '(3a)' ) types(2,idx3-1), ' :: ', 'p_'//trim(varname) - else - write( luprolog, '(6a)' ) types(2,idx3-1)(1:k-1), trim(strlength), & - types(2,idx3-1)(k+1:), ' :: ', 'p_'//trim(varname) - endif - endif - write( luprolog, '(3a)' ) types(2,1), ' :: ', 'has_'//trim(varname) - write( lustart, '(3a)' ) ' has_', varname, ' = .false.' - if ( dim /= '--' ) then - write( lustart, '(3a)' ) ' allocate(' // trim(varcomp), '(0))' - endif - write( luloop, '(a)' ) ' case('''//trim(vartag)//''')' - - if ( idx6 <= 0 ) then - write( luloop, '(a)' ) & - &' call '//trim(types(3,idx3))//'( &', & - &' info, tag, endtag, attribs, noattribs, data, nodata, &',& - &' ' // trim(varcomp) // ', has_'//trim(varname) // ' )' - else - write( luloop, '(a)' ) & - &' call '//trim(types(3,idx3))//'( &', & - &' info, tag, endtag, attribs, noattribs, data, nodata, &',& - &' p_' // trim(varname) // ', has_'//trim(varname) // ' )',& - &' if ( has_'//trim(varname) // ') then' - if ( vdim == 1 ) then - write( luloop, '(a)' ) & - &' if ( size('//trim(varcomp)//') <= size(p_'//trim(varname)//') ) then', & - &' '//trim(varcomp) // ' = p_'//trim(varname)//'(1:size('//trim(varcomp)//'))', & - &' else', & - &' '//trim(varcomp) // '(1:size(p_'//trim(varname)//')) = p_'//trim(varname), & - &' endif' - else - write( luloop, '(a)' ) & - &' if ( size(p_'//trim(varname)//') >= size('//trim(varcomp)//') ) then',& - &' '//trim(varcomp)//' = reshape(p_'//trim(varname)//', shape('//trim(varcomp)//'))',& - &' else',& - &' has_'//trim(varname)//' = .false.',& - &' call xml_report_errors(info, ''Incorrect number of values for '//trim(varname)//''')', & - &' endif' - endif - write( luloop, '(a)' ) & - &' deallocate( p_'//trim(varname)//' )', & - &' endif' - endif - if ( idx4 <= 0 ) then - write( luend, '(a)' ) & - &' if ( .not. has_'//trim(varname)//' ) then' - - if ( component ) then - write( luend, '(a)' ) & - &' has_dvar = .false.' - else - write( luend, '(a)' ) & - &' error = .true.' - endif - - write( luend, '(a)' ) & - &' call xml_report_errors(info, ''Missing data on '//trim(varname)//''')', & - &' endif' - else - ! - ! Note: the attribute value is supposed to have the quotes, if that - ! is relevant for the variable's type - ! - if ( component ) then - write( ludeflt, '(4a)' ) & - &' dvar%', trim(varname), ' = ', attribs(2,idx4) - else - write( luinit, '(4a)' ) & - &' ', trim(varname), ' = ', attribs(2,idx4) - endif - endif - ! - ! Write the component/variable - ! - if ( component ) then - write( luwrite, '(4a)' ) & - &' call '//trim(types(4,idx3))//'(', & - &' info, '''//trim(vartag)//''', indent+3, dvar%', trim(varname), ')' - else - write( luwrv, '(4a)' ) & - &' call '//trim(types(4,idx3))//'(', & - &' info, '''//trim(vartag)//''', indent+3, ', trim(varname), ')' - endif - endif - -end subroutine add_variable - -!=============================================================================== -! ADD_TYPEDEF -- -! Routine to write the definition and other code for a derived type -! Arguments: -! dyn_strings Whether dynamic string lengths are allowed -!=============================================================================== - -subroutine add_typedef( dyn_strings ) - logical, intent(in) :: dyn_strings - - integer :: idx1 - integer :: idx2 - - character(len=32) :: typetag - - idx1 = xml_find_attrib( attribs, noattribs, 'name', typename ) - if ( idx1 <= 0 ) then - write( 20, * ) 'Type definition found which has no name' - error = .true. - endif - - ! - ! We need a new set of temporary files - ! - call open_tmp_files( luprolog+notmps ) - - idx2 = xml_find_attrib( attribs, noattribs, 'tag', typetag ) - if ( idx1 < 1 ) then - typetag = typename - endif - - if ( .not. error ) then - write( ludef, '(/,2a)' ) 'type ',trim(typename) - write( luprolog, '(a)' ) & - & 'subroutine read_xml_type_'//trim(typename)//'_array( &' ,& - & ' info, tag, endtag, attribs, noattribs, data, nodata, &',& - & ' dvar, has_dvar )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(inout) :: tag ',& - & ' logical, intent(inout) :: endtag ',& - & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& - & ' integer, intent(inout) :: noattribs',& - & ' character(len=*), dimension(:), intent(inout) :: data ',& - & ' integer, intent(inout) :: nodata ',& - & ' type('//trim(typename)//'), dimension(:), pointer :: dvar ',& - & ' logical, intent(inout) :: has_dvar ',& - & ' ' ,& - & ' integer :: newsize ',& - & ' type('//trim(typename)//'), dimension(:), pointer :: newvar',& - & ' ' ,& - & ' newsize = size(dvar) + 1' ,& - & ' allocate( newvar(1:newsize) )' ,& - & ' newvar(1:newsize-1) = dvar' ,& - & ' deallocate( dvar )' ,& - & ' dvar => newvar' ,& - & ' ' ,& - & ' call read_xml_type_'//trim(typename)// & - & '( info, tag, endtag, attribs, noattribs, data, nodata, &',& - & ' dvar(newsize), has_dvar )' ,& - & 'end subroutine read_xml_type_'//trim(typename)//'_array' ,& - & ' ' - - write( luwrite, '(a)' ) & - & 'subroutine write_xml_type_'//trim(typename)//'_array( &' ,& - & ' info, tag, indent, dvar )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(in) :: tag' ,& - & ' integer :: indent',& - & ' type('//trim(typename)//'), dimension(:) :: dvar' ,& - & ' integer :: i' ,& - & ' do i = 1,size(dvar)' ,& - & ' call write_xml_type_'//trim(typename)// & - & '( info, tag, indent, dvar(i) )' ,& - & ' enddo' ,& - & 'end subroutine write_xml_type_'//trim(typename)//'_array' ,& - & ' ', & - & 'subroutine write_xml_type_'//trim(typename)//'( &' ,& - & ' info, tag, indent, dvar )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(in) :: tag' ,& - & ' integer :: indent',& - & ' type('//trim(typename)//') :: dvar' ,& - & ' character(len=100) :: indentation' ,& - & ' indentation = '' ''' ,& - & ' write(info%lun, ''(4a)'' ) indentation(1:min(indent,100)),&',& - & ' ''<'',trim(tag), ''>''' - - write( luprolog, '(a)' ) & - & 'subroutine read_xml_type_'//trim(typename)//& - & '( info, starttag, endtag, attribs, noattribs, data, nodata, &' ,& - & ' dvar, has_dvar )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(in) :: starttag',& - & ' logical, intent(inout) :: endtag ',& - & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& - & ' integer, intent(inout) :: noattribs',& - & ' character(len=*), dimension(:), intent(inout) :: data ',& - & ' integer, intent(inout) :: nodata ',& - & ' type('//trim(typename)//'), intent(inout) :: dvar' ,& - & ' logical, intent(inout) :: has_dvar ',& - & ' ' ,& - & ' integer :: att_ ',& - & ' integer :: noatt_ ',& - & ' logical :: error ',& - & ' logical :: endtag_org' - if ( dyn_strings ) then - write( luprolog, '(a)' ) & - & ' character(len=len(starttag)) :: tag ' - else - write( luprolog, '(a)' ) & - & ' character(len=80) :: tag ' - endif - - ! - ! Note: this may require a more sophisticated approach - ! when the components of the type are also pointers ... - ! - write( ludeflt, '(a)' ) & - & 'subroutine init_xml_type_'//trim(typename)//'_array( dvar ) ',& - & ' type('//trim(typename)//'), dimension(:), pointer :: dvar ',& - & ' if ( associated( dvar ) ) then' ,& - & ' deallocate( dvar )' ,& - & ' endif' ,& - & ' allocate( dvar(0) )' ,& - & 'end subroutine init_xml_type_'//trim(typename)//'_array' ,& - & 'subroutine init_xml_type_'//trim(typename)//'(dvar)' ,& - & ' type('//trim(typename)//') :: dvar ' - - begin_loop = .true. - - call add_end_loop - - ! - ! Add the names of the two new types to the list - ! - allocate( new_types(1:4,1:notypes+3) ) - new_types(:,1:notypes) = types - deallocate( types ) - types => new_types - - types(1,notypes+1) = typename - types(2,notypes+1) = ' type('//trim(typename)//')' - types(3,notypes+1) = 'read_xml_type_'//trim(typename) - types(4,notypes+1) = 'write_xml_type_'//trim(typename) - - types(1,notypes+2) = trim(typename) // '-array' - types(2,notypes+2) = ' type('//trim(typename)//'), dimension(:), pointer' - types(3,notypes+2) = 'read_xml_type_'//trim(typename)//'_array' - types(4,notypes+2) = 'write_xml_type_'//trim(typename)//'_array' - - types(1,notypes+3) = trim(typename) // '-shape' - types(2,notypes+3) = ' type('//trim(typename)//'), dimension(SHAPE)' - types(3,notypes+3) = 'read_xml_type_'//trim(typename)//'_array' - types(4,notypes+3) = 'write_xml_type_'//trim(typename)//'_array' - - notypes = notypes + 3 - - endif -end subroutine add_typedef - -!=============================================================================== -! CLOSE_TYPEDEF -- -! Routine to write the last code fragments for a derived type -! Arguments: -! component Turn off the "component" parameter -!=============================================================================== - -subroutine close_typedef( component ) - logical, intent(out) :: component - - component = .false. - write( ludef, '(a)' ) 'end type '//trim(typename) - write( luend, '(a)' ) & - & 'end subroutine read_xml_type_'//trim(typename) - write( ludeflt, '(a)' ) & - & 'end subroutine init_xml_type_'//trim(typename) - write( luwrite, '(a)' ) & - & ' write(info%lun,''(4a)'') indentation(1:min(indent,100)), &' ,& - & ' ''''', & - & 'end subroutine write_xml_type_'//trim(typename) ,& - & ' ' - call append_files( luprolog ) - call close_tmp_files - -end subroutine close_typedef - -!=============================================================================== -! ADD_PLACEHOLDER -- -! Routine to write the starting code fragments for a placeholder tag -! Arguments: -! dyn_strings Whether dynamic string lengths are allowed -!=============================================================================== - -subroutine add_placeholder( dyn_strings ) - logical, intent(in) :: dyn_strings - - integer :: idx1 - integer :: idx2 - - character(len=32) :: tag - character(len=20) :: optional - - idx1 = xml_find_attrib( attribs, noattribs, 'tag', tag ) - if ( idx1 <= 0 ) then - write( 20, * ) 'Placeholder definition found which has no tag name' - error = .true. - endif - - optional = 'no' - idx2 = xml_find_attrib( attribs, noattribs, 'optional', optional ) - - if ( optional == 'yes' ) then - if ( begin_loop ) then - call add_begin_loop( .false., .false. ) - endif - write( luloop, '(a)' ) & - ' case('''//trim(tag)//''')',& - ' ! Simply ignore the tag' - else - no_placeholders = no_placeholders + 1 - placeholder(no_placeholders) = tag - - write( luloop, '(a)' ) & - ' case('''//trim(tag)//''')',& - &' call read_xml_place_'//trim(tag)//'( info, &', & - &' tag, attribs, noattribs, data, nodata )' - comp = .false. - - ! - ! We need a new set of temporary files - ! - call open_tmp_files( luprolog+notmps ) - - ! - ! Write the first part of the routine - ! NOTE: - ! Will require an extra argument when collecting all variables - ! in one derived type - ! - write( luprolog, '(a)' ) & - & 'subroutine read_xml_place_'//trim(tag)//& - & '( info, starttag, attribs, noattribs, data, nodata )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(in) :: starttag',& - & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& - & ' integer, intent(inout) :: noattribs',& - & ' character(len=*), dimension(:), intent(inout) :: data ',& - & ' integer, intent(inout) :: nodata ',& - & ' ' ,& - & ' logical :: error ',& - & ' logical :: endtag ' - if ( dyn_strings ) then - write( luprolog, '(a)' ) & - & ' character(len=len(starttag)) :: tag ' - else - write( luprolog, '(a)' ) & - & ' character(len=80) :: tag ' - endif - - begin_loop = .true. - - call add_end_loop - - write(luwrite,'(a)') & - &'subroutine write_xml_place_'//trim(tag)//'( &' ,& - &' info, indent )' ,& - &' type(XML_PARSE) :: info' ,& - &' integer :: indent',& - &' character(len=100) :: indentation' ,& - &' indentation = '' ''' ,& - &' write(info%lun, ''(4a)'' ) indentation(1:min(indent,100)),&',& - &' ''<'// trim(tag) // '>''' - write(luwritp,'(a)') & - &' call write_xml_place_'//trim(tag)//'( info, indent+3 )' - - endif -end subroutine add_placeholder - -!=============================================================================== -! CLOSE_PLACEHOLDER -- -! Routine to write the last code fragments for a placeholder -! Arguments: -! None -!=============================================================================== - -subroutine close_placeholder - - write( luend, '(a)' ) & - & 'end subroutine read_xml_place_'//trim(placeholder(no_placeholders)) - - write( luwrite, '(a)' ) & - & ' write(info%lun,''(4a)'') indentation(1:min(indent,100)), &' ,& - & ' ''''' ,& - & 'end subroutine write_xml_place_'//trim(placeholder(no_placeholders)) ,& - & ' ' - - call append_files( luprolog ) - call close_tmp_files - - no_placeholders = no_placeholders - 1 - -end subroutine close_placeholder - -end program diff --git a/src/xml/LICENSE b/src/xml/LICENSE new file mode 100644 index 000000000..53df0326a --- /dev/null +++ b/src/xml/LICENSE @@ -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 , which is licensed +as shown in the file utils/fox_m_utils_mtprng.f90 + +This version of FoX is: +(c) 2005-2009 Toby White +(c) 2007-2009 Gen-Tao Chiang +(c) 2008-2012 Andrew Walker + +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
+! 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. diff --git a/src/xml/Makefile b/src/xml/Makefile new file mode 100644 index 000000000..f9151178c --- /dev/null +++ b/src/xml/Makefile @@ -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 diff --git a/src/xml/README b/src/xml/README new file mode 100644 index 000000000..5707d4524 --- /dev/null +++ b/src/xml/README @@ -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/ diff --git a/src/xml/common/FoX_common.F90 b/src/xml/common/FoX_common.F90 new file mode 100644 index 000000000..eaa7e684f --- /dev/null +++ b/src/xml/common/FoX_common.F90 @@ -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 diff --git a/src/xml/common/Makefile b/src/xml/common/Makefile new file mode 100644 index 000000000..a4874b3b5 --- /dev/null +++ b/src/xml/common/Makefile @@ -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 diff --git a/src/xml/common/m_common_attrs.F90 b/src/xml/common/m_common_attrs.F90 new file mode 100644 index 000000000..33a2cdb48 --- /dev/null +++ b/src/xml/common/m_common_attrs.F90 @@ -0,0 +1,1081 @@ +module m_common_attrs + +#ifndef DUMMYLIB + use fox_m_fsys_array_str, only : str_vs, vs_str_alloc + use m_common_element, only: get_att_type_enum, ATT_CDATA, ATT_CDAMB, ATT_TYPES + use m_common_error, only : FoX_error, FoX_fatal + + implicit none + private + + !Initial length of dictionary + integer, parameter :: DICT_INIT_LEN = 10 + !Multiplier if we need to extend it. + real, parameter :: DICT_LEN_MULT = 1.5 + + type dict_item + character(len=1), pointer, dimension(:) :: nsURI => null() + character(len=1), pointer, dimension(:) :: localName => null() + character(len=1), pointer, dimension(:) :: prefix => null() + character(len=1), pointer, dimension(:) :: key => null() + character(len=1), pointer, dimension(:) :: value => null() + logical :: specified = .true. + logical :: declared = .false. + logical :: isId = .false. + integer :: type = 11 + end type dict_item + + type dict_item_ptr + type(dict_item), pointer :: d => null() + end type dict_item_ptr +#endif + + type dictionary_t + private +#ifndef DUMMYLIB + type(dict_item_ptr), dimension(:), pointer :: list => null() + character, dimension(:), pointer :: base => null() +#else + integer :: i +#endif + end type dictionary_t + + public :: dictionary_t + + ! Building procedures +#ifndef DUMMYLIB + public :: init_dict + public :: reset_dict + public :: add_item_to_dict + public :: destroy_dict +#endif + ! Query and extraction procedures + + ! SAX names: + public :: getIndex + public :: getLength + public :: getLocalName + public :: getQName + public :: getURI + public :: getValue + public :: getType + public :: isSpecified + public :: setSpecified + public :: isDeclared + public :: setDeclared + public :: hasKey + +#ifndef DUMMYLIB + public :: len + public :: get_key + public :: get_value + public :: remove_key + public :: has_key + public :: print_dict + + ! Namespaces + public :: get_prefix + public :: get_localName + public :: set_nsURI + public :: set_prefix + public :: set_localName +#endif + + ! For internal FoX use only: + public :: get_att_index_pointer + public :: getWhitespaceHandling + public :: setIsId + public :: getIsId + + public :: setBase + public :: getBase + + public :: sortAttrs + + interface len + module procedure getLength + end interface + + interface hasKey + module procedure has_key, has_key_ns + end interface + + interface getIndex + module procedure get_key_index, get_key_index_ns + end interface + + interface getQName + module procedure get_key + end interface + + interface getValue + module procedure get_value_by_key, get_value_by_index, get_value_by_key_ns + end interface +#ifndef DUMMYLIB + interface get_value + module procedure get_value_by_key, get_value_by_index + end interface + interface remove_key + module procedure remove_key_by_index + end interface +#endif + + interface getURI + module procedure get_nsURI_by_index + end interface +#ifndef DUMMYLIB + interface get_prefix + module procedure get_prefix_by_index + end interface +#endif + interface getLocalName + module procedure get_localName_by_index + end interface +#ifndef DUMMYLIB + interface get_localName + module procedure get_localName_by_index + end interface + interface set_nsURI + module procedure set_nsURI_by_index + end interface + interface set_prefix + module procedure set_prefix_by_index + end interface + interface set_localName + module procedure set_localName_by_index_s + module procedure set_localName_by_index_vs + end interface +#endif + + interface getType + module procedure getType_by_index + module procedure getType_by_keyname + end interface + + interface isSpecified + module procedure isSpecified_by_index + module procedure isSpecified_by_key + module procedure isSpecified_by_keyNS + end interface + + interface isDeclared + module procedure isDeclared_by_index + module procedure isDeclared_by_key + module procedure isDeclared_by_keyNS + end interface + +#ifndef DUMMYLIB + interface getIsId + module procedure getIsId_by_index + end interface + + interface setIsId + module procedure setIsId_by_index + end interface + + interface destroy + module procedure destroy_dict_item + module procedure destroy_dict + end interface + +#endif + +contains + + pure function getLength(dict) result(n) + type(dictionary_t), intent(in) :: dict + integer :: n + +#ifndef DUMMYLIB + n = ubound(dict%list, 1) +#else + n = 0 +#endif + end function getLength + + + function has_key(dict, key) result(found) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key + logical :: found + +#ifndef DUMMYLIB + integer :: i + + do i = 1, ubound(dict%list, 1) + if (key==str_vs(dict%list(i)%d%key)) then + found = .true. + return + endif + enddo + found = .false. +#else + found = .false. +#endif + end function has_key + + function has_key_ns(dict, uri, localname) result(found) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: uri, localname + logical :: found + +#ifndef DUMMYLIB + integer :: i + found = .false. + do i = 1, ubound(dict%list, 1) + ! FIXME xlf 10.01 segfaults if the below is done as + ! an AND rather than two separate ifs. This is + ! probably due to the Heisenbug + if (uri==str_vs(dict%list(i)%d%nsURI)) then + if (localname==str_vs(dict%list(i)%d%localname)) then + found = .true. + exit + endif + endif + enddo +#else + found = .false. +#endif + end function has_key_ns + + pure function get_key_index(dict, key) result(ind) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key + integer :: ind + +#ifndef DUMMYLIB + integer :: i + do i = 1, ubound(dict%list, 1) + if (key == str_vs(dict%list(i)%d%key)) then + ind = i + return + endif + enddo + ind = 0 +#else + ind = 0 +#endif + end function get_key_index + + pure function get_key_index_ns(dict, uri, localname) result(ind) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: uri, localname + integer :: ind + +#ifndef DUMMYLIB + integer :: i + ind = -1 + do i = 1, ubound(dict%list, 1) + if (uri==str_vs(dict%list(i)%d%nsURI) & + .and. localname==str_vs(dict%list(i)%d%localname)) then + ind = i + exit + endif + enddo +#else + ind = 0 +#endif + end function get_key_index_ns + +#ifndef DUMMYLIB + pure function get_value_by_key_len(dict, key) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key + integer :: n + + integer :: i + + do i = 1, ubound(dict%list, 1) + if (key == str_vs(dict%list(i)%d%key)) then + n = size(dict%list(i)%d%value) + return + endif + enddo + n = 0 + end function get_value_by_key_len +#endif + + function get_value_by_key(dict, key) result(value) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key +#ifndef DUMMYLIB + character(len=get_value_by_key_len(dict,key)) :: value + + integer :: i + + do i = 1, ubound(dict%list, 1) + if (key == str_vs(dict%list(i)%d%key)) then + value = str_vs(dict%list(i)%d%value) + return + endif + enddo + value = "" +#else + character(len=1) :: value + value = "" +#endif + end function get_value_by_key + +#ifndef DUMMYLIB + pure function get_value_by_key_ns_len(dict, nsUri, localname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: nsUri + character(len=*), intent(in) :: localname + integer :: n + + integer :: i + + do i = 1, ubound(dict%list, 1) + if (nsUri==str_vs(dict%list(i)%d%nsURI) & + .and.localname==str_vs(dict%list(i)%d%localname)) then + n = size(dict%list(i)%d%value) + return + endif + enddo + n = 0 + end function get_value_by_key_ns_len +#endif + + function get_value_by_key_ns(dict, nsUri, localname) result(value) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: nsUri + character(len=*), intent(in) :: localname +#ifndef DUMMYLIB + character(len=get_value_by_key_ns_len(dict, nsURI, localname)) :: value + + integer :: i + + do i = 1, ubound(dict%list, 1) + if (nsUri==str_vs(dict%list(i)%d%nsURI) & + .and.localname==str_vs(dict%list(i)%d%localname)) then + value = str_vs(dict%list(i)%d%value) + return + endif + enddo + value = "" +#else + character(len=1) :: value + value = "" +#endif + end function get_value_by_key_ns + +#ifndef DUMMYLIB + subroutine get_att_index_pointer(dict, key, i, value) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key + integer, intent(out) :: i + character, pointer :: value(:) + + value => null() + do i = 1, ubound(dict%list, 1) + if (key == str_vs(dict%list(i)%d%key)) then + value => dict%list(i)%d%value + return + endif + enddo + i = 0 + end subroutine get_att_index_pointer + + subroutine remove_key_by_index(dict, ind) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: ind + + integer :: i, n + type(dict_item_ptr), pointer :: tempList(:) + + n = ubound(dict%list, 1) + + if (ind<=0.or.ind>n) return + + allocate(tempList(0:n-1)) + do i = 0, ind-1 + tempList(i)%d => dict%list(i)%d + enddo + call destroy(dict%list(ind)%d) + do i = ind+1, n + tempList(i-1)%d => dict%list(i)%d + enddo + deallocate(dict%list) + dict%list => tempList + end subroutine remove_key_by_index +#endif + + pure function get_value_by_index_len(dict, i) result(n) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + integer :: n + +#ifdef DUMMYLIB + n = 1 +#else + if (i>0.and.i<=ubound(dict%list, 1)) then + n = size(dict%list(i)%d%value) + else + n = 0 + endif +#endif + end function get_value_by_index_len + + function get_value_by_index(dict, i) result(value) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=get_value_by_index_len(dict, i)) :: value + + if (i>0.and.i<=ubound(dict%list, 1)) then + value = str_vs(dict%list(i)%d%value) + else + value = "" + endif +#else + character(len=1) :: value + value = "" +#endif + end function get_value_by_index + +#ifndef DUMMYLIB + pure function get_key_len(dict, i) result(n) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + integer :: n + + if (i>0.and.i<=ubound(dict%list, 1)) then + n = size(dict%list(i)%d%key) + else + n = 0 + endif + end function get_key_len +#endif + + function get_key(dict, i) result(key) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=get_key_len(dict,i)) :: key + + if (i>0.and.i<=ubound(dict%list, 1)) then + key = str_vs(dict%list(i)%d%key) + else + key = "" + endif +#else + character(len=1) :: key + key = "" +#endif + end function get_key + +#ifndef DUMMYLIB + subroutine add_item_to_dict(dict, key, value, prefix, nsURI, type, itype, specified, declared) + type(dictionary_t), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + character(len=*), intent(in), optional :: prefix + character(len=*), intent(in), optional :: nsURI + character(len=*), intent(in), optional :: type + integer, intent(in), optional :: itype + logical, intent(in), optional :: specified + logical, intent(in), optional :: declared + + type(dict_item_ptr), pointer :: tempList(:) + integer :: i, n + + if (present(prefix) .eqv. .not.present(nsURI)) & + call FoX_Error('Namespace improperly specified') + + n = ubound(dict%list, 1) + allocate(tempList(0:n+1)) + do i = 0, n + tempList(i)%d => dict%list(i)%d + enddo + n = n + 1 + + allocate(tempList(n)%d) + tempList(n)%d%value => vs_str_alloc(value) + if (present(prefix)) then + tempList(n)%d%key => vs_str_alloc(prefix//":"//key) + tempList(n)%d%localname => vs_str_alloc(key) + tempList(n)%d%prefix => vs_str_alloc(prefix) + tempList(n)%d%nsURI => vs_str_alloc(nsURI) + else + tempList(n)%d%key => vs_str_alloc(key) + tempList(n)%d%localname => vs_str_alloc(key) + allocate(tempList(n)%d%prefix(0)) + allocate(tempList(n)%d%nsURI(0)) + endif + if (present(type)) then + if (present(itype)) & + call FoX_fatal("internal library error in add_item_to_dict") + tempList(n)%d%type = get_att_type_enum(type) + elseif (present(itype)) then + tempList(n)%d%type = itype + else + tempList(n)%d%type = ATT_CDAMB + endif + if (present(specified)) then + tempList(n)%d%specified = specified + else + tempList(n)%d%specified = .true. + endif + if (present(declared)) then + tempList(n)%d%declared = declared + else + tempList(n)%d%declared = .false. + endif + + deallocate(dict%list) + dict%list => tempList + + end subroutine add_item_to_dict + + subroutine set_nsURI_by_index(dict, i, nsURI) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + character(len=*), intent(in) :: nsURI + + if (associated(dict%list(i)%d%nsURI)) & + deallocate(dict%list(i)%d%nsURI) + dict%list(i)%d%nsURI => vs_str_alloc(nsURI) + end subroutine set_nsURI_by_index + + subroutine set_prefix_by_index(dict, i, prefix) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + character(len=*), intent(in) :: prefix + + if (associated(dict%list(i)%d%prefix)) & + deallocate(dict%list(i)%d%prefix) + dict%list(i)%d%prefix => vs_str_alloc(prefix) + end subroutine set_prefix_by_index + + subroutine set_localName_by_index_s(dict, i, localName) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + character(len=*), intent(in) :: localName + + if (associated(dict%list(i)%d%localName)) & + deallocate(dict%list(i)%d%localName) + dict%list(i)%d%localName => vs_str_alloc(localName) + end subroutine set_localName_by_index_s + + subroutine set_localName_by_index_vs(dict, i, localName) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + character(len=1), dimension(:), intent(in) :: localName + + if (associated(dict%list(i)%d%localName)) & + deallocate(dict%list(i)%d%localName) + allocate(dict%list(i)%d%localName(size(localName))) + dict%list(i)%d%localName = localName + end subroutine set_localName_by_index_vs +#endif + + pure function get_nsURI_by_index(dict, i) result(nsURI) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=size(dict%list(i)%d%nsURI)) :: nsURI + nsURI = str_vs(dict%list(i)%d%nsURI) +#else + character(len=1) :: nsURI + nsURI = "" +#endif + end function get_nsURI_by_index + +#ifndef DUMMYLIB + pure function get_prefix_by_index(dict, i) result(prefix) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + character(len=size(dict%list(i)%d%prefix)) :: prefix + + prefix = str_vs(dict%list(i)%d%prefix) + end function get_prefix_by_index +#endif + + pure function get_localName_by_index(dict, i) result(localName) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=size(dict%list(i)%d%localName)) :: localName + localName = str_vs(dict%list(i)%d%localName) +#else + character(len=1) :: localName + localName = "" +#endif + end function get_localName_by_index + +#ifndef DUMMYLIB + pure function get_nsURI_by_keyname_len(dict, keyname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + integer :: n + + integer :: i + + i = get_key_index(dict, keyname) + n = size(dict%list(i)%d%nsURI) + end function get_nsURI_by_keyname_len +#endif + +#ifndef DUMMYLIB + pure function get_nsURI_by_keyname(dict, keyname) result(nsURI) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + character(len=get_nsURI_by_keyname_len(dict, keyname)) :: nsURI + integer :: i + + i = get_key_index(dict, keyname) + nsURI = str_vs(dict%list(i)%d%nsURI) + end function get_nsURI_by_keyname + + pure function get_prefix_by_keyname_len(dict, keyname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + integer :: n + + integer :: i + + i = get_key_index(dict, keyname) + n = size(dict%list(i)%d%prefix) + + end function get_prefix_by_keyname_len + + pure function get_prefix_by_keyname(dict, keyname) result(prefix) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + character(len=get_prefix_by_keyname_len(dict,keyname)) :: prefix + integer :: i + + i = get_key_index(dict, keyname) + prefix = str_vs(dict%list(i)%d%prefix) + + end function get_prefix_by_keyname + + pure function get_localname_by_keyname_len(dict, keyname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + integer :: n + + integer :: i + + i = get_key_index(dict, keyname) + n = size(dict%list(i)%d%localName) + + end function get_localname_by_keyname_len + + pure function get_localName_by_keyname(dict, keyname) result(localName) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + character(get_localname_by_keyname_len(dict, keyname)) :: localname + integer :: i + + i=get_key_index(dict, keyname) + localName = str_vs(dict%list(i)%d%localName) + + end function get_localName_by_keyname +#endif + +#ifndef DUMMYLIB + pure function getType_by_index_len(dict, i) result(n) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + integer :: n + + if (i>0.and.i<=ubound(dict%list, 1)) then + n = len_trim(ATT_TYPES(dict%list(i)%d%type)) + else + n = 0 + endif + end function getType_by_index_len +#endif + + function getType_by_index(dict, i) result(type) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=getType_by_index_len(dict, i)) :: type + + if (i>0.and.i<=ubound(dict%list, 1)) then + type = ATT_TYPES(dict%list(i)%d%type) + else + type = "" + endif +#else + character(len=1) :: type + type = "" +#endif + end function getType_by_index + +#ifndef DUMMYLIB + pure function getType_by_keyname_len(dict, keyname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + integer :: n + + integer :: i + i = get_key_index(dict, keyname) + + if (i>0) then + n = len_trim(ATT_TYPES(i)) + else + n = 0 + endif + end function getType_by_keyname_len +#endif + + function getType_by_keyname(dict, keyname) result(type) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname +#ifndef DUMMYLIB + character(len=getType_by_keyname_len(dict, keyname)) :: type + + integer :: i + i = get_key_index(dict, keyname) + if (i>0) then + type = ATT_TYPES(dict%list(i)%d%type) + else + type = "" + endif +#else + character(len=1) :: type + type = "" +#endif + end function getType_by_keyname + + function isSpecified_by_index(dict, i) result(p) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + logical :: p + +#ifndef DUMMYLIB + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%specified + else + p = .false. + endif +#else + p = .false. +#endif + end function isSpecified_by_index + + function isSpecified_by_key(dict, qName) result(p) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: qName + logical :: p + +#ifndef DUMMYLIB + integer :: i + i = getIndex(dict, qName) + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%specified + else + p = .false. + endif +#else + p = .false. +#endif + end function isSpecified_by_key + + subroutine setSpecified(dict, i, p) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + logical, intent(in) :: p + +#ifndef DUMMYLIB + if (i>0.and.i<=ubound(dict%list, 1)) then + dict%list(i)%d%specified = p + endif +#endif + end subroutine setSpecified + + function isSpecified_by_keyNS(dict, uri, localName) result(p) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: uri + character(len=*), intent(in) :: localName + logical :: p + +#ifndef DUMMYLIB + integer :: i + i = getIndex(dict, uri, localName) + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%specified + else + p = .false. + endif +#else + p = .false. +#endif + end function isSpecified_by_keyNS + + function isDeclared_by_index(dict, i) result(p) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + logical :: p + +#ifndef DUMMYLIB + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%declared + else + p = .false. + endif +#else + p = .false. +#endif + end function isDeclared_by_index + + function isDeclared_by_key(dict, qName) result(p) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: qName + logical :: p + +#ifndef DUMMYLIB + integer :: i + i = getIndex(dict, qName) + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%declared + else + p = .false. + endif +#else + p = .false. +#endif + end function isDeclared_by_key + + function isDeclared_by_keyNS(dict, uri, localName) result(p) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: uri + character(len=*), intent(in) :: localName + logical :: p + +#ifndef DUMMYLIB + integer :: i + i = getIndex(dict, uri, localName) + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%declared + else + p = .false. + endif +#else + p = .false. +#endif + end function isDeclared_by_keyNS + + subroutine setDeclared(dict, i, p) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + logical, intent(in) :: p + +#ifndef DUMMYLIB + if (i>0.and.i<=ubound(dict%list, 1)) then + dict%list(i)%d%declared = p + endif +#endif + end subroutine setDeclared + +#ifndef DUMMYLIB + function getIsId_by_index(dict, i) result(p) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + logical :: p + + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%isId + else + p = .false. + endif + + end function getIsId_by_index + + subroutine setIsId_by_index(dict, i, p) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + logical, intent(in) :: p + + if (i>0.and.i<=ubound(dict%list, 1)) then + dict%list(i)%d%isId = p + endif + end subroutine setIsId_by_index + + function getWhitespaceHandling(dict, i) result(j) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + integer :: j + + if (i<=ubound(dict%list, 1)) then + select case(dict%list(i)%d%type) + case (ATT_CDATA) + j = 0 ! + case (ATT_CDAMB) + j = 1 + case default + j = 2 + end select + else + j = 2 + endif + + end function getWhitespaceHandling + + subroutine setBase(dict, base) + type(dictionary_t), intent(inout) :: dict + character(len=*), intent(in) :: base + + if (associated(dict%base)) deallocate(dict%base) + dict%base => vs_str_alloc(base) + end subroutine setBase + + pure function getBase_len(dict) result(n) + type(dictionary_t), intent(in) :: dict + integer :: n + + if (associated(dict%base)) then + n = size(dict%base) + else + n = 0 + endif + end function getBase_len + + function getBase(dict) result(base) + type(dictionary_t), intent(in) :: dict + character(len=getBase_len(dict)) :: base + + if (associated(dict%base)) then + base = str_vs(dict%base) + else + base = "" + endif + end function getBase + + subroutine destroy_dict_item(d) + type(dict_item), pointer :: d + + if (associated(d)) then + deallocate(d%key) + deallocate(d%value) + deallocate(d%nsURI) + deallocate(d%prefix) + deallocate(d%localName) + deallocate(d) + endif + end subroutine destroy_dict_item + + subroutine init_dict(dict) + type(dictionary_t), intent(out) :: dict + + + allocate(dict%list(0:0)) + allocate(dict%list(0)%d) + allocate(dict%list(0)%d%key(0)) + + end subroutine init_dict + + subroutine destroy_dict(dict) + type(dictionary_t), intent(inout) :: dict + integer :: i + + if (associated(dict%list)) then + deallocate(dict%list(0)%d%key) + deallocate(dict%list(0)%d) + do i = 1, ubound(dict%list, 1) + call destroy(dict%list(i)%d) + enddo + deallocate(dict%list) + endif + if (associated(dict%base)) deallocate(dict%base) + + end subroutine destroy_dict + + + subroutine reset_dict(dict) + type(dictionary_t), intent(inout) :: dict + + call destroy_dict(dict) + call init_dict(dict) + + end subroutine reset_dict + + subroutine sortAttrs(dict) + type(dictionary_t), intent(inout) :: dict + + logical :: done(ubound(dict%list, 1)) + type(dict_item_ptr), dimension(:), pointer :: list => null() + integer :: i, j, n, firstIndex + character, pointer :: firstKey(:) + + !Ridiculously naive sort algorithm. We are unlikely + !to ever be sorting more then ten or so attributes though + + n = ubound(dict%list, 1) + + allocate(list(0:n)) + list(0)%d => dict%list(0)%d + + j = 1 + done = .false. + + firstIndex = 1 + do while (firstIndex/=0) + firstIndex = 0 + firstKey => null() + do i = 1, n + if (.not.done(i).and.str_vs(dict%list(i)%d%key)=="xmlns" & + .or. str_vs(dict%list(i)%d%prefix)=="xmlns") then + firstIndex = i + if (associated(firstKey)) then + if (llt(str_vs(dict%list(i)%d%key),str_vs(firstKey))) then + firstIndex = i + firstKey => dict%list(i)%d%key + endif + else + firstIndex = i + firstKey => dict%list(i)%d%key + endif + endif + enddo + if (firstIndex/=0) then + done(firstIndex) = .true. + list(j)%d => dict%list(firstIndex)%d + j = j + 1 + endif + enddo + + do while (any(.not.done)) + firstIndex = 0 + firstKey => null() + do i = 1, n + if (.not.done(i)) then + if (associated(firstKey)) then + if (llt(str_vs(dict%list(i)%d%key),str_vs(firstKey))) then + firstIndex = i + firstKey => dict%list(i)%d%key + endif + else + firstIndex = i + firstKey => dict%list(i)%d%key + endif + endif + enddo + done(firstIndex) = .true. + list(j)%d => dict%list(firstIndex)%d + j = j + 1 + enddo + + deallocate(dict%list) + dict%list => list + + end subroutine sortAttrs + + + subroutine print_dict(dict) + type(dictionary_t), intent(in) :: dict + + integer :: i + + do i = 1, ubound(dict%list, 1) + write(*,'(7a)') str_vs(dict%list(i)%d%key), " [ {", str_vs(dict%list(i)%d%nsURI), & + "}", str_vs(dict%list(i)%d%localName), " ] = ", str_vs(dict%list(i)%d%value) + enddo + + end subroutine print_dict + +#endif +end module m_common_attrs diff --git a/src/xml/common/m_common_buffer.F90 b/src/xml/common/m_common_buffer.F90 new file mode 100644 index 000000000..0bf518362 --- /dev/null +++ b/src/xml/common/m_common_buffer.F90 @@ -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 diff --git a/src/xml/common/m_common_charset.F90 b/src/xml/common/m_common_charset.F90 new file mode 100644 index 000000000..d46a95ec2 --- /dev/null +++ b/src/xml/common/m_common_charset.F90 @@ -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 diff --git a/src/xml/common/m_common_content_model.F90 b/src/xml/common/m_common_content_model.F90 new file mode 100644 index 000000000..1b5df709e --- /dev/null +++ b/src/xml/common/m_common_content_model.F90 @@ -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 diff --git a/src/xml/common/m_common_element.F90 b/src/xml/common/m_common_element.F90 new file mode 100644 index 000000000..5eecbbfdc --- /dev/null +++ b/src/xml/common/m_common_element.F90 @@ -0,0 +1,1645 @@ +module m_common_element + +#ifndef DUMMYLIB + ! Structure and manipulation of element specification + + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc + use fox_m_fsys_string_list, only: string_list, init_string_list, & + destroy_string_list, add_string, tokenize_to_string_list, & + registered_string + use m_common_charset, only: isInitialNameChar, isNameChar, & + upperCase, XML_WHITESPACE + use m_common_content_model, only: content_particle_t, newCP, destroyCPtree, & + OP_MIXED, OP_CHOICE, OP_SEQ, OP_NAME, & + REP_QUESTION_MARK, REP_ASTERISK, & + transformCPPlus ! , dumpCPtree ! For debugging - see below. + use m_common_error, only: error_stack, add_error, in_error + use m_common_namecheck, only: checkName, checkNames, checkNCName, & + checkNCNames, checkQName, checkNmtoken, checkNmtokens + + implicit none + private + + integer, parameter :: ST_START = 0 + integer, parameter :: ST_EMPTYANY = 1 + integer, parameter :: ST_FIRSTCHILD = 2 + integer, parameter :: ST_END = 3 + integer, parameter :: ST_PCDATA = 4 + integer, parameter :: ST_NAME = 5 + integer, parameter :: ST_CHILD = 6 + integer, parameter :: ST_AFTERBRACKET = 7 + integer, parameter :: ST_AFTERLASTBRACKET = 8 + integer, parameter :: ST_SEPARATOR = 9 + integer, parameter :: ST_AFTERNAME = 10 + integer, parameter :: ST_ATTTYPE = 11 + integer, parameter :: ST_AFTER_NOTATION = 12 + integer, parameter :: ST_NOTATION_LIST = 13 + integer, parameter :: ST_ENUMERATION = 14 + integer, parameter :: ST_ENUM_NAME = 15 + integer, parameter :: ST_AFTER_ATTTYPE_SPACE = 16 + integer, parameter :: ST_AFTER_ATTTYPE = 17 + integer, parameter :: ST_DEFAULT_DECL = 18 + integer, parameter :: ST_AFTERDEFAULTDECL = 19 + integer, parameter :: ST_DEFAULTVALUE = 20 + + integer, parameter :: ATT_NULL = 0 + + integer, parameter :: ATT_CDATA = 1 + integer, parameter :: ATT_ID = 2 + integer, parameter :: ATT_IDREF = 3 + integer, parameter :: ATT_IDREFS = 4 + integer, parameter :: ATT_ENTITY = 5 + integer, parameter :: ATT_ENTITIES = 6 + integer, parameter :: ATT_NMTOKEN = 7 + integer, parameter :: ATT_NMTOKENS = 8 + integer, parameter :: ATT_NOTATION = 9 + integer, parameter :: ATT_ENUM = 10 + integer, parameter :: ATT_CDANO = 11 + integer, parameter :: ATT_CDAMB = 12 + + character(len=8), parameter :: ATT_TYPES(12) = (/ & + "CDATA ", & + "ID ", & + "IDREF ", & + "IDREFS ", & + "ENTITY ", & + "ENTITIES", & + "NMTOKEN ", & + "NMTOKENS", & + "NOTATION", & + "ENUM ", & + "CDANO ", & + "CDAMB "/) + + integer, parameter :: ATT_REQUIRED = 1 + integer, parameter :: ATT_IMPLIED = 2 + integer, parameter :: ATT_DEFAULT = 4 + integer, parameter :: ATT_FIXED = 3 + + + type attribute_t + character, pointer :: name(:) => null() + integer :: attType = ATT_NULL + integer :: attDefault = ATT_NULL + type(string_list) :: enumerations + character, pointer :: default(:) => null() + logical :: internal = .true. + end type attribute_t + + type attribute_list + type(attribute_t), pointer :: list(:) => null() + end type attribute_list + + type element_t + character, pointer :: name(:) => null() + logical :: empty = .false. + logical :: any = .false. + logical :: mixed = .false. + logical :: id_declared = .false. + logical :: internal = .true. + type (content_particle_t), pointer :: cp => null() + character, pointer :: model(:) => null() + type(attribute_list) :: attlist + end type element_t + + type element_list + type(element_t), pointer :: list(:) => null() + end type element_list + + + public :: element_t + public :: element_list + + public :: attribute_t + public :: attribute_list + + public :: init_element_list + public :: destroy_element_list + public :: existing_element + public :: declared_element + public :: get_element + public :: add_element + + public :: parse_dtd_element + + public :: init_attribute_list + public :: destroy_attribute_list + + + public :: parse_dtd_attlist + + public :: report_declarations + + public :: attribute_has_default + public :: get_attlist_size + public :: get_attribute_declaration + public :: express_attribute_declaration + + public :: att_value_normalize + + public :: get_att_type_enum + + public :: ATT_NULL + public :: ATT_CDATA + public :: ATT_ID + public :: ATT_IDREF + public :: ATT_IDREFS + public :: ATT_ENTITY + public :: ATT_ENTITIES + public :: ATT_NMTOKEN + public :: ATT_NMTOKENS + public :: ATT_NOTATION + public :: ATT_ENUM + + public :: ATT_CDANO + public :: ATT_CDAMB + + public :: ATT_REQUIRED + public :: ATT_IMPLIED + public :: ATT_DEFAULT + public :: ATT_FIXED + + public :: ATT_TYPES + + interface get_attribute_declaration + module procedure get_attdecl_by_index + module procedure get_attdecl_by_name + end interface + +contains + + subroutine init_element_list(e_list) + type(element_list), intent(inout) :: e_list + + allocate(e_list%list(0)) + end subroutine init_element_list + + subroutine destroy_element_list(e_list) + type(element_list), intent(inout) :: e_list + + integer :: i + + do i = 1, size(e_list%list) + deallocate(e_list%list(i)%name) + if (associated(e_list%list(i)%cp)) call destroyCPtree(e_list%list(i)%cp) + if (associated(e_list%list(i)%model)) deallocate(e_list%list(i)%model) + call destroy_attribute_list(e_list%list(i)%attlist) + enddo + deallocate(e_list%list) + end subroutine destroy_element_list + + function existing_element(e_list, name) result(p) + type(element_list), intent(in) :: e_list + character(len=*), intent(in) :: name + logical :: p + + integer :: i + + p = .false. + do i = 1, size(e_list%list) + if (str_vs(e_list%list(i)%name)==name) then + p = .true. + exit + endif + enddo + end function existing_element + + function declared_element(e_list, name) result(p) + type(element_list), intent(in) :: e_list + character(len=*), intent(in) :: name + logical :: p + + integer :: i + + p = .false. + do i = 1, size(e_list%list) + if (str_vs(e_list%list(i)%name)==name) then + p = associated(e_list%list(i)%model) + exit + endif + enddo + end function declared_element + + function get_element(e_list, name) result(e) + type(element_list), intent(in) :: e_list + character(len=*), intent(in) :: name + type(element_t), pointer :: e + + integer :: i + + do i = 1, size(e_list%list) + if (str_vs(e_list%list(i)%name)==name) then + e => e_list%list(i) + return + endif + enddo + e => null() + end function get_element + + function add_element(e_list, name) result(e) + type(element_list), intent(inout) :: e_list + character(len=*), intent(in) :: name + type(element_t), pointer :: e + + type(element_t), pointer :: temp(:) + integer :: i + + temp => e_list%list + + allocate(e_list%list(size(temp)+1)) + do i = 1, size(temp) + e_list%list(i)%name => temp(i)%name + e_list%list(i)%model => temp(i)%model + e_list%list(i)%empty = temp(i)%empty + e_list%list(i)%any = temp(i)%any + e_list%list(i)%mixed = temp(i)%mixed + e_list%list(i)%cp => temp(i)%cp + e_list%list(i)%id_declared = temp(i)%id_declared + e_list%list(i)%internal = temp(i)%internal + e_list%list(i)%attlist%list => temp(i)%attlist%list + enddo + deallocate(temp) + e => e_list%list(i) + e%name => vs_str_alloc(name) + call init_attribute_list(e%attlist) + + end function add_element + + subroutine parse_dtd_element(contents, xv, stack, element, internal) + character(len=*), intent(in) :: contents + integer, intent(in) :: xv + type(error_stack), intent(inout) :: stack + type(element_t), pointer :: element + logical, intent(in) :: internal + + integer :: state + integer :: i, nbrackets + logical :: mixed, empty, any + character :: c + character, pointer :: order(:), name(:), temp(:) + type(content_particle_t), pointer :: top, current, tcp + logical :: mixed_additional, firstChild + + ! FIXME should we check namespaces here (for element names) + ! checking duplicates - valid or wf? - and only for MIXED? + + order => null() + name => null() + temp => null() + + any = .false. + empty = .false. + mixed = .false. + nbrackets = 0 + mixed_additional = .false. + firstChild = .true. + state = ST_START + + top => null() + + do i = 1, len(contents) + 1 + if (i<=len(contents)) then + c = contents(i:i) + else + c = ' ' + endif + + if (state==ST_START) then + !write(*,*)'ST_START' + if (verify(c, XML_WHITESPACE)==0) then + continue + elseif (verify(c, 'EMPTYANY')==0) then + name => vs_str_alloc(c) + state = ST_EMPTYANY + elseif (c=='(') then + order => vs_str_alloc(" ") + nbrackets = 1 + top => newCP() + current => top + state = ST_FIRSTCHILD + else + call add_error(stack, & + 'Unexpected character "'//c//'" at start of ELEMENT specification') + goto 100 + endif + + elseif (state==ST_EMPTYANY) then + !write(*,*)'ST_EMPTYANY' + if (verify(c, upperCase)==0) then + temp => name + name => vs_str_alloc(str_vs(temp)//c) + deallocate(temp) + elseif (verify(c, XML_WHITESPACE)==0) then + if (str_vs(name)=='EMPTY') then + empty = .true. + top => newCP(empty=.true.) + current => top + elseif (str_vs(name)=='ANY') then + any = .true. + top => newCP(any=.true.) + current => top + else + call add_error(stack, & + 'Unexpected ELEMENT specification; expecting EMPTY or ANY') + goto 100 + endif + deallocate(name) + state = ST_END + else + call add_error(stack, & + 'Unexpected ELEMENT specification; expecting EMPTY or ANY') + goto 100 + endif + + elseif (state==ST_FIRSTCHILD) then + !write(*,*)'ST_FIRSTCHILD' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='#') then + mixed = .true. + state = ST_PCDATA + name => vs_str_alloc("") + elseif (isInitialNameChar(c, xv)) then + allocate(name(1)) + name(1) = c + state = ST_NAME + elseif (c=='(') then + nbrackets = nbrackets + 1 + deallocate(order) + tcp => newCP() + current%firstChild => tcp + tcp%parent => current + current => tcp + order => vs_str_alloc(" ") + state = ST_CHILD + else + call add_error(stack, & + 'Unexpected character in ELEMENT specification') + goto 100 + endif + + elseif (state==ST_PCDATA) then + !write(*,*)'ST_PCDATA' + if (verify(c, 'PCDATA')==0) then + temp => name + name => vs_str_alloc(str_vs(temp)//c) + deallocate(temp) + elseif (verify(c, XML_WHITESPACE)==0) then + if (str_vs(name)=='PCDATA') then + deallocate(name) + else + call add_error(stack, & + 'Unexpected token after #') + goto 100 + endif + ! Must be first child + current%operator = OP_MIXED + tcp => newCP(name="#PCDATA") + current%firstChild => tcp + tcp%parent => current + current => tcp + firstChild = .false. + state = ST_SEPARATOR + elseif (c==')') then + if (str_vs(name)=='PCDATA') then + deallocate(name) + nbrackets = 0 + state = ST_AFTERLASTBRACKET + deallocate(order) + else + call add_error(stack, & + 'Unexpected token after #') + goto 100 + endif + ! Must be first child + current%operator = OP_MIXED + tcp => newCP(name="#PCDATA") + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + elseif (c=='|') then + if (str_vs(name)=='PCDATA') then + firstChild = .false. + deallocate(name) + else + call add_error(stack, & + 'Unexpected token after #') + goto 100 + endif + ! Must be first child + current%operator = OP_MIXED + tcp => newCP(name="#PCDATA") + current%firstChild => tcp + tcp%parent => current + current => tcp + firstChild = .false. + order(1) = '|' + state = ST_CHILD + elseif (c==',') then + call add_error(stack, & + 'Ordered specification not allowed for Mixed elements') + goto 100 + else + call add_error(stack, & + 'Unexpected character in ELEMENT specification') + goto 100 + endif + + elseif (state==ST_NAME) then + !write(*,*)'ST_NAME' + if (isNameChar(c, xv)) then + temp => name + name => vs_str_alloc(str_vs(temp)//c) + deallocate(temp) + elseif (scan(c, "?+*")>0) then + if (mixed) then + call add_error(stack, & + 'Repeat operators forbidden for Mixed elements') + goto 100 + endif + tcp => newCP(name=str_vs(name), repeat=c) + deallocate(name) + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + else + current%nextSibling => tcp + tcp%parent => current%parent + endif + current => tcp + if (c=="+") call transformCPPlus(current) + state = ST_SEPARATOR + elseif (verify(c, XML_WHITESPACE)==0) then + if (mixed) mixed_additional = .true. + tcp => newCP(name=str_vs(name)) + deallocate(name) + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + else + current%nextSibling => tcp + tcp%parent => current%parent + endif + current => tcp + state = ST_SEPARATOR + elseif (scan(c,',|')>0) then + if (order(nbrackets)=='') then + order(nbrackets)=c + elseif (order(nbrackets)/=c) then + call add_error(stack, & + 'Cannot mix ordered and unordered elements') + goto 100 + endif + if (mixed) mixed_additional = .true. + tcp => newCP(name=str_vs(name)) + deallocate(name) + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + else + current%nextSibling => tcp + tcp%parent => current%parent + endif + current => tcp + if (c=="|".and.current%parent%operator/=OP_MIXED) & + current%parent%operator = OP_CHOICE + state = ST_CHILD + elseif (c==')') then + if (mixed) mixed_additional = .true. + nbrackets = nbrackets - 1 + if (nbrackets==0) then + state = ST_AFTERLASTBRACKET + deallocate(order) + else + temp => order + allocate(order(nbrackets)) + order = temp(:size(order)) + deallocate(temp) + state = ST_AFTERBRACKET + endif + tcp => newCP(name=str_vs(name)) + deallocate(name) + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + else + current%nextSibling => tcp + tcp%parent => current%parent + current => current%parent + if (.not.check_duplicates(current)) & + goto 100 + endif + else + call add_error(stack, & + 'Unexpected character found after element name') + goto 100 + endif + + elseif (state==ST_CHILD) then + !write(*,*)'ST_CHILD' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='#') then + call add_error(stack, & + '# forbidden except as first child element') + goto 100 + elseif (isInitialNameChar(c, xv)) then + name => vs_str_alloc(c) + state = ST_NAME + elseif (c=='(') then + if (mixed) then + call add_error(stack, & + 'Nested brackets forbidden for Mixed content') + goto 100 + endif + tcp => newCP() + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + else + current%nextSibling => tcp + tcp%parent => current%parent + firstChild = .true. + endif + current => tcp + nbrackets = nbrackets + 1 + temp => order + order => vs_str_alloc(str_vs(temp)//" ") + deallocate(temp) + else + call add_error(stack, & + 'Unexpected character "'//c//'" found after (') + goto 100 + endif + + elseif (state==ST_SEPARATOR) then + !write(*,*)'ST_SEPARATOR' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='#') then + call add_error(stack, & + '#PCDATA must be first in list') + goto 100 + elseif (scan(c,'|,')>0) then + if (order(nbrackets)=='') then + order(nbrackets) = c + elseif (order(nbrackets)/=c) then + call add_error(stack, & + 'Cannot mix ordered and unordered elements') + goto 100 + endif + if (c=="|".and.current%parent%operator/=OP_MIXED) & + current%parent%operator = OP_CHOICE + state = ST_CHILD + elseif (c==')') then + nbrackets = nbrackets - 1 + if (nbrackets==0) then + state = ST_AFTERLASTBRACKET + deallocate(order) + else + temp => order + allocate(order(nbrackets)) + order = temp(:size(order)) + deallocate(temp) + state = ST_AFTERBRACKET + endif + current => current%parent + if (.not.check_duplicates(current)) & + goto 100 + else + call add_error(stack, & + 'Unexpected character found in element declaration.') + goto 100 + endif + + elseif (state==ST_AFTERBRACKET) then + !write(*,*)'ST_AFTERBRACKET' + if (c=='*') then + current%repeater = REP_ASTERISK + state = ST_SEPARATOR + elseif (c=='+') then + call transformCPPlus(current) + state = ST_SEPARATOR + elseif (c=='?') then + current%repeater = REP_QUESTION_MARK + state = ST_SEPARATOR + elseif (verify(c, XML_WHITESPACE)==0) then + state = ST_SEPARATOR + elseif (scan(c,'|,')>0) then + if (order(nbrackets)=='') then + order(nbrackets) = c + elseif (order(nbrackets)/=c) then + call add_error(stack, & + 'Cannot mix ordered and unordered elements') + goto 100 + endif + if (c=="|".and.current%parent%operator/=OP_MIXED) & + current%parent%operator = OP_CHOICE + state = ST_CHILD + elseif (c==')') then + nbrackets = nbrackets - 1 + if (nbrackets==0) then + deallocate(order) + state = ST_AFTERLASTBRACKET + else + temp => order + allocate(order(nbrackets)) + order = temp(:size(order)) + deallocate(temp) + state = ST_AFTERBRACKET + endif + current => current%parent + if (.not.check_duplicates(current)) & + goto 100 + else + call add_error(stack, & + 'Unexpected character "'//c//'"found after ")"') + goto 100 + endif + + elseif (state==ST_AFTERLASTBRACKET) then + !write(*,*)'ST_AFTERLASTBRACKET' + if (c=='*') then + state = ST_END + current%repeater = REP_ASTERISK + elseif (c=='+') then + if (mixed) then + call add_error(stack, & + '+ operator disallowed for Mixed elements') + goto 100 + endif + call transformCPPlus(current) + state = ST_END + elseif (c=='?') then + if (mixed) then + call add_error(stack, & + '? operator disallowed for Mixed elements') + goto 100 + endif + current%repeater = REP_QUESTION_MARK + state = ST_END + elseif (verify(c, XML_WHITESPACE)==0) then + if (mixed) then + if (mixed_additional) then + call add_error(stack, & + 'Missing "*" at end of Mixed element specification') + goto 100 + endif + endif + state = ST_END + else + call add_error(stack, & + 'Unexpected character "'//c//'" found after final ")"') + goto 100 + endif + + elseif (state==ST_END) then + !write(*,*)'ST_END' + if (verify(c, XML_WHITESPACE)==0) then + continue + else + call add_error(stack, & + 'Unexpected token found after end of element specification') + goto 100 + endif + + endif + + enddo + + if (state/=ST_END) then + call add_error(stack, "Error in parsing contents of element declaration") + goto 100 + endif + + if (associated(element)) then + element%any = any + element%empty = empty + element%mixed = mixed + element%model => vs_str_alloc(trim(strip_spaces(contents))) + element%cp => top + element%internal = internal +! For debugging it may be useful to dump the result here... +! Also need to use the subroutine. +! call dumpCPtree(top) + else + if (associated(top)) call destroyCPtree(top) + endif + return + +100 if (associated(order)) deallocate(order) + if (associated(name)) deallocate(name) + if (associated(top)) call destroyCPtree(top) + + contains + function strip_spaces(s1) result(s2) + character(len=*) :: s1 + character(len=len(s1)) :: s2 + integer :: i, i2 + i2 = 1 + do i = 1, len(s1) + if (verify(s1(i:i), XML_WHITESPACE)==0) cycle + s2(i2:i2) = s1(i:i) + i2 = i2 + 1 + end do + s2(i2:) = '' + end function strip_spaces + + function check_duplicates(cp) result(p) + type(content_particle_t), pointer :: cp + logical :: p + + type(string_list) :: sl + type(content_particle_t), pointer :: tcp + + if (cp%operator==OP_SEQ) then + p = .true. + return + endif + + call init_string_list(sl) + tcp => cp%firstChild + p = .false. + do while (associated(tcp)) + if (tcp%operator==OP_NAME) then + if (registered_string(sl, str_vs(tcp%name))) then + call destroy_string_list(sl) + if (cp%operator==OP_MIXED) then + call add_error(stack, & + "Duplicate element names found in MIXED") + elseif (cp%operator==OP_CHOICE) then + call add_error(stack, & + "Duplicate element names found in CHOICE") + endif + return + else + call add_string(sl, str_vs(tcp%name)) + endif + endif + tcp => tcp%nextSibling + enddo + p = .true. + call destroy_string_list(sl) + end function check_duplicates + end subroutine parse_dtd_element + + + subroutine init_attribute_list(a_list) + type(attribute_list), intent(inout) :: a_list + + allocate(a_list%list(0)) + end subroutine init_attribute_list + + subroutine destroy_attribute_t(a) + type(attribute_t), pointer :: a + + if (associated(a%name)) deallocate(a%name) + if (associated(a%default)) deallocate(a%default) + call destroy_string_list(a%enumerations) + + deallocate(a) + end subroutine destroy_attribute_t + + subroutine destroy_attribute_list(a_list) + type(attribute_list), intent(inout) :: a_list + + integer :: i + + do i = 1, size(a_list%list) + deallocate(a_list%list(i)%name) + if (associated(a_list%list(i)%default)) deallocate(a_list%list(i)%default) + call destroy_string_list(a_list%list(i)%enumerations) + enddo + deallocate(a_list%list) + + end subroutine destroy_attribute_list + + function existing_attribute(a_list, name) result(p) + type(attribute_list), intent(inout) :: a_list + character(len=*), intent(in) :: name + logical :: p + + integer :: i + p = .false. + do i = 1, size(a_list%list) + p = (str_vs(a_list%list(i)%name)==name) + if (p) exit + enddo + end function existing_attribute + + function add_attribute(a_list, name, internal) result(a) + type(attribute_list), intent(inout) :: a_list + character(len=*), intent(in) :: name + logical, intent(in) :: internal + type(attribute_t), pointer :: a + + integer :: i + type(attribute_t), pointer :: temp(:) + + temp => a_list%list + allocate(a_list%list(size(temp)+1)) + do i = 1, size(temp) + a_list%list(i)%name => temp(i)%name + a_list%list(i)%atttype = temp(i)%atttype + a_list%list(i)%attdefault = temp(i)%attdefault + a_list%list(i)%default => temp(i)%default + a_list%list(i)%enumerations%list => temp(i)%enumerations%list + a_list%list(i)%internal = temp(i)%internal + enddo + deallocate(temp) + a => a_list%list(i) + + a%name => vs_str_alloc(name) + call init_string_list(a%enumerations) + a%internal = internal + + end function add_attribute + + function get_attribute(a_list, name) result(a) + type(attribute_list), intent(inout) :: a_list + character(len=*), intent(in) :: name + type(attribute_t), pointer :: a + + integer :: i + do i = 1, size(a_list%list) + if (str_vs(a_list%list(i)%name)==name) then + a => a_list%list(i) + exit + endif + enddo + end function get_attribute + + subroutine parse_dtd_attlist(contents, xv, namespaces, validCheck, stack, elem, internal) + character(len=*), intent(in) :: contents + integer, intent(in) :: xv + logical, intent(in) :: validCheck + logical, intent(in) :: namespaces + type(error_stack), intent(inout) :: stack + type(element_t), pointer :: elem + logical, intent(in) :: internal + + integer :: i + integer :: state + character :: c, q + character, pointer :: name(:), attType(:), default(:), value(:), temp(:) + + type(attribute_t), pointer :: ca + type(attribute_t), pointer :: ignore_att + + ignore_att => null() + ! We need ignore_att to process but not take account of duplicate attributes + ! elem is optional so we can not record declarations if necessary. + ca => null() + name => null() + attType => null() + default => null() + value => null() + temp => null() + + state = ST_START + + do i = 1, len(contents) + 1 + if (in_error(stack)) exit + if (i<=len(contents)) then + c = contents(i:i) + else + c = " " + endif + + if (state==ST_START) then + !write(*,*)'ST_START' + if (verify(c, XML_WHITESPACE)==0) cycle + if (isInitialNameChar(c, xv)) then + name => vs_str_alloc(c) + state = ST_NAME + else + call add_error(stack, & + 'Unexpected character in Attlist') + endif + + elseif (state==ST_NAME) then + !write(*,*)'ST_NAME' + if (isNameChar(c, xv)) then + temp => vs_str_alloc(str_vs(name)//c) + deallocate(name) + name => temp + elseif (verify(c, XML_WHITESPACE)==0) then + if (namespaces.and..not.checkQName(str_vs(name), xv)) then + call add_error(stack, & + "Attribute name in ATTLIST must be QName") + elseif (associated(elem)) then + if (existing_attribute(elem%attlist, str_vs(name))) then + if (associated(ignore_att)) call destroy_attribute_t(ignore_att) + allocate(ignore_att) + call init_string_list(ignore_att%enumerations) + ignore_att%name => vs_vs_alloc(name) + ca => ignore_att + else + ca => add_attribute(elem%attlist, str_vs(name), internal) + endif + else + if (associated(ignore_att)) call destroy_attribute_t(ignore_att) + allocate(ignore_att) + call init_string_list(ignore_att%enumerations) + ignore_att%name => vs_vs_alloc(name) + ca => ignore_att + endif + deallocate(name) + state = ST_AFTERNAME + else + call add_error(stack, & + 'Unexpected character in Attlist Name') + endif + + elseif (state==ST_AFTERNAME) then + !write(*,*)'ST_AFTERNAME' + if (verify(c, XML_WHITESPACE)==0) cycle + if (verify(c, upperCase)==0) then + attType => vs_str_alloc(c) + state = ST_ATTTYPE + elseif (c=='(') then + allocate(value(0)) + ca%attType = ATT_ENUM + state = ST_ENUMERATION + else + call add_error(stack, & + 'Unexpected error after Attlist Name') + endif + + elseif (state==ST_ATTTYPE) then + !write(*,*)'ST_ATTTYPE' + if (verify(c, upperCase)==0) then + temp => attType + attType => vs_str_alloc(str_vs(temp)//c) + deallocate(temp) + elseif (verify(c, XML_WHITESPACE)==0) then + ! xml:id constraint + if (str_vs(ca%name)=="xml:id" & + .and..not.str_vs(attType)=="ID") then + call add_error(stack, & + "xml:id attribute must be declared as type ID") + elseif (str_vs(attType)=='CDATA') then + ca%attType = ATT_CDATA + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='ID') then + if (validCheck) then + ! Validity Constraint: One ID per Element Type + if (associated(elem)) then + if (elem%id_declared) then + call add_error(stack, & + "Cannot have two declared attributes of type ID on one element type.") + else + elem%id_declared = .true. + endif + endif + endif + ca%attType = ATT_ID + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='IDREF') then + ca%attType = ATT_IDREF + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='IDREFS') then + ca%attType = ATT_IDREFS + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='ENTITY') then + ca%attType = ATT_ENTITY + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='ENTITIES') then + ca%attType = ATT_ENTITIES + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='NMTOKEN') then + ca%attType = ATT_NMTOKEN + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='NMTOKENS') then + ca%attType = ATT_NMTOKENS + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='NOTATION') then + ca%attType = ATT_NOTATION + state = ST_AFTER_NOTATION + else + call add_error(stack, & + 'Unknown AttType') + endif + deallocate(attType) + else + call add_error(stack, & + 'Unexpected character in AttType') + endif + + elseif (state==ST_AFTER_NOTATION) then + !write(*,*)'ST_AFTER_NOTATION' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='(') then + state = ST_NOTATION_LIST + else + call add_error(stack, & + 'Unexpected character after Notation') + endif + + elseif (state==ST_NOTATION_LIST) then + !write(*,*)'ST_NOTATION_LIST' + if (verify(c, XML_WHITESPACE)==0) cycle + if (isInitialNameChar(c, xv)) then + value => vs_str_alloc(c) + state = ST_ENUM_NAME + else + call add_error(stack, & + 'Unexpected character in Notation list') + endif + + elseif (state==ST_ENUMERATION) then + !write(*,*)'ST_ENUMERATION' + if (verify(c, XML_WHITESPACE)==0) cycle + if (isNameChar(c, xv)) then + temp => vs_str_alloc(str_vs(value)//c) + deallocate(value) + value => temp + state = ST_ENUM_NAME + elseif (c=='|') then + call add_error(stack, & + "Missing token in Enumeration") + elseif (c==')') then + call add_error(stack, & + "Missing tokens in Enumeration") + else + call add_error(stack, & + 'Unexpected character in attlist enumeration') + endif + + elseif (state==ST_ENUM_NAME) then + !write(*,*)'ST_ENUM_NAME' + if (isNameChar(c, xv)) then + temp => vs_str_alloc(str_vs(value)//c) + deallocate(value) + value => temp + elseif (verify(c, XML_WHITESPACE)==0) then + if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then + call add_error(stack, & + "Duplicate enumeration value in ATTLIST") + elseif (namespaces.and.ca%attType==ATT_NOTATION & + .and..not.checkNCName(str_vs(value), xv)) then + call add_error(stack, & + "Notation name must be NCName") + else + call add_string(ca%enumerations, str_vs(value)) + endif + deallocate(value) + state = ST_SEPARATOR + elseif (c=='|') then + if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then + call add_error(stack, & + "Duplicate enumeration value in ATTLIST") + elseif (namespaces.and.ca%attType==ATT_NOTATION & + .and..not.checkNCName(str_vs(value), xv)) then + call add_error(stack, & + "Notation name must be NCName") + else + call add_string(ca%enumerations, str_vs(value)) + endif + deallocate(value) + if (ca%attType==ATT_NOTATION) then + state = ST_NOTATION_LIST + else + allocate(value(0)) + state = ST_ENUMERATION + endif + elseif (c==')') then + if (size(value)==0) then + call add_error(stack, & + 'Missing token in Enumeration list') + endif + if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then + call add_error(stack, & + "Duplicate enumeration value in ATTLIST") + elseif (namespaces.and.ca%attType==ATT_NOTATION & + .and..not.checkNCName(str_vs(value), xv)) then + call add_error(stack, & + "Notation name must be NCName") + else + call add_string(ca%enumerations, str_vs(value)) + endif + deallocate(value) + state = ST_AFTER_ATTTYPE_SPACE + else + call add_error(stack, & + 'Unexpected character in attlist enumeration') + endif + + elseif (state==ST_SEPARATOR) then + !write(*,*)'ST_SEPARATOR' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='|') then + if (ca%attType==ATT_NOTATION) then + state = ST_NOTATION_LIST + else + allocate(value(0)) + state = ST_ENUMERATION + endif + elseif (c==')') then + state = ST_AFTER_ATTTYPE_SPACE + else + call add_error(stack, & + 'Unexpected character in attlist enumeration') + endif + + elseif (state==ST_AFTER_ATTTYPE_SPACE) then + if (verify(c, XML_WHITESPACE)/=0) then + call add_error(stack, & + 'Missing whitespace in attlist enumeration') + endif + state = ST_AFTER_ATTTYPE + + elseif (state==ST_AFTER_ATTTYPE) then + !write(*,*)'ST_AFTER_ATTTYPE' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='#') then + allocate(default(0)) + state = ST_DEFAULT_DECL + elseif (c=='"'.or.c=="'") then + if (validCheck) then + ! Validity Constraint: ID Attribute Default + if (ca%attType==ATT_ID) & + call add_error(stack, & + "Attribute of type ID may not have default value") + endif + ca%attDefault = ATT_DEFAULT + q = c + allocate(value(0)) + state = ST_DEFAULTVALUE + else + call add_error(stack, & + 'Unexpected character after AttType') + endif + + elseif (state==ST_DEFAULT_DECL) then + !write(*,*)'ST_DEFAULT_DECL' + if (verify(c, upperCase)==0) then + temp => vs_str_alloc(str_vs(default)//c) + deallocate(default) + default => temp + elseif (verify(c, XML_WHITESPACE)==0) then + if (str_vs(default)=='REQUIRED') then + ca%attdefault = ATT_REQUIRED + deallocate(default) + state = ST_START + elseif (str_vs(default)=='IMPLIED') then + ca%attdefault = ATT_IMPLIED + deallocate(default) + state = ST_START + elseif (str_vs(default)=='FIXED') then + if (validCheck) then + ! Validity Constraint: ID Attribute Default + if (ca%attType==ATT_ID) & + call add_error(stack, & + "Attribute of type ID may not have FIXED value") + endif + ca%attdefault = ATT_FIXED + deallocate(default) + state = ST_AFTERDEFAULTDECL + else + call add_error(stack, & + 'Unknown Default declaration') + endif + else + call add_error(stack, & + 'Unexpected character in Default declaration') + endif + + elseif (state==ST_AFTERDEFAULTDECL) then + !write(*,*)'ST_AFTERDEFAULTDECL' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='"') then + q = c + allocate(value(0)) + state = ST_DEFAULTVALUE + elseif (c=="'") then + q = c + allocate(value(0)) + state = ST_DEFAULTVALUE + else + call add_error(stack, & + 'Unexpected character after Default declaration') + endif + + elseif (state==ST_DEFAULTVALUE) then + !write(*,*)'ST_DEFAULTVALUE' + if (c==q) then + if (ca%attType/=ATT_CDATA) then + temp => vs_str_alloc(att_value_normalize(str_vs(value))) + deallocate(value) + value => temp + endif + if (validCheck) then + select case(ca%attType) + ! Can't have ID with defaults + case (ATT_IDREF) + ! VC: IDREF + if (namespaces) then + if (.not.checkNCName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type IDREF must have a value which is an XML NCName") + else + if (.not.checkName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type IDREF must have a value which is an XML Name") + endif + case (ATT_IDREFS) + ! VC: IDREF + if (namespaces) then + if (.not.checkNCNames(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type IDREFS must have a value which contains only XML NCNames") + else + if (.not.checkNames(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type IDREFS must have a value which contains only XML Names") + endif + case (ATT_ENTITY) + ! VC: Entity Name + if (namespaces) then + if (.not.checkNCName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENTITY must have a value which is an XML NCName") + else + if (.not.checkName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENTITY must have a value which is an XML Name") + endif + case (ATT_ENTITIES) + ! VC: Entity Name + if (namespaces) then + if (.not.checkNames(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENTITIES must have a value which contains only XML NCNames") + else + if (.not.checkNames(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENTITIES must have a value which contains only XML Names") + endif + case (ATT_NMTOKEN) + ! VC Name Token + if (.not.checkNmtoken(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type NMTOKEN must have a value which is a NMTOKEN") + case (ATT_NMTOKENS) + ! VC: Name Token + if (.not.checkNmtokens(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type NMTOKENS must have a value which contain only NMTOKENs") + case (ATT_NOTATION) + ! VC: Notation Attributes + if (namespaces) then + if (.not.checkNCName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type NOTATION must have a value which is an XMLNCName") + else + if (.not.checkName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type NOTATION must have a value which is an XML Name") + endif + case (ATT_ENUM) + ! VC: Enumeration + if (.not.checkNmtoken(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENUM must have a value which is an NMTOKENs") + if (.not.registered_string(ca%enumerations, str_vs(value))) & + call add_error(stack, & + "Default value of ENUM does not match permitted values") + end select + endif + if (.not.in_error(stack)) then + if (ca%attType==ATT_ENTITIES) then + call destroy_string_list(ca%enumerations) + ca%enumerations = tokenize_to_string_list(str_vs(value)) + endif + ca%default => value + value => null() + state = ST_START + endif + else + temp => vs_str_alloc(str_vs(value)//c) + deallocate(value) + value => temp + endif + + endif + + enddo + + if (associated(ignore_att)) call destroy_attribute_t(ignore_att) + + if (.not.in_error(stack)) then + if (state==ST_START) then + return + else + call add_error(stack, & + 'Incomplete Attlist declaration') + endif + endif + + if (associated(name)) deallocate(name) + if (associated(attType)) deallocate(attType) + if (associated(default)) deallocate(default) + if (associated(value)) deallocate(value) + + end subroutine parse_dtd_attlist + + subroutine report_declarations(elem, attributeDecl_handler) + type(element_t), intent(in) :: elem + interface + 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 + end interface + + integer :: i + character(len=8) :: type + character(len=8) :: mode + type(attribute_t), pointer :: a + + do i = 1, size(elem%attlist%list) + a => elem%attlist%list(i) + type = ATT_TYPES(a%attType) + select case (a%attDefault) + case (ATT_REQUIRED) + mode = "REQUIRED" + case (ATT_IMPLIED) + mode = "IMPLIED" + case (ATT_FIXED) + mode = "FIXED" + end select + + if (a%attType==ATT_NOTATION) then + if (a%attDefault==ATT_DEFAULT) then + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + 'NOTATION '//make_token_group(a%enumerations), value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + 'NOTATION '//make_token_group(a%enumerations)) + endif + else + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + 'NOTATION '//make_token_group(a%enumerations), mode=trim(mode), & + value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + 'NOTATION '//make_token_group(a%enumerations), mode=trim(mode)) + endif + endif + elseif (a%attType==ATT_ENUM) then + if (a%attDefault==ATT_DEFAULT) then + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + make_token_group(a%enumerations), value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + make_token_group(a%enumerations)) + endif + else + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + make_token_group(a%enumerations), mode=trim(mode), & + value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + make_token_group(a%enumerations), mode=trim(mode)) + endif + endif + else + if (a%attDefault==ATT_DEFAULT) then + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + trim(type), value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + trim(type)) + endif + else + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + trim(type), mode=trim(mode), value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + trim(type), mode=trim(mode)) + endif + endif + endif + enddo + + + end subroutine report_declarations + + pure function make_token_group_len(s_list) result(n) + type(string_list), intent(in) :: s_list + integer :: n + + integer :: i + n = size(s_list%list) + 1 + do i = 1, size(s_list%list) + n = n + size(s_list%list(i)%s) + enddo + end function make_token_group_len + + function make_token_group(s_list) result(s) + type(string_list), intent(in) :: s_list + character(len=make_token_group_len(s_list)) :: s + + integer :: i, m, n + s(1:1) = '(' + n = 2 + do i = 1, size(s_list%list)-1 + m = size(s_list%list(i)%s) + s(n:n+m) = str_vs(s_list%list(i)%s)//'|' + n = n + m + 1 + enddo + s(n:) = str_vs(s_list%list(i)%s)//')' + end function make_token_group + + function attribute_has_default(att) result(p) + type(attribute_t), pointer :: att + logical :: p + + if (associated(att)) then + p = att%attDefault==ATT_DEFAULT.or.att%attDefault==ATT_FIXED + else + p = .false. + endif + end function attribute_has_default + + function get_attlist_size(elem) result(n) + type(element_t), pointer :: elem + integer :: n + + if (associated(elem)) then + n = size(elem%attlist%list) + else + n = 0 + endif + end function get_attlist_size + + function get_attdecl_by_index(elem, n) result(att) + type(element_t), pointer :: elem + integer, intent(in) :: n + type(attribute_t), pointer :: att + + att => null() + if (associated(elem)) then + if (n>0.and.n<=size(elem%attlist%list)) then + att => elem%attlist%list(n) + endif + endif + end function get_attdecl_by_index + + function get_attdecl_by_name(elem, name) result(att) + type(element_t), pointer :: elem + character(len=*), intent(in) :: name + type(attribute_t), pointer :: att + + integer :: i + att => null() + if (associated(elem)) then + do i = 1, size(elem%attlist%list) + if (str_vs(elem%attlist%list(i)%name)==name) then + att => elem%attlist%list(i) + return + endif + enddo + endif + end function get_attdecl_by_name + + pure function express_att_decl_len(a) result(n) + type(attribute_t), intent(in) :: a + integer :: n + + if (a%attType==ATT_ENUM) then + n = size(a%name) + else + n = size(a%name)+1+len_trim(ATT_TYPES(a%attType)) + endif + + if (a%attType==ATT_NOTATION & + .or.a%attType==ATT_ENUM) & + n = n + 1 + make_token_group_len(a%enumerations) + + select case(a%attDefault) + case (ATT_REQUIRED) + n = n + len(" #REQUIRED") + case (ATT_IMPLIED) + n = n + len(" #IMPLIED") + case (ATT_DEFAULT) + n = n + len(" ") + case (ATT_FIXED) + n = n + len(" #FIXED") + end select + + if (associated(a%default)) & + n = n + 3 + size(a%default) + end function express_att_decl_len + + function express_attribute_declaration(a) result(s) + type(attribute_t), intent(in) :: a + character(len=express_att_decl_len(a)) :: s + + if (a%attType==ATT_ENUM) then + s = str_vs(a%name) + else + s = str_vs(a%name)//" "//ATT_TYPES(a%attType) + endif + if (a%attType==ATT_NOTATION & + .or.a%attType==ATT_ENUM) & + s = trim(s)//" "//make_token_group(a%enumerations) + + select case(a%attDefault) + case (ATT_REQUIRED) + s = trim(s)//" #REQUIRED" + case (ATT_IMPLIED) + s = trim(s)//" #IMPLIED" + case (ATT_DEFAULT) + s = trim(s)//" " + case (ATT_FIXED) + s = trim(s)//" #FIXED" + end select + + if (associated(a%default)) & + s = trim(s)//" """//str_vs(a%default)//"""" + end function express_attribute_declaration + + function get_att_type_enum(s) result(n) + character(len=*), intent(in) :: s + integer :: n + + select case(s) + case ('CDATA') + n = ATT_CDATA + case ('ID') + n = ATT_ID + case ('IDREF') + n = ATT_IDREF + case ('IDREFS') + n = ATT_IDREFS + case ('NMTOKEN') + n = ATT_NMTOKEN + case ('NMTOKENS') + n = ATT_NMTOKENS + case ('ENTITY') + n = ATT_ENTITY + case ('ENTITIES') + n = ATT_ENTITIES + case ('NOTATION') + n = ATT_NOTATION + case ('CDANO') + n= ATT_CDANO + case ('CDAMB') + n = ATT_CDAMB + end select + end function get_att_type_enum + + pure function att_value_normalize_len(s1) result(n) + character(len=*), intent(in) :: s1 + integer :: n + + integer :: i + logical :: w + + n = 0 + w = .true. + do i = 1, len(s1) + if (w.and.(verify(s1(i:i),XML_WHITESPACE)==0)) cycle + w = .false. + n = n + 1 + if (verify(s1(i:i),XML_WHITESPACE)==0) w = .true. + enddo + if (w) n = n - 1 ! Discard final space + + end function att_value_normalize_len + + function att_value_normalize(s1) result(s2) + character(len=*), intent(in) :: s1 + character(len=att_value_normalize_len(s1)) :: s2 + + integer :: i, i2 + logical :: w + + i = 0 + i2 = 1 + w = .true. + do while (i2<=len(s2)) + i = i + 1 + if (w.and.(verify(s1(i:i),XML_WHITESPACE)==0)) cycle + w = .false. + s2(i2:i2) = s1(i:i) + i2 = i2 + 1 + if (verify(s1(i:i),XML_WHITESPACE)==0) w = .true. + enddo + + end function att_value_normalize + +#endif +end module m_common_element diff --git a/src/xml/common/m_common_elstack.F90 b/src/xml/common/m_common_elstack.F90 new file mode 100644 index 000000000..ccfca15dc --- /dev/null +++ b/src/xml/common/m_common_elstack.F90 @@ -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 diff --git a/src/xml/common/m_common_entities.F90 b/src/xml/common/m_common_entities.F90 new file mode 100644 index 000000000..071455b29 --- /dev/null +++ b/src/xml/common/m_common_entities.F90 @@ -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)') ' 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 diff --git a/src/xml/common/m_common_entity_expand.F90 b/src/xml/common/m_common_entity_expand.F90 new file mode 100644 index 000000000..565700710 --- /dev/null +++ b/src/xml/common/m_common_entity_expand.F90 @@ -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 diff --git a/src/xml/common/m_common_error.F90 b/src/xml/common/m_common_error.F90 new file mode 100644 index 000000000..0a1f1c1a8 --- /dev/null +++ b/src/xml/common/m_common_error.F90 @@ -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 diff --git a/src/xml/common/m_common_io.F90 b/src/xml/common/m_common_io.F90 new file mode 100644 index 000000000..a15a25dbc --- /dev/null +++ b/src/xml/common/m_common_io.F90 @@ -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 diff --git a/src/xml/common/m_common_namecheck.F90 b/src/xml/common/m_common_namecheck.F90 new file mode 100644 index 000000000..a796732e7 --- /dev/null +++ b/src/xml/common/m_common_namecheck.F90 @@ -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 diff --git a/src/xml/common/m_common_namespaces.F90 b/src/xml/common/m_common_namespaces.F90 new file mode 100644 index 000000000..e3bdff60c --- /dev/null +++ b/src/xml/common/m_common_namespaces.F90 @@ -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 diff --git a/src/xml/common/m_common_notations.F90 b/src/xml/common/m_common_notations.F90 new file mode 100644 index 000000000..ee404da35 --- /dev/null +++ b/src/xml/common/m_common_notations.F90 @@ -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 diff --git a/src/xml/common/m_common_struct.F90 b/src/xml/common/m_common_struct.F90 new file mode 100644 index 000000000..ec92b5291 --- /dev/null +++ b/src/xml/common/m_common_struct.F90 @@ -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 diff --git a/src/xml/dom/FoX_dom.F90 b/src/xml/dom/FoX_dom.F90 new file mode 100644 index 000000000..6e1ac36a7 --- /dev/null +++ b/src/xml/dom/FoX_dom.F90 @@ -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 diff --git a/src/xml/dom/Makefile b/src/xml/dom/Makefile new file mode 100644 index 000000000..1f597ddbc --- /dev/null +++ b/src/xml/dom/Makefile @@ -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 diff --git a/src/xml/dom/m_dom_dom.F90 b/src/xml/dom/m_dom_dom.F90 new file mode 100644 index 000000000..01f6265b0 --- /dev/null +++ b/src/xml/dom/m_dom_dom.F90 @@ -0,0 +1,12323 @@ +! ATTENTION +! THIS FILE IS AUTOGENERATED +! DO NOT EDIT DIRECTLY +! EDIT FILES dom/m_dom_***.m4 +! +module m_dom_dom + + use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc + use fox_m_fsys_format, only: operator(//) + use fox_m_fsys_string, only: toLower + use fox_m_utils_uri, only: URI, parseURI, destroyURI, isAbsoluteURI, & + rebaseURI, expressURI + use m_common_charset, only: checkChars, XML1_0, XML1_1 + use m_common_element, only: element_t, get_element, attribute_t, & + attribute_has_default, get_attribute_declaration, get_attlist_size + use m_common_namecheck, only: checkQName, prefixOfQName, localPartOfQName, & + checkName, checkPublicId, checkNCName + use m_common_struct, only: xml_doc_state, init_xml_doc_state, destroy_xml_doc_state + + use m_dom_error, only: DOMException, throw_exception, inException, getExceptionCode, & + NO_MODIFICATION_ALLOWED_ERR, NOT_FOUND_ERR, HIERARCHY_REQUEST_ERR, & + WRONG_DOCUMENT_ERR, FoX_INTERNAL_ERROR, FoX_NODE_IS_NULL, FoX_LIST_IS_NULL, & + INUSE_ATTRIBUTE_ERR, FoX_MAP_IS_NULL, INVALID_CHARACTER_ERR, NAMESPACE_ERR, & + FoX_INVALID_PUBLIC_ID, FoX_INVALID_SYSTEM_ID, FoX_IMPL_IS_NULL, FoX_INVALID_NODE, & + FoX_INVALID_CHARACTER, FoX_INVALID_COMMENT, FoX_INVALID_CDATA_SECTION, & + FoX_INVALID_PI_DATA, NOT_SUPPORTED_ERR, FoX_INVALID_ENTITY, & + INDEX_SIZE_ERR, FoX_NO_SUCH_ENTITY, FoX_HIERARCHY_REQUEST_ERR, & + FoX_INVALID_URI + + implicit none + private + + + integer, parameter :: configParamLen = 42 + + character(len=configParamLen), parameter :: configParams(24) = (/ & + ! DOM 3 Core: + "canonical-form ", & + "cdata-sections ", & + "check-character-normalization ", & + "comments ", & + "datatype-normalization ", & + "element-content-whitespace ", & + "entities ", & + "error-handler ", & +! "infoset ", & is not a real config option + "namespaces ", & + "namespace-declarations ", & + "normalize-characters ", & +! "schema-location ", & we dont implement +! "schema-type ", & we dont implement + "split-cdata-sections ", & + "validate ", & + "validate-if-schema ", & + "well-formed ", & + ! DOM 3 LS (Parser): + "charset-overrides-xml-encoding ", & + "disallow-doctype ", & + "ignore-unknown-character-denormalizations", & + "resource-resolver ", & + "supported-media-types-only ", & + ! DOM 3 LS (Serializer) + "discard-default-content ", & + "format-pretty-print ", & + "xml-declaration ", & + ! Extra (FoX) configuration options + "invalid-pretty-print " /) + + integer, parameter :: paramSettable = 27293398 + integer, parameter :: paramDefaults = 10786516 + + type DOMConfiguration + private + integer :: parameters = paramDefaults + ! FIXME make sure this is 32 bit at least. + end type DOMConfiguration + + interface canSetParameter + module procedure canSetParameter_log + module procedure canSetParameter_ch + end interface canSetParameter + + public :: setParameter + public :: getParameter + public :: canSetParameter + public :: getParameterNames + + public :: newDOMConfig + public :: copyDOMConfig + + + integer, parameter :: ELEMENT_NODE = 1 + integer, parameter :: ATTRIBUTE_NODE = 2 + integer, parameter :: TEXT_NODE = 3 + integer, parameter :: CDATA_SECTION_NODE = 4 + integer, parameter :: ENTITY_REFERENCE_NODE = 5 + integer, parameter :: ENTITY_NODE = 6 + integer, parameter :: PROCESSING_INSTRUCTION_NODE = 7 + integer, parameter :: COMMENT_NODE = 8 + integer, parameter :: DOCUMENT_NODE = 9 + integer, parameter :: DOCUMENT_TYPE_NODE = 10 + integer, parameter :: DOCUMENT_FRAGMENT_NODE = 11 + integer, parameter :: NOTATION_NODE = 12 + integer, parameter :: XPATH_NAMESPACE_NODE = 13 + + type DOMImplementation + private + character(len=7) :: id = "FoX_DOM" + logical :: FoX_checks = .true. ! Do extra checks not mandated by DOM + end type DOMImplementation + + type ListNode + private + type(Node), pointer :: this => null() + end type ListNode + + type NodeList + private + character, pointer :: nodeName(:) => null() ! What was getByTagName run on? + character, pointer :: localName(:) => null() ! What was getByTagNameNS run on? + character, pointer :: namespaceURI(:) => null() ! What was getByTagNameNS run on? + type(Node), pointer :: element => null() ! which element or document was the getByTagName run from? + type(ListNode), pointer :: nodes(:) => null() + integer :: length = 0 + end type NodeList + + type NodeListptr + private + type(NodeList), pointer :: this + end type NodeListptr + + type NamedNodeMap + private + logical :: readonly = .false. + type(Node), pointer :: ownerElement => null() + type(ListNode), pointer :: nodes(:) => null() + integer :: length = 0 + end type NamedNodeMap + + type documentExtras + type(DOMImplementation), pointer :: implementation => null() ! only for doctype + type(Node), pointer :: docType => null() + type(Node), pointer :: documentElement => null() + character, pointer :: inputEncoding(:) => null() + character, pointer :: xmlEncoding(:) => null() + type(NodeListPtr), pointer :: nodelists(:) => null() ! document + ! In order to keep track of all nodes not connected to the document + logical :: liveNodeLists ! For the document, are nodelists live? + type(NodeList) :: hangingNodes ! For the document, list of nodes not associated with doc + type(xml_doc_state), pointer :: xds => null() + logical :: strictErrorChecking = .true. + logical :: brokenNS = .false. ! FIXME consolidate these logical variables into bitmask + type(DOMConfiguration), pointer :: domConfig => null() + end type documentExtras + + type elementOrAttributeExtras + ! Needed for all: + character, pointer, dimension(:) :: namespaceURI => null() + character, pointer, dimension(:) :: prefix => null() + character, pointer, dimension(:) :: localName => null() + ! Needed for elements: + type(NamedNodeMap) :: attributes + type(NodeList) :: namespaceNodes + ! Needed for attributes: + type(Node), pointer :: ownerElement => null() + logical :: specified = .true. + logical :: isId = .false. + logical :: dom1 = .false. + end type elementOrAttributeExtras + + type docTypeExtras + character, pointer :: publicId(:) => null() ! doctype, entity, notation + character, pointer :: systemId(:) => null() ! doctype, entity, notation + character, pointer :: notationName(:) => null() ! entity + logical :: illFormed = .false. ! entity + type(namedNodeMap) :: entities ! doctype + type(namedNodeMap) :: notations ! doctype + end type docTypeExtras + + type Node + private + logical :: readonly = .false. + character, pointer, dimension(:) :: nodeName => null() + character, pointer, dimension(:) :: nodeValue => null() + integer :: nodeType = 0 + type(Node), pointer :: parentNode => null() + type(Node), pointer :: firstChild => null() + type(Node), pointer :: lastChild => null() + type(Node), pointer :: previousSibling => null() + type(Node), pointer :: nextSibling => null() + type(Node), pointer :: ownerDocument => null() + type(NodeList) :: childNodes ! not for text, cdata, PI, comment, notation, docType, XPath + logical :: inDocument = .false.! For a node, is this node associated to the doc? + logical :: ignorableWhitespace = .false. ! Text nodes only + type(documentExtras), pointer :: docExtras => null() + type(elementOrAttributeExtras), pointer :: elExtras => null() + type(docTypeExtras), pointer :: dtdExtras => null() + integer :: textContentLength = 0 + end type Node + + type(DOMImplementation), save, target :: FoX_DOM + + interface destroy + module procedure destroyNode + module procedure destroyNodeList + module procedure destroyNamedNodeMap + module procedure destroyDOMConfig + end interface destroy + + 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 :: DOMImplementation + public :: DOMConfiguration + public :: Node + + public :: ListNode + public :: NodeList + public :: NamedNodeMap + + public :: destroy + public :: destroyAllNodesRecursively + + + + public :: getNodeName + public :: getNodeValue + public :: setNodeValue + public :: getNodeType + public :: getParentNode + public :: getChildNodes + public :: getFirstChild + public :: getLastChild + public :: getNextSibling + public :: getPreviousSibling + public :: getAttributes + 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 :: isEqualNode + public :: isSameNode + public :: isDefaultNamespace + public :: lookupNamespaceURI + public :: lookupPrefix + public :: getTextContent + public :: setTextContent + + public :: getNodePath + + public :: setStringValue + public :: getStringValue + public :: setReadonlyNode + public :: getReadOnly + + public :: getBaseURI + + + + public :: item + public :: append + public :: pop_nl + public :: remove_nl + public :: destroyNodeList + + interface append + module procedure append_nl + end interface + + interface item + module procedure item_nl + end interface + + interface getLength + module procedure getLength_nl + end interface getLength + + + public :: getNamedItem + public :: setNamedItem + public :: removeNamedItem +! public :: item +! public :: getLength + public :: getNamedItemNS + public :: setNamedItemNS + public :: removeNamedItemNS + +! public :: append + public :: setReadOnlyMap + public :: destroyNamedNodeMap + + + interface item + module procedure item_nnm + end interface + + interface getLength + module procedure getLength_nnm + end interface + + + + public :: hasFeature + public :: createDocument + public :: createDocumentType + + public :: destroyDocument + public :: createEmptyDocument + + public :: getFoX_checks + public :: setFoX_checks + + + +!FIXME lots of these should have a check if(namespaces) checkNCName + + public :: getDocType + public :: getImplementation + public :: getDocumentElement + public :: setDocumentElement + + public :: createElement + public :: createDocumentFragment + public :: createTextNode + public :: createComment + public :: createCdataSection + public :: createProcessingInstruction + public :: createAttribute + public :: createEntityReference + public :: createEmptyEntityReference + public :: getElementsByTagName + public :: importNode + public :: createElementNS + public :: createAttributeNS + public :: getElementsByTagNameNS + public :: getElementById + public :: getXmlStandalone + public :: setXmlStandalone + public :: getXmlVersion + public :: setXmlVersion + public :: getXmlEncoding + public :: getInputEncoding + public :: getDocumentURI + public :: setDocumentURI + public :: getStrictErrorChecking + public :: setStrictErrorChecking + public :: getDomConfig + public :: renameNode + public :: adoptNode + + public :: setDocType + public :: setDomConfig + public :: setXds + public :: createNamespaceNode + public :: createEntity + public :: createNotation + public :: setGCstate + public :: getXds + public :: getLiveNodeLists + public :: setLiveNodeLists + + + !public :: getName + public :: getEntities + public :: getNotations +! public :: getPublicId +! public :: getSystemId + public :: getInternalSubset + + + + public :: getTagName + public :: getAttribute + public :: setAttribute + public :: removeAttribute + public :: getAttributeNode + public :: setAttributeNode + public :: removeAttributeNode + public :: getAttributeNS + public :: setAttributeNS + public :: removeAttributeNS + public :: getAttributeNodeNS + public :: setAttributeNodeNS + public :: removeAttributeNodeNS + public :: hasAttribute + public :: hasAttributeNS + public :: setIdAttribute + public :: setIdAttributeNS + public :: setIdAttributeNode + + + + !public :: getName + public :: getSpecified + public :: setSpecified + interface getValue + module procedure getValue_DOM + end interface + public :: getValue + public :: setValue + public :: getOwnerElement + + public :: getIsId + public :: setIsId + interface getIsId + module procedure getIsId_DOM + end interface + interface setIsId + module procedure setIsId_DOM + end interface + + + + public :: getLength +! public :: getData +! public :: setData + public :: substringData + public :: appendData + public :: insertData + public :: deleteData + public :: replaceData + + interface getLength + module procedure getLength_characterdata + end interface + + + + public :: getNotationName + + public :: getIllFormed + public :: setIllFormed + + + + public :: getTarget + + + public :: splitText + public :: getIsElementContentWhitespace + public :: setIsElementContentWhitespace + + +! Assorted functions with identical signatures despite belonging to different types. + + public :: getData + public :: setData + public :: getName + public :: getPublicId + public :: getSystemId + + + + public :: normalizeDocument + + public :: getNamespaceNodes + public :: namespaceFixup + + +contains + + + subroutine resetParameter(domConfig, name) + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + + integer :: i, n + do i = 1, size(configParams) + if (toLower(name)==trim(configParams(i))) then + n = i + exit + endif + enddo + if (i>size(configParams)) return + if (.not.btest(paramSettable, n)) return + if (btest(paramDefaults, n)) then + domConfig%parameters = ibset(domConfig%parameters, n) + else + domConfig%parameters = ibclr(domConfig%parameters, n) + endif + end subroutine resetParameter + + recursive subroutine setParameter(domConfig, name, value, ex) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + logical, intent(in) :: value + integer :: i, n + + if (toLower(name)=="infoset") then + if (value) then + call setParameter(domConfig, "validate-if-schema", .false.) + call setParameter(domConfig, "entities", .false.) + ! cant do datatype-normalization + call setParameter(domConfig, "cdata-sections", .false.) + call setParameter(domConfig, "namespace-declarations", .true.) + ! well-formed cannot be changed + call setParameter(domConfig, "element-content-whitespace", .true.) + call setParameter(domConfig, "comments", .true.) + call setParameter(domConfig, "namespaces", .true.) + endif + return + endif + + do i = 1, size(configParams) + if (toLower(name)==trim(configParams(i))) then + n = i + exit + endif + enddo + if (i > size(configParams)) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "setParameter", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (.not.canSetParameter(domConfig, name, value)) then + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "setParameter", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (value) then + domConfig%parameters = ibset(domConfig%parameters, n) + else + domConfig%parameters = ibclr(domConfig%parameters, n) + endif + + select case (toLower(name)) + case ("canonical-form") + if (value) then + domConfig%parameters = ibclr(domConfig%parameters, 7) + ! cant do normalize-characters + domConfig%parameters = ibclr(domConfig%parameters, 2) + domConfig%parameters = ibset(domConfig%parameters, 9) + domConfig%parameters = ibset(domConfig%parameters, 10) + ! well-formed cannot be changed + domConfig%parameters = ibset(domConfig%parameters, 6) + ! FIXME when we work out pretty-print/preserve-whitespace semantics + ! call setParameter(domConfig, "format-pretty-print", .false.) + domConfig%parameters = ibclr(domConfig%parameters, 21) + domConfig%parameters = ibclr(domConfig%parameters, 23) + domConfig%parameters = ibclr(domConfig%parameters, 24) + else + call resetParameter(domConfig, "entities") + ! cant do normalize-characters + call resetParameter(domConfig, "cdata-sections") + call resetParameter(domConfig, "namespaces") + call resetParameter(domConfig, "namespace-declarations") + ! well-formed cannot be changed + call resetParameter(domConfig, "element-content-whitespace") + call resetParameter(domConfig, "format-pretty-print") + call resetParameter(domConfig, "discard-default-content") + call resetParameter(domConfig, "xml-declaration") + call resetParameter(domConfig, "invalid-pretty-print") + endif + case ("cdata-sections") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("element-content-whitespace") + if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("entities") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("namespaces") + if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("namespaces-declarations") + if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case("validate") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 14) + case ("validate-if-schema") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 13) + case ("format-pretty-print") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("discard-default-content") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("xml-declaration") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("invalid-pretty-print") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + end select + + end subroutine setParameter + + recursive function getParameter(domConfig, name, ex)result(value) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + logical :: value + + integer :: i, n + + if (toLower(name)=="infoset") then + value = & + .not.getParameter(domConfig, "validate-if-schema") & + .and..not.getParameter(domConfig, "entities") & + .and..not.getParameter(domConfig, "datatype-normalization") & + .and..not.getParameter(domConfig, "cdata-sections") & + .and.getParameter(domConfig, "namespace-declarations") & + .and.getParameter(domConfig, "well-formed") & + .and.getParameter(domConfig, "element-content-whitespace") & + .and.getParameter(domConfig, "comments") & + .and.getParameter(domConfig, "namespaces") + return + endif + + do i = 1, size(configParams) + if (toLower(name)==trim(configParams(i))) then + n = i + exit + endif + enddo + if (i > size(configParams)) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "getParameter", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + value = btest(domConfig%parameters, n) + + end function getParameter + + function canSetParameter_log(domConfig, name, value, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + logical, intent(in) :: value + logical :: p + + integer :: i, n + + if (toLower(name)=="infoset") then + p = .true. + return + endif + do i = 1, size(configParams) + if (toLower(name)==trim(configParams(i))) then + n = i + exit + endif + enddo + if (i > size(configParams)) then + p = .false. + return + endif + + p = btest(paramSettable, n) + + end function canSetParameter_log + + function canSetParameter_ch(domConfig, name, value, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + logical :: p + + ! DOM 3 allows some config options to be set to strings + ! (eg schemaLocation) but we dont support any of these, + ! so no parameter can be set to a string. + p = .false. + + end function canSetParameter_ch + + function getParameterNames(domConfig, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=configParamLen) :: s(size(configParams)) + + s = configParams + end function getParameterNames + + function newDOMConfig() result(dc) + type(DOMConfiguration), pointer :: dc + allocate(dc) + end function newDOMConfig + + subroutine copyDOMConfig(dc1, dc2) + type(DOMConfiguration), pointer :: dc1, dc2 + + dc1%parameters = dc2%parameters + end subroutine copyDOMConfig + + subroutine destroyDOMConfig(dc) + type(DOMConfiguration), pointer :: dc + + deallocate(dc) + end subroutine destroyDOMConfig + + + + function createNode(arg, nodeType, nodeName, nodeValue, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: nodeType + character(len=*), intent(in) :: nodeName + character(len=*), intent(in) :: nodeValue + type(Node), pointer :: np + + allocate(np) + np%ownerDocument => arg + np%nodeType = nodeType + np%nodeName => vs_str_alloc(nodeName) + np%nodeValue => vs_str_alloc(nodeValue) + + allocate(np%childNodes%nodes(0)) + + end function createNode + + recursive subroutine destroyNode(np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + + if (.not.associated(np)) return + + select case(np%nodeType) + case (ELEMENT_NODE, ATTRIBUTE_NODE, XPATH_NAMESPACE_NODE) + call destroyElementOrAttribute(np, ex) + case (DOCUMENT_TYPE_NODE) + call destroyDocumentType(np, ex) + case (ENTITY_NODE, NOTATION_NODE) + call destroyEntityOrNotation(np, ex) + case (DOCUMENT_NODE) + call destroyDocument(np,ex) + end select + call destroyNodeContents(np) + deallocate(np) + + end subroutine destroyNode + + recursive subroutine destroyElementOrAttribute(np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + + integer :: i + + if (np%nodeType /= ELEMENT_NODE & + .and. np%nodeType /= ATTRIBUTE_NODE & + .and. np%nodeType /= XPATH_NAMESPACE_NODE) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "destroyElementOrAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%elExtras%attributes%nodes)) deallocate(np%elExtras%attributes%nodes) + do i = 1, np%elExtras%namespaceNodes%length + call destroyNode(np%elExtras%namespaceNodes%nodes(i)%this) + enddo + if (associated(np%elExtras%namespaceNodes%nodes)) deallocate(np%elExtras%namespaceNodes%nodes) + if (associated(np%elExtras%namespaceURI)) deallocate(np%elExtras%namespaceURI) + if (associated(np%elExtras%prefix)) deallocate(np%elExtras%prefix) + if (associated(np%elExtras%localName)) deallocate(np%elExtras%localName) + deallocate(np%elExtras) + + end subroutine destroyElementOrAttribute + + subroutine destroyEntityOrNotation(np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + + if (np%nodeType /= ENTITY_NODE & + .and. np%nodeType /= NOTATION_NODE) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "destroyEntityOrNotation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%dtdExtras%publicId)) deallocate(np%dtdExtras%publicId) + if (associated(np%dtdExtras%systemId)) deallocate(np%dtdExtras%systemId) + if (associated(np%dtdExtras%notationName)) deallocate(np%dtdExtras%notationName) + + deallocate(np%dtdExtras) + + end subroutine destroyEntityOrNotation + + subroutine destroyDocumentType(np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + + integer :: i + + if (np%nodeType /= DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "destroyDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%dtdExtras%publicId)) deallocate(np%dtdExtras%publicId) + if (associated(np%dtdExtras%systemId)) deallocate(np%dtdExtras%systemId) + + ! Destroy all entities & notations (docType only) + if (associated(np%dtdExtras%entities%nodes)) then + do i = 1, size(np%dtdExtras%entities%nodes) + call destroyAllNodesRecursively(np%dtdExtras%entities%nodes(i)%this) + enddo + deallocate(np%dtdExtras%entities%nodes) + endif + if (associated(np%dtdExtras%notations%nodes)) then + do i = 1, size(np%dtdExtras%notations%nodes) + call destroy(np%dtdExtras%notations%nodes(i)%this) + enddo + deallocate(np%dtdExtras%notations%nodes) + endif + + deallocate(np%dtdExtras) + + end subroutine destroyDocumentType + + recursive subroutine destroyAllNodesRecursively(arg, except) + ! Only recurses once into destroyDocumentType + type(Node), pointer :: arg + logical, intent(in), optional :: except + + type(Node), pointer :: this, deadNode, treeroot + logical :: doneChildren, doneAttributes + integer :: i_tree + + if (.not.associated(arg)) return + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + deadNode => null() + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + deadNode => null() + + 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 + + deadNode => this + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree 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 + call destroy(deadNode) + endif + + enddo + + + + deallocate(arg%childNodes%nodes) + allocate(arg%childNodes%nodes(0)) + arg%firstChild => null() + arg%lastChild => null() + + if (.not.present(except)) call destroyNode(arg) + + end subroutine destroyAllNodesRecursively + + subroutine destroyNodeContents(np) + type(Node), intent(inout) :: np + + if (associated(np%nodeName)) deallocate(np%nodeName) + if (associated(np%nodeValue)) deallocate(np%nodeValue) + + deallocate(np%childNodes%nodes) + + end subroutine destroyNodeContents + + + + + pure function getnodeName_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p) then + n = size(np%nodeName) + else + n = 0 + endif + end function getnodeName_len +function getnodeName(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getnodeName_len(np, .true.)) :: c +#else + character(len=getnodeName_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnodeName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c = str_vs(np%nodeName) + + end function getnodeName + + + pure function getNodeValue_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + n = 0 + if (.not.p) return + + select case(np%nodeType) + case (ATTRIBUTE_NODE) + n = getTextContent_len(np, .true.) + case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) + n = size(np%nodeValue) + end select + + end function getNodeValue_len + + function getNodeValue(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getNodeValue_len(np, .true.)) :: c +#else + character(len=getNodeValue_len(np, associated(np))) :: c +#endif + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getNodeValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + select case(np%nodeType) + case (ATTRIBUTE_NODE) + c = getTextContent(np) + case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) + c = str_vs(np%nodeValue) + case default + c = "" + end select + + end function getNodeValue + + subroutine setNodeValue(arg, nodeValue, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*) :: nodeValue + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setNodeValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(getOwnerDocument(arg))) then + if (.not.checkChars(nodeValue, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "setNodeValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif ! Otherwise its a document node, and nothing will happen anyway + + select case(arg%nodeType) + case (ATTRIBUTE_NODE) + call setValue(arg, nodeValue, ex) + case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) + call setData(arg, nodeValue, ex) + end select + + end subroutine setNodeValue + +function getnodeType(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + integer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnodeType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c = np%nodeType + + end function getnodeType + + +function getparentNode(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getparentNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%parentNode + + end function getparentNode + + +function getchildNodes(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(NodeList), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getchildNodes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%childNodes + + end function getchildNodes + + +function getfirstChild(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getfirstChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%firstChild + + end function getfirstChild + + +function getlastChild(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getlastChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%lastChild + + end function getlastChild + + +function getpreviousSibling(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getpreviousSibling", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%previousSibling + + end function getpreviousSibling + + +function getnextSibling(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnextSibling", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%nextSibling + + end function getnextSibling + + + function getAttributes(arg, ex)result(nnm) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(NamedNodeMap), pointer :: nnm + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttributes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg)==ELEMENT_NODE) then + nnm => arg%elExtras%attributes + else + nnm => null() + endif + end function getAttributes + + function getOwnerDocument(arg, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getOwnerDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType==DOCUMENT_NODE) then + np => null() + else + np => arg%ownerDocument + endif + end function getOwnerDocument + +subroutine setownerDocument(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setownerDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setownerDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%ownerDocument => c + + end subroutine setownerDocument + + + function insertBefore(arg, newChild, refChild, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newChild + type(Node), pointer :: refChild + type(Node), pointer :: np + + type(Node), pointer :: testChild, testParent, treeroot, this + type(ListNode), pointer :: temp_nl(:) + integer :: i, i2, i_t, i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg).or..not.associated(newChild)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(refChild)) then + np => appendChild(arg, newChild, ex) + return + endif + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + testParent => arg + ! Check if you are allowed to put a newChild nodetype under a arg nodetype + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + testChild => newChild%childNodes%nodes(i)%this + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement))) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType)))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + enddo + else + testChild => newChild + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement))) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType)))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + ! And then check that newChild is not arg or one of args ancestors + ! (this would never be true if newChild is a documentFragment) + testParent => arg + do while (associated(testParent)) + if (associated(testParent, newChild)) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + testParent => testParent%parentNode + enddo + endif + + if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & + .not.(associated(arg%ownerDocument, newChild%ownerDocument) & + .or.associated(arg, newChild%ownerDocument))) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE & + .and. newChild%childNodes%length==0) then + np => newChild + return + ! Nothing to do + endif + if (associated(getParentNode(newChild))) then + np => removeChild(getParentNode(newChild), newChild, ex) + newChild => np + endif + + if (arg%childNodes%length==0) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length)) + else + allocate(temp_nl(arg%childNodes%length+1)) + endif + + i_t = 0 + np => null() + do i = 1, arg%childNodes%length + if (associated(arg%childNodes%nodes(i)%this, refChild)) then + np => refChild + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i2 = 1, newChild%childNodes%length + i_t = i_t + 1 + temp_nl(i_t)%this => newChild%childNodes%nodes(i2)%this + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + enddo + else + i_t = i_t + 1 + temp_nl(i_t)%this => newChild + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + endif + if (i==1) then + arg%firstChild => temp_nl(1)%this + !temp_nl(1)%this%previousSibling => null() ! This is a no-op + else + temp_nl(i-1)%this%nextSibling => temp_nl(i)%this + temp_nl(i)%this%previousSibling => temp_nl(i-1)%this + endif + arg%childNodes%nodes(i)%this%previousSibling => temp_nl(i_t)%this + temp_nl(i_t)%this%nextSibling => arg%childNodes%nodes(i)%this + endif + i_t = i_t + 1 + temp_nl(i_t)%this => arg%childNodes%nodes(i)%this + enddo + + if (.not.associated(np)) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + + if (associated(temp_nl)) deallocate(temp_nl) + return + endif + endif +endif + + endif + + np => newChild + if (getGCstate(arg%ownerDocument)) then + if (arg%inDocument) then + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + call putNodesInDocument(arg%ownerDocument, newChild%childNodes%nodes(i)%this) + enddo + else + call putNodesInDocument(arg%ownerDocument, newChild) + endif + ! If newChild was originally in document, it was removed above so must be re-added + ! Ideally we would avoid the cost of removal & readding to hanging nodelist + endif + ! If arg was not in the document, then newChildren were either + ! a) removed above in call to removeChild or + ! b) in a document fragment and therefore not part of doc either + endif + + + if (getNodeType(newChild)==DOCUMENT_FRAGMENT_NODE) then + deallocate(newChild%childNodes%nodes) + allocate(newChild%childNodes%nodes(0)) + newChild%childNodes%length = 0 + endif + deallocate(arg%childNodes%nodes) + arg%childNodes%nodes => temp_nl + arg%childNodes%length = size(arg%childNodes%nodes) + + call updateNodeLists(arg%ownerDocument) + + call updateTextContentLength(arg, newChild%textContentLength) + + end function insertBefore + + + function replaceChild(arg, newChild, oldChild, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newChild + type(Node), pointer :: oldChild + type(Node), pointer :: np + + type(Node), pointer :: testChild, testParent, treeroot, this + type(ListNode), pointer :: temp_nl(:) + integer :: i, i2, i_t, i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg).or..not.associated(newChild).or..not.associated(oldChild)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + testParent => arg + ! Check if you are allowed to put a newChild nodetype under a arg nodetype + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + testChild => newChild%childNodes%nodes(i)%this + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement) & + .and.oldChild%nodeType/=ELEMENT_NODE)) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType) & + .and.oldChild%nodeType/=DOCUMENT_TYPE_NODE))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + enddo + else + testChild => newChild + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement) & + .and.oldChild%nodeType/=ELEMENT_NODE)) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType) & + .and.oldChild%nodeType/=DOCUMENT_TYPE_NODE))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + ! And then check that newChild is not arg or one of args ancestors + ! (this would never be true if newChild is a documentFragment) + testParent => arg + do while (associated(testParent)) + if (associated(testParent, newChild)) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + testParent => testParent%parentNode + enddo + endif + + if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & + .not.(associated(arg%ownerDocument, newChild%ownerDocument) & + .or.associated(arg, newChild%ownerDocument))) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(getParentNode(newChild))) & + newChild => removeChild(getParentNode(newChild), newChild, ex) + + if (arg%childNodes%length==0) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length-1)) + else + temp_nl => arg%childNodes%nodes + endif + + i_t = 0 + np => null() + do i = 1, arg%childNodes%length + if (associated(arg%childNodes%nodes(i)%this, oldChild)) then + np => oldChild + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i2 = 1, newChild%childNodes%length + i_t = i_t + 1 + temp_nl(i_t)%this => newChild%childNodes%nodes(i2)%this + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + enddo + else + i_t = i_t + 1 + temp_nl(i_t)%this => newChild + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + endif + if (i==1) then + arg%firstChild => temp_nl(1)%this + !temp_nl(1)%this%previousSibling => null() ! This is a no-op + else + temp_nl(i-1)%this%nextSibling => temp_nl(i)%this + temp_nl(i)%this%previousSibling => temp_nl(i-1)%this + endif + if (i==arg%childNodes%length) then + arg%lastChild => temp_nl(i_t)%this + !temp_nl(i_t)%this%nextSibling => null() ! This is a no-op + else + arg%childNodes%nodes(i+1)%this%previousSibling => temp_nl(i_t)%this + temp_nl(i_t)%this%nextSibling => arg%childNodes%nodes(i+1)%this + endif + else + i_t = i_t + 1 + temp_nl(i_t)%this => arg%childNodes%nodes(i)%this + endif + enddo + + if (.not.associated(np)) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + np%parentNode => null() + np%previousSibling => null() + np%nextSibling => null() + +! call namespaceFixup(np) + + if (getGCstate(arg%ownerDocument)) then + if (arg%inDocument) then + call removeNodesFromDocument(arg%ownerDocument, oldChild) + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + call putNodesInDocument(arg%ownerDocument, newChild%childNodes%nodes(i)%this) + enddo + else + call putNodesInDocument(arg%ownerDocument, newChild) + endif + ! If newChild was originally in document, it was removed above so must be re-added + ! Ideally we would avoid the cost of removing & re-adding to hangingnodelist + endif + ! If arg was not in the document, then newChildren were either + ! a) removed above in call to removeChild or + ! b) in a document fragment and therefore not part of doc either + endif + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + deallocate(newChild%childNodes%nodes) + allocate(newChild%childNodes%nodes(0)) + newChild%childNodes%length = 0 + deallocate(arg%childNodes%nodes) + arg%childNodes%nodes => temp_nl + arg%childNodes%length = size(arg%childNodes%nodes) + endif + + call updateNodeLists(arg%ownerDocument) + + call updateTextContentLength(arg, newChild%textContentLength-oldChild%textContentLength) + + end function replaceChild + + + function removeChild(arg, oldChild, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: oldChild + type(Node), pointer :: np + + type(ListNode), pointer :: temp_nl(:) + integer :: i, i_t + + if (.not.associated(arg).or..not.associated(oldChild)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + allocate(temp_nl(size(arg%childNodes%nodes)-1)) + i_t = 1 + do i = 1, size(arg%childNodes%nodes) + if (associated(arg%childNodes%nodes(i)%this, oldChild)) then + if (associated(arg%firstChild, arg%lastChild)) then + ! There is only one child, we are removing it. + arg%firstChild => null() + arg%lastChild => null() + elseif (i==1) then + ! We are removing the first child, but there is a second + arg%firstChild => arg%childNodes%nodes(2)%this + arg%childNodes%nodes(2)%this%previousSibling => null() + elseif (i==size(arg%childNodes%nodes)) then + ! We are removing the last child, but there is a second-to-last + arg%lastChild => arg%childNodes%nodes(i-1)%this + arg%childNodes%nodes(i-1)%this%nextSibling => null() + else + ! We are removing a child in the middle + arg%childNodes%nodes(i-1)%this%nextSibling => arg%childNodes%nodes(i+1)%this + arg%childNodes%nodes(i+1)%this%previousSibling => arg%childNodes%nodes(i-1)%this + endif + else + if (i_t==size(arg%childNodes%nodes)) exit ! We have failed to find the child + temp_nl(i_t)%this => arg%childNodes%nodes(i)%this + i_t = i_t + 1 + endif + enddo + + deallocate(arg%childNodes%nodes) + arg%childNodes%nodes => temp_nl + arg%childNodes%length = size(temp_nl) + if (i==i_t) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + oldChild%parentNode => null() + oldChild%previousSibling => null() + oldChild%nextSibling => null() + +! call namespaceFixup(oldChild) + + if (getGCstate(arg%ownerDocument)) then + if (arg%inDocument) then + call removeNodesFromDocument(arg%ownerDocument, oldChild) + endif + endif + + np => oldChild + + call updateNodeLists(arg%ownerDocument) + + call updateTextContentLength(arg, -oldChild%textContentLength) + + end function removeChild + + + function appendChild(arg, newChild, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newChild + type(Node), pointer :: np + + type(Node), pointer :: testChild, testParent, treeroot, this + type(ListNode), pointer :: temp_nl(:) + integer :: i, i_t, i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg).or..not.associated(newChild)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + testParent => arg + ! Check if you are allowed to put a newChild nodetype under a arg nodetype + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + testChild => newChild%childNodes%nodes(i)%this + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement))) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType)))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + enddo + else + testChild => newChild + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement))) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType)))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + ! And then check that newChild is not arg or one of args ancestors + ! (this would never be true if newChild is a documentFragment) + testParent => arg + do while (associated(testParent)) + if (associated(testParent, newChild)) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + testParent => testParent%parentNode + enddo + endif + + if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & + .not.(associated(arg%ownerDocument, newChild%ownerDocument) & + .or.associated(arg, newChild%ownerDocument))) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE & + .and. newChild%childNodes%length==0) then + np => newChild + return + ! Nothing to do + endif + + if (associated(getParentNode(newChild))) & + newChild => removeChild(getParentNode(newChild), newChild, ex) + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length)) + else + allocate(temp_nl(arg%childNodes%length+1)) + endif + + do i = 1, arg%childNodes%length + temp_nl(i)%this => arg%childNodes%nodes(i)%this + enddo + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + i_t = arg%childNodes%length + do i = 1, newChild%childNodes%length + i_t = i_t + 1 + temp_nl(i_t)%this => newChild%childNodes%nodes(i)%this + if (arg%inDocument) & + call putNodesInDocument(arg%ownerDocument, temp_nl(i_t)%this) + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + enddo + if (arg%childNodes%length==0) then + arg%firstChild => newChild%firstChild + else + newChild%firstChild%previousSibling => arg%lastChild + arg%lastChild%nextSibling => newChild%firstChild + endif + arg%lastChild => newChild%lastChild + newChild%firstChild => null() + newChild%lastChild => null() + deallocate(newChild%childNodes%nodes) + allocate(newChild%childNodes%nodes(0)) + newChild%childNodes%length = 0 + else + temp_nl(i)%this => newChild + if (i==1) then + arg%firstChild => newChild + newChild%previousSibling => null() + else + temp_nl(i-1)%this%nextSibling => newChild + newChild%previousSibling => temp_nl(i-1)%this + endif + if (getGCstate(arg%ownerDocument)) then + if (arg%inDocument.and..not.newChild%inDocument) then + call putNodesInDocument(arg%ownerDocument, newChild) + endif + endif + newChild%nextSibling => null() + arg%lastChild => newChild + newChild%parentNode => arg +! call namespaceFixup(newChild) + endif + + deallocate(arg%childNodes%nodes) + arg%childNodes%nodes => temp_nl + arg%childNodes%length = size(temp_nl) + + np => newChild + + call updateNodeLists(arg%ownerDocument) + + call updateTextContentLength(arg, newChild%textContentLength) + + end function appendChild + + + function hasChildNodes(arg, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical :: hasChildNodes + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "hasChildNodes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + hasChildNodes = associated(arg%firstChild) + + end function hasChildNodes + + recursive function cloneNode(arg, deep, ex)result(np) + type(DOMException), intent(out), optional :: ex + ! Needs to be recursive in case of entity-references within each other. + type(Node), pointer :: arg + logical, intent(in) :: deep + type(Node), pointer :: np + + type(Node), pointer :: doc, treeroot, thatParent, this, new, ERchild + + logical :: doneAttributes, doneChildren, readonly, brokenNS + integer :: i_tree + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "cloneNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + thatParent => null() + ERchild => null() + doc => getOwnerDocument(arg) + if (.not.associated(doc)) return + np => null() + brokenNS = doc%docExtras%brokenNS + doc%docExtras%brokenNS = .true. ! May need to do stupid NS things + readonly = .false. + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + new => null() + select case(getNodeType(this)) + case (ELEMENT_NODE) + if (getParameter(getDomConfig(doc), "namespaces")) then + new => createEmptyElementNS(doc, getNamespaceURI(this), getTagName(this)) + else + new => createEmptyElement(doc, getTagName(this)) + endif + case (ATTRIBUTE_NODE) + if (getParameter(getDomConfig(doc), "namespaces")) then + new => createAttributeNS(doc, getNamespaceURI(this), getName(this)) + else + new => createAttribute(doc, getName(this)) + endif + if (associated(this, arg)) then + call setSpecified(new, .true.) + else + call setSpecified(new, getSpecified(this)) + endif + case (TEXT_NODE) + new => createTextNode(doc, getData(this)) + case (CDATA_SECTION_NODE) + new => createCDataSection(doc, getData(this)) + case (ENTITY_REFERENCE_NODE) + ERchild => this + readonly = .true. + new => createEntityReference(doc, getNodeName(this)) + doneChildren = .true. + case (ENTITY_NODE) + return + case (PROCESSING_INSTRUCTION_NODE) + new => createProcessingInstruction(doc, getTarget(this), getData(this)) + case (COMMENT_NODE) + new => createComment(doc, getData(this)) + case (DOCUMENT_NODE) + return + case (DOCUMENT_TYPE_NODE) + return + case (DOCUMENT_FRAGMENT_NODE) + new => createDocumentFragment(doc) + case (NOTATION_NODE) + return + end select + + if (.not.associated(thatParent)) then + thatParent => new + elseif (associated(new)) then + if (this%nodeType==ATTRIBUTE_NODE) then + new => setAttributeNode(thatParent, new) + else + new => appendChild(thatParent, new) + endif + endif + + if (.not.deep) then + if (getNodeType(arg)==ATTRIBUTE_NODE.or.getNodeType(arg)==ELEMENT_NODE) then + continue + else + exit + endif + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + + if (getNodeType(this)==ENTITY_REFERENCE_NODE & + .and.associated(ERchild, this)) then + ERchild => null() + readonly = .false. + endif + this%readonly = readonly + + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + if (.not.associated(this, treeroot)) thatParent => getLastChild(thatParent) + this => item(getAttributes(this), 0) + else + if (.not.deep) exit + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + if (getNodeType(this)==ELEMENT_NODE.and..not.deep) exit + if (.not.associated(this, treeroot)) then + if (getNodeType(this)==ATTRIBUTE_NODE) then + thatParent => item(getAttributes(thatParent), i_tree) + else + thatParent => getLastChild(thatParent) + endif + endif + 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 item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + if (associated(getParentNode(thatParent))) thatParent => getParentNode(thatParent) + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + if (.not.associated(this, treeroot)) then + if (getNodeType(this)==ATTRIBUTE_NODE) then + thatParent => getOwnerElement(thatParent) + else + thatParent => getParentNode(thatParent) + endif + endif + endif + endif + + enddo + + + + np => thatParent + doc%docExtras%brokenNS = brokenNS + + end function cloneNode + + + function hasAttributes(arg, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical :: hasAttributes + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "hasAttributes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType == ELEMENT_NODE) then + hasAttributes = (getLength(getAttributes(arg)) > 0) + else + hasAttributes = .false. + endif + + end function hasAttributes + +! function getBaseURI FIXME + +! function compareDocumentPosition FIXME + + subroutine normalize(arg, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: this, tempNode, oldNode, treeroot + integer :: i_tree, i_t + logical :: doneChildren, doneAttributes + character, pointer :: temp(:) + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "normalize", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +! DOM standard requires we ignore readonly status + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + if (getNodeType(this)==TEXT_NODE) then + if (associated(this, arg)) exit ! If we are called on a text node itself, then do nothing. + i_t = getLength(this) + tempNode => getNextSibling(this) + do while (associated(tempNode)) + if (getNodeType(tempNode)/=TEXT_NODE) exit + i_t = i_t + getLength(tempNode) + tempNode => getNextSibling(tempNode) + enddo + if (.not.associated(tempNode, getNextSibling(this))) then + allocate(temp(i_t)) + temp(:getLength(this)) = vs_str(getData(this)) + i_t = getLength(this) + tempNode => getNextSibling(this) + do while (associated(tempNode)) + if (getNodeType(tempNode)/=TEXT_NODE) exit + temp(i_t+1:i_t+getLength(tempNode)) = vs_str(getData(tempNode)) + i_t = i_t + getLength(tempNode) + oldNode => tempNode + tempNode => getNextSibling(tempNode) + oldNode => removeChild(getParentNode(oldNode), oldNode) + call remove_node_nl(arg%ownerDocument%docExtras%hangingNodes, oldNode) + call destroy(oldNode) + enddo + deallocate(this%nodeValue) + this%nodeValue => temp + endif + end if + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 normalize + + function isSupported(arg, feature, version, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: feature + character(len=*), intent(in) :: version + logical :: p + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "isSupported", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + p = hasFeature(getImplementation(arg%ownerDocument), feature, version) + end function isSupported + + pure function getNamespaceURI_len(arg, p) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (p) then + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + n = size(arg%elExtras%namespaceURI) + endif + endif + + end function getNamespaceURI_len + + function getNamespaceURI(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getNamespaceURI_len(arg, .true.)) :: c +#else + character(len=getNamespaceURI_len(arg, associated(arg))) :: c +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getNamespaceURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = "" + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + c = str_vs(arg%elExtras%namespaceURI) + endif + end function getNamespaceURI + +subroutine setnamespaceURI(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*) :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setnamespaceURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=XPATH_NAMESPACE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setnamespaceURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%elExtras%namespaceURI)) deallocate(np%elExtras%namespaceURI) + np%elExtras%namespaceURI => vs_str_alloc(c) + + end subroutine setnamespaceURI + + + pure function getPrefix_len(arg, p) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (p) then + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + n = size(arg%elExtras%prefix) + endif + endif + + end function getPrefix_len + + function getPrefix(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getPrefix_len(arg, .true.)) :: c +#else + character(len=getPrefix_len(arg, associated(arg))) :: c +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = "" + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + c = str_vs(arg%elExtras%prefix) + endif + + end function getPrefix + + subroutine setPrefix(arg, prefix, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*) :: prefix + + character, pointer :: tmp(:) + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(prefix, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkNCName(prefix, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (size(arg%elExtras%namespaceURI)==0) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefix=="xml" .and. & + str_vs(arg%elExtras%namespaceURI)/="http://www.w3.org/XML/1998/namespace") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefix=="xmlns" .and. (getNodeType(arg)/=ATTRIBUTE_NODE & + .or. str_vs(arg%elExtras%namespaceURI)/="http://www.w3.org/2000/xmlns/")) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)==ATTRIBUTE_NODE.and.getName(arg)=="xmlns") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif +! FIXME check if prefix is declared and already points to same namespace +! but only if we ever get full error-checking up and running. + deallocate(arg%elExtras%prefix) + arg%elExtras%prefix => vs_str_alloc(prefix) + tmp => arg%nodeName + i = index(str_vs(arg%nodeName), ":") + if (i==0) then + arg%nodeName => vs_str_alloc(prefix//":"//str_vs(tmp)) + else + arg%nodeName => vs_str_alloc(prefix//str_vs(tmp(i:))) + endif + deallocate(tmp) + endif + + call updateNodeLists(arg%ownerDocument) + + end subroutine setPrefix + + pure function getLocalName_len(arg, p) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (p) then + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + n = size(arg%elExtras%localName) + endif + endif + + end function getLocalName_len + + function getLocalName(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getLocalName_len(arg, .true.)) :: c +#else + character(len=getLocalName_len(arg, associated(arg))) :: c +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getLocalName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = "" + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + c = str_vs(arg%elExtras%localName) + endif + + end function getLocalName + + recursive function isEqualNode(arg, other, ex)result(p) + type(DOMException), intent(out), optional :: ex + ! We only have one level of recursion, in case of element attributes + type(Node), pointer :: arg + type(Node), pointer :: other + logical :: p + + type(Node), pointer :: this, that, treeroot, treeroot2, att1, att2 + type(NodeList), pointer :: children1, children2 + type(NamedNodeMap), pointer :: atts1, atts2 + + integer :: i_tree, i + logical :: doneChildren, doneAttributes, equal + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "isEqualNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (isSameNode(arg, other)) then + ! Shortcut the treewalking + p = .true. + return + else + p = .false. + endif + + treeroot => arg + treeroot2 => other + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + that => treeroot2 + equal = .false. + do + if (getNodeType(this)/=getNodeType(that)) exit + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + if (getNodeType(this)/=getNodeType(that)) return + ! Check necessary equal attributes ... + if (getNodeName(this)/=getNodeName(that) & + .or. getLocalName(this)/=getLocalName(that) & + .or. getNamespaceURI(this)/=getNamespaceURI(that) & + .or. getPrefix(this)/=getPrefix(that) & + .or. getNodeValue(this)/=getNodeValue(that)) & + return + children1 => getChildNodes(this) + children2 => getChildNodes(that) + if (getLength(children1)/=getLength(children2)) return + ! Well get to the contents of the children later on anyway. + if (getNodeType(this)==ELEMENT_NODE) then + ! We must treat attributes specially here (rather than relying on + ! treewalk) since the order can legitimately change. + atts1 => getAttributes(this) + atts2 => getAttributes(that) + if (getLength(atts1)/=getLength(atts2)) return + do i = 0, getLength(atts1)-1 + att1 => item(atts1, i) + if (getNamespaceURI(att1)=="") then + att2 => getNamedItem(atts2, getNodeName(att1)) + else + att2 => getNamedItemNS(atts2, getLocalName(att1), getNamespaceURI(att1)) + endif + if (.not.associated(att2)) return + if (.not.isEqualNode(att1, att2)) return + enddo + doneAttributes = .true. + elseif (getNodeType(this)==DOCUMENT_TYPE_NODE) then + if (getPublicId(this)/=getPublicId(that) & + .or. getSystemId(this)/=getSystemId(that) & + .or. getInternalSubset(this)/=getInternalSubset(that)) return + atts1 => getEntities(this) + atts2 => getEntities(that) + if (getLength(atts1)/=getLength(atts2)) return + do i = 0, getLength(atts1)-1 + att1 => item(atts1, i) + att2 => getNamedItem(atts2, getNodeName(att1)) + if (.not.associated(att2)) return + if (.not.isEqualNode(att1, att2)) return + enddo + atts1 => getNotations(this) + atts2 => getNotations(that) + if (getLength(atts1)/=getLength(atts2)) return + do i = 0, getLength(atts1)-1 + att1 => item(atts1, i) + att2 => getNamedItem(atts2, getNodeName(att1)) + if (.not.associated(att2)) return + if (.not.isEqualNode(att1, att2)) return + enddo + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))/=getLength(getAttributes(that))) exit + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + that => item(getAttributes(that), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this).or.hasChildNodes(that)) then + if (getLength(getChildNodes(this))/=getLength(getChildNodes(that))) exit + this => getFirstChild(this) + that => getFirstChild(that) + 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 item(getAttributes(getOwnerElement(this)), i_tree) + that => item(getAttributes(getOwnerElement(that)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + that => getOwnerElement(that) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + that => getNextSibling(that) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + that => getParentNode(that) + endif + endif + + enddo + + + + p = .true. + + end function isEqualNode + + + function isSameNode(arg, other, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: other + logical :: isSameNode + + if (.not.associated(arg).or..not.associated(other)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "isSameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + isSameNode = associated(arg, other) + + end function isSameNode + + !FIXME all the lookup* functions below are out of spec, + ! since they rely on a statically-calculated set of NSnodes + ! which is only generated at parse time, and updated after + ! normalize. + ! the spec reckons it should be dynamic, but because we need + ! to know string lengths, which must be calculated inside + ! a pure function, we cant do the recursive walk we need to. + ! (although isDefaultNamespace could be fixed easily enough) + + function isDefaultNamespace(np, namespaceURI, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*), intent(in) :: namespaceURI + logical :: p + + type(Node), pointer :: el + integer :: i + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "isDefaultNamespace", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + el => null() + select case(getNodeType(np)) + case (ELEMENT_NODE) + el => np + case (ATTRIBUTE_NODE) + el => getOwnerElement(np) + case (DOCUMENT_NODE) + el => getDocumentElement(np) + end select + + p = .false. + if (associated(el)) then + do i = 1, el%elExtras%namespaceNodes%length + if (size(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==0) then + p = (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) + return + endif + enddo + endif + end function isDefaultNamespace + + pure function lookupNamespaceURI_len(np, prefix, p) result(n) + type(Node), intent(in) :: np + character(len=*), intent(in) :: prefix + logical, intent(in) :: p + integer :: n + + integer :: i + + n = 0 + if (.not.p) return + if (np%nodeType/=ELEMENT_NODE & + .and. np%nodeType/=ATTRIBUTE_NODE & + .and. np%nodeType/=DOCUMENT_NODE) return + + if (prefix=="xml".or.prefix=="xmlns") then + n = 0 + return + endif + + select case(np%nodeType) + case (ELEMENT_NODE) + do i = 1, np%elExtras%namespaceNodes%length + if (str_vs(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then + n = size(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) + return + endif + enddo + case (ATTRIBUTE_NODE) + if (associated(np%elExtras%ownerElement)) then + do i = 1, np%elExtras%ownerElement%elExtras%namespaceNodes%length + if (str_vs(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then + n = size(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) + return + endif + enddo + endif + case (DOCUMENT_NODE) + if (associated(np%docExtras%documentElement)) then + do i = 1, np%docExtras%documentElement%elExtras%namespaceNodes%length + if (str_vs(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then + n = size(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) + return + endif + enddo + endif + end select + + end function lookupNamespaceURI_len + + function lookupNamespaceURI(np, prefix, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*), intent(in) :: prefix +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=lookupNamespaceURI_len(np, prefix, .true.)) :: c +#else + character(len=lookupNamespaceURI_len(np, prefix, associated(np))) :: c +#endif + + type(Node), pointer :: el + integer :: i + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "lookupNamespaceURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c)==0) then + c = "" + return + endif + + el => null() + select case(getNodeType(np)) + case (ELEMENT_NODE) + el => np + case (ATTRIBUTE_NODE) + el => getOwnerElement(np) + case (DOCUMENT_NODE) + el => getDocumentElement(np) + end select + + if (associated(el)) then + do i = 1, el%elExtras%namespaceNodes%length + if (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then + c = str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) + return + endif + enddo + endif + + end function lookupNamespaceURI + + pure function lookupPrefix_len(np, namespaceURI, p) result(n) + type(Node), intent(in) :: np + character(len=*), intent(in) :: namespaceURI + logical, intent(in) :: p + integer :: n + + integer :: i + + n = 0 + if (.not.p) return + if (np%nodeType/=ELEMENT_NODE & + .and. np%nodeType/=ATTRIBUTE_NODE & + .and. np%nodeType/=DOCUMENT_NODE) return + + if (namespaceURI=="" & + .or. namespaceURI=="http://www.w3.org/XML/1998/namespace" & + .or. namespaceURI=="http://www.w3.org/2000/xmlns/") then + return + endif + + select case(np%nodeType) + case (ELEMENT_NODE) + do i = 1, np%elExtras%namespaceNodes%length + if (str_vs(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then + n = size(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) + return + endif + enddo + case (ATTRIBUTE_NODE) + if (associated(np%elExtras%ownerElement)) then + do i = 1, np%elExtras%ownerElement%elExtras%namespaceNodes%length + if (str_vs(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then + n = size(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) + return + endif + enddo + endif + case (DOCUMENT_NODE) + if (associated(np%docExtras%documentElement)) then + do i = 1, np%docExtras%documentElement%elExtras%namespaceNodes%length + if (str_vs(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then + n = size(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) + return + endif + enddo + endif + end select + + end function lookupPrefix_len + + function lookupPrefix(np, namespaceURI, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*), intent(in) :: namespaceURI +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=lookupPrefix_len(np, namespaceURI, .true.)) :: c +#else + character(len=lookupPrefix_len(np, namespaceURI, associated(np))) :: c +#endif + + type(Node), pointer :: el + integer :: i + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "lookupPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c)==0) then + c = "" + return + endif + + el => null() + select case(getNodeType(np)) + case (ELEMENT_NODE) + el => np + case (ATTRIBUTE_NODE) + el => getOwnerElement(np) + case (DOCUMENT_NODE) + el => getDocumentElement(np) + end select + + if (associated(el)) then + do i = 1, el%elExtras%namespaceNodes%length + if (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then + c = str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) + return + endif + enddo + endif + end function lookupPrefix + + ! function getUserData + ! function setUserData + ! will not implement ... + + subroutine updateTextContentLength(np, n) + type(Node), pointer :: np + integer, intent(in) :: n + + type(Node), pointer :: this + + if (n/=0) then + this => np + do while (associated(this)) + this%textContentLength = this%textContentLength + n + this => getParentNode(this) + if (associated(this)) then + if (getNodeType(this)==DOCUMENT_NODE) exit + endif + enddo + endif + end subroutine updateTextContentLength + + pure function getTextContent_len(arg, p) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + integer :: n + + if (p) then + n = arg%textContentLength + else + n = 0 + endif + end function getTextContent_len + + function getTextContent(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getTextContent_len(arg, .true.)) :: c +#else + character(len=getTextContent_len(arg, associated(arg))) :: c +#endif + + type(Node), pointer :: this, treeroot + integer :: i, i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c) == 0) then + c = "" + return + endif + + i = 1 + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (associated(this, treeroot).and.isCharData(getNodeType(this))) then + c = getData(this) + return + endif + select case(getNodeType(this)) + case (ELEMENT_NODE) + doneAttributes = .true. + ! Ignore attributes for text content (unless this is an attribute!) + case(TEXT_NODE, CDATA_SECTION_NODE) + if (.not.getIsElementContentWhitespace(this)) then + c(i:i+size(this%nodeValue)-1) = str_vs(this%nodeValue) + i = i + size(this%nodeValue) + endif + end select + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 function getTextContent + + subroutine setTextContent(arg, textContent, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: textContent + + type(Node), pointer :: np + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkChars(textContent, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "setTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + select case(getNodeType(arg)) + case (ELEMENT_NODE, ATTRIBUTE_NODE, DOCUMENT_FRAGMENT_NODE) + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + do i = 1, getLength(getChildNodes(arg)) + call destroyNode(arg%childNodes%nodes(i)%this) + enddo + deallocate(arg%childNodes%nodes) + allocate(arg%childNodes%nodes(0)) + arg%childNodes%length = 0 + arg%firstChild => null() + arg%lastChild => null() + arg%textContentLength = 0 + np => createTextNode(getOwnerDocument(arg), textContent) + np => appendChild(arg, np) + case (TEXT_NODE, CDATA_SECTION_NODE, PROCESSING_INSTRUCTION_NODE, COMMENT_NODE) + call setData(arg, textContent) + case (ENTITY_NODE, ENTITY_REFERENCE_NODE) + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + end subroutine setTextContent + + function getBaseURI(arg, ex)result(baseURI) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=200) :: baseURI + + type(Node), pointer :: el + type(URI), pointer :: URIref, URIbase, newURI + + select case(getNodeType(arg)) + case (ELEMENT_NODE) + el => arg + case (ATTRIBUTE_NODE) + if (getName(arg)=="xml:base") then + if (associated(getOwnerElement(arg))) then + el => getParentNode(getOwnerElement(arg)) + else + el => null() + endif + else + el => getOwnerElement(arg) + endif + case (TEXT_NODE) + ! then are we in an attribute or textContent? + el => getParentNode(arg) + do while (associated(el)) + if (getNodeType(el)==ELEMENT_NODE) then + exit + elseif (getNodeType(el)==ATTRIBUTE_NODE) then + el => getOwnerElement(el) + exit + else + el => getParentNode(el) + endif + enddo + case (PROCESSING_INSTRUCTION_NODE) + ! then are we in or out of element content? + el => getParentNode(arg) + do while (associated(el)) + if (getNodeType(el)==ELEMENT_NODE) then + exit + elseif (getNodeType(el)==DOCUMENT_NODE) then + el => getOwnerElement(el) + exit + else + el => getParentNode(el) + endif + enddo + case default + el => null() + end select + + URIref => parseURI("") + + do while (associated(el)) + select case (getNodeType(el)) + case (ELEMENT_NODE) + if (hasAttribute(el, "xml:base")) then + URIbase => parseURI(getAttribute(el, "xml:base")) + newURI => rebaseURI(URIbase, URIref) + call destroyURI(URIbase) + call destroyURI(URIref) + URIref => newURI + if (isAbsoluteURI(URIref)) exit + endif + case (ENTITY_REFERENCE_NODE) + if (getSystemId(el)/="") then + URIbase => parseURI(getSystemId(el)) + newURI => rebaseURI(URIbase, URIref) + call destroyURI(URIbase) + call destroyURI(URIref) + URIref => newURI + if (isAbsoluteURI(URIref)) exit + endif + case default + exit + end select + el => getParentNode(el) + end do + + if (isAbsoluteURI(URIref)) then + baseURI = expressURI(URIref) + else + baseURI = "" + endif + call destroyURI(URIref) + + end function getBaseURI + + recursive function getNodePath(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + ! recursive only for atts and text + type(Node), pointer :: arg + character(len=100) :: c + + type(Node), pointer :: this, this2 + character(len=len(c)) :: c2 + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getNodePath", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = "" + if (.not.arg%inDocument) return + select case(getNodeType(arg)) + + case (ELEMENT_NODE) + this => arg + do while (getNodeType(this)/=DOCUMENT_NODE) + c2 = "" + this2 => getPreviousSibling(this) + n = 0 + do while (associated(this2)) + if (getNodeType(this2)==ELEMENT_NODE & + .and.getNodeName(this2)==getNodeName(this)) n = n + 1 + this2 => getPreviousSibling(this2) + enddo + if (n==0) then + this2 => getNextSibling(this) + do while (associated(this2)) + if (getNodeType(this2)==ELEMENT_NODE & + .and.getNodeName(this2)==getNodeName(this)) then + n = 1 + exit + endif + this2 => getNextSibling(this2) + enddo + else + n = n + 1 + endif + if (n>0) c2 = "["//n//"]" + ! What name to use: + if (getNamespaceURI(this)/="".and.getPrefix(this)=="") then + ! default namespace; need to do the * trick + ! how many previous siblings? + c2 = "/*"//c2 + else + c2 = "/"//getNodeName(this)//c2 + endif + c = trim(c2)//c + this => getParentNode(this) + enddo + + case (ATTRIBUTE_NODE) + c = trim(getNodePath(getOwnerElement(arg)))//"/@"//getNodeName(arg) + + case (TEXT_NODE, CDATA_SECTION_NODE) + ! FIXME this will give wrong answers sometimes if + ! the tree contains entity references + this => getParentNode(arg) + do while (associated(this)) + if (getNodeType(this)==ELEMENT_NODE) exit + this => getParentNode(this) + enddo + if (getNodeType(this)/=ELEMENT_NODE) & + this => getOwnerElement(this) + c = trim(getNodePath(this))//"/text()" + this => getPreviousSibling(arg) + n = 0 + do while (associated(this)) + if (getNodeType(this)==TEXT_NODE & + .or.getNodeType(this)==CDATA_SECTION_NODE) n = n + 1 + this => getPreviousSibling(this) + enddo + if (n==0) then + this => getNextSibling(arg) + do while (associated(this)) + if (getNodeType(this)==COMMENT_NODE & + .or.getNodeType(this)==CDATA_SECTION_NODE) then + n = 1 + exit + endif + this => getNextSibling(this) + enddo + else + n = n + 1 + endif + if (n>0) c = trim(c)//"["//n//"]" + + case (PROCESSING_INSTRUCTION_NODE) + this => getParentNode(arg) + c = trim(getNodePath(this))//"/processing-instruction("//getNodeName(arg)//")" + this => getPreviousSibling(arg) + n = 0 + do while (associated(this)) + if (getNodeType(this)==PROCESSING_INSTRUCTION_NODE & + .and.getNodeName(this)==getNodeName(arg)) n = n + 1 + this => getPreviousSibling(this) + enddo + if (n==0) then + this => getNextSibling(arg) + do while (associated(this)) + if (getNodeType(this)==PROCESSING_INSTRUCTION_NODE & + .and.getNodeName(this)==getNodeName(arg)) then + n = 1 + exit + endif + this => getNextSibling(this) + enddo + else + n = n + 1 + endif + if (n>0) c = trim(c)//"["//n//"]" + + case (COMMENT_NODE) + this => getParentNode(arg) + c = trim(getNodePath(this))//"/comment()" + this => getPreviousSibling(arg) + n = 0 + do while (associated(this)) + if (getNodeType(this)==COMMENT_NODE) n = n + 1 + this => getPreviousSibling(this) + enddo + if (n==0) then + this => getNextSibling(arg) + do while (associated(this)) + if (getNodeType(this)==COMMENT_NODE) then + n = 1 + exit + endif + this => getNextSibling(this) + enddo + else + n = n + 1 + endif + if (n>0) c = trim(c)//"["//n//"]" + + case (DOCUMENT_NODE) + c = "/" + + case (XPATH_NAMESPACE_NODE) + this => getOwnerElement(arg) + if (getPrefix(arg)=="") then + c = trim(getNodePath(this))//"/namespace::xmlns" + else + c = trim(getNodePath(this))//"/namespace::"//getPrefix(arg) + endif + ! FIXME namespace nodes are not marked as inDocument correctly + + end select + + end function getNodePath + + subroutine putNodesInDocument(doc, arg) + type(Node), pointer :: doc, arg + type(Node), pointer :: this, treeroot + logical :: doneChildren, doneAttributes + integer :: i_tree + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + this%inDocument = .true. + call remove_node_nl(doc%docExtras%hangingNodes, this) + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 putNodesInDocument + + subroutine removeNodesFromDocument(doc, arg) + type(Node), pointer :: doc, arg + type(Node), pointer :: this, treeroot + logical :: doneChildren, doneAttributes + integer :: i_tree + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + this%inDocument = .false. + call append_nl(doc%docExtras%hangingNodes, this) + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 removeNodesFromDocument + + subroutine setReadOnlyNode(arg, p, deep) + type(Node), pointer :: arg + logical, intent(in) :: p + logical, intent(in) :: deep + + type(Node), pointer :: this, treeroot + integer :: i_tree + logical :: doneAttributes, doneChildren + + if (deep) then + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + this%readonly = p + if (this%nodeType==ELEMENT_NODE) & + this%elExtras%attributes%readonly = p + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 + + + else + arg%readonly = p + if (arg%nodeType==ELEMENT_NODE) & + arg%elExtras%attributes%readonly = p + endif + + end subroutine setReadOnlyNode + +function getreadonly(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getreadonly", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c = np%readonly + + end function getreadonly + + + + + function item_nl(list, index, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NodeList), pointer :: list + integer, intent(in) :: index + type(Node), pointer :: np + + if (.not.associated(list)) then + if (getFoX_checks().or.FoX_LIST_IS_NULL<200) then + call throw_exception(FoX_LIST_IS_NULL, "item_nl", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (index>=0.and.index list%nodes(index+1)%this + else + np => null() + endif + + end function item_nl + + subroutine append_nl(list, arg) + type(NodeList), intent(inout) :: list + type(Node), pointer :: arg + + type(ListNode), pointer :: temp_nl(:) + integer :: i + + if (.not.associated(list%nodes)) then + allocate(list%nodes(1)) + list%nodes(1)%this => arg + list%length = 1 + else + temp_nl => list%nodes + allocate(list%nodes(size(temp_nl)+1)) + do i = 1, size(temp_nl) + list%nodes(i)%this => temp_nl(i)%this + enddo + deallocate(temp_nl) + list%nodes(size(list%nodes))%this => arg + list%length = size(list%nodes) + endif + + end subroutine append_nl + + function pop_nl(list, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NodeList), pointer :: list + type(Node), pointer :: np + + type(ListNode), pointer :: temp_nl(:) + integer :: i + + if (list%length==0) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "pop_nl", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => list%nodes(size(list%nodes))%this + + if (list%length==1) then + deallocate(list%nodes) + list%length = 0 + else + temp_nl => list%nodes + allocate(list%nodes(size(temp_nl)-1)) + do i = 1, size(temp_nl)-1 + list%nodes(i)%this => temp_nl(i)%this + enddo + deallocate(temp_nl) + list%length = size(list%nodes) + endif + + end function pop_nl + + + function remove_nl(nl, index, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NodeList), intent(inout) :: nl + integer, intent(in) :: index + type(Node), pointer :: np + + type(ListNode), pointer :: temp_nl(:) + + integer :: i + + if (index>nl%length) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "remove_nl", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => nl%nodes(index)%this + temp_nl => nl%nodes + allocate(nl%nodes(size(temp_nl)-1)) + nl%length = nl%length - 1 + do i = 1, index - 1 + nl%nodes(i)%this => temp_nl(i)%this + enddo + do i = index, nl%length + nl%nodes(i)%this => temp_nl(i+1)%this + enddo + deallocate(temp_nl) + + end function remove_nl + + + subroutine remove_node_nl(nl, np) + type(NodeList), intent(inout) :: nl + type(Node), pointer :: np + + integer :: i + + do i = 1, nl%length + if (associated(nl%nodes(i)%this, np)) exit + enddo + np => remove_nl(nl, i) + + end subroutine remove_node_nl + + + function getLength_nl(nl, ex)result(n) + type(DOMException), intent(out), optional :: ex + type(NodeList), pointer :: nl + integer :: n + + if (.not.associated(nl)) then + if (getFoX_checks().or.FoX_LIST_IS_NULL<200) then + call throw_exception(FoX_LIST_IS_NULL, "getLength_nl", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + n = size(nl%nodes) + end function getLength_nl + + subroutine destroyNodeList(nl) + type(NodeList), pointer :: nl + + if (associated(nl%nodes)) deallocate(nl%nodes) + if (associated(nl%nodeName)) deallocate(nl%nodeName) + if (associated(nl%localName)) deallocate(nl%localName) + if (associated(nl%namespaceURI)) deallocate(nl%namespaceURI) + deallocate(nl) + end subroutine destroyNodeList + + subroutine updateNodeLists(doc) + ! When triggered, update all nodelists + type(Node), pointer :: doc + + type(NodeList), pointer :: nl, nl_orig + type(NodeListPtr), pointer :: temp_nll(:) + integer :: i, i_t + + if (.not.getGCstate(doc)) return + if (.not.doc%docExtras%liveNodeLists) return + if (.not.associated(doc%docExtras%nodelists)) return + + ! We point the old list of nodelists to temp_nll, then recalculate + ! them all (which repopulates nodelists) + temp_nll => doc%docExtras%nodelists + i_t = size(temp_nll) + allocate(doc%docExtras%nodelists(0)) + do i = 1, i_t + nl_orig => temp_nll(i)%this + ! + ! Although all nodes should be searched whatever the result, + ! we should only do the appropriate sort of search for this + ! list - according to namespaces or not. + ! + if (associated(nl_orig%nodeName)) then + ! this was made by getElementsByTagName + nl => getElementsByTagName(nl_orig%element, str_vs(nl_orig%nodeName)) + elseif (associated(nl_orig%namespaceURI)) then + ! this was made by getElementsByTagNameNS + nl => getElementsByTagNameNS(nl_orig%element, & + str_vs(nl_orig%localName), str_vs(nl_orig%namespaceURI)) + endif + enddo + ! We dont care about the nodelists weve calculated now + nullify(nl) + + deallocate(temp_nll) + + end subroutine updateNodeLists + + + + function getNamedItem(map, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + character(len=*), intent(in) :: name + type(Node), pointer :: np + + integer :: i + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "getNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + do i = 1, map%length + if (str_vs(map%nodes(i)%this%nodeName)==name) then + np => map%nodes(i)%this + return + endif + enddo + + np => null() + + end function getNamedItem + + + function setNamedItem(map, arg, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + type(Node), pointer :: arg + type(Node), pointer :: np + + integer :: i + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (map%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (map%ownerElement%nodeType==ELEMENT_NODE) then + if (.not.associated(map%ownerElement%ownerDocument, arg%ownerDocument)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ATTRIBUTE_NODE) then + !Additional check from DOM 3 + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + + if (getNodeType(arg)==ATTRIBUTE_NODE) then + if (associated(map%ownerElement, getOwnerElement(arg))) then + ! we are looking at literally the same node + np => arg + return + elseif (associated(getOwnerElement(arg))) then + if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then + call throw_exception(INUSE_ATTRIBUTE_ERR, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + arg%elExtras%ownerElement => map%ownerElement + endif + + do i = 0, getLength(map)-1 + np => item(map, i) + if (getNodeName(np)==getNodeName(arg)) then + map%nodes(i+1)%this => arg + exit + endif + enddo + + if (i null() + call append_nnm(map, arg) + endif + + if (map%ownerElement%nodeType==ELEMENT_NODE) then + if (getGCstate(getOwnerDocument(map%ownerElement))) then + ! We need to worry about importing this node + if (map%ownerElement%inDocument) then + if (.not.arg%inDocument) & + call putNodesInDocument(getOwnerDocument(map%ownerElement), arg) + else + if (arg%inDocument) & + call removeNodesFromDocument(getOwnerDocument(map%ownerElement), arg) + endif + endif + endif + ! Otherwise we only ever setNNM when building the doc, so we know this + ! does not matter + + end function setNamedItem + + + function removeNamedItem(map, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + character(len=*), intent(in) :: name + type(Node), pointer :: np + + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + type(ListNode), pointer :: temp_nl(:) + integer :: i, i2 + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "removeNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (map%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + do i = 0, map%length-1 + np => item(map, i) + if (getNodeName(np)==name) then + xds => getXds(getOwnerDocument(map%ownerElement)) + elem => get_element(xds%element_list, getNodeName(map%ownerElement)) + att => get_attribute_declaration(elem, name) + if (associated(att)) then + if (attribute_has_default(att)) then ! there is a default value + ! Well swap the old one out & put a new one in. + ! Do *nothing* about namespace handling at this stage, + ! wait until we are asked for namespace normalization + if (getParameter( & + getDomConfig(getOwnerDocument(map%ownerElement)), & + "namespaces")) then + np => createAttributeNS(getOwnerDocument(map%ownerElement), "", name) + else + np => createAttribute(getOwnerDocument(map%ownerElement), name) + endif + call setValue(np, str_vs(att%default)) + call setSpecified(np, .false.) + np => setNamedItem(map, np) + call setSpecified(np, .true.) + return + endif + endif + ! Otherwise there was no default value, so we just remove the node. + ! Grab this node + if (getNodeType(np)==ATTRIBUTE_NODE) np%elExtras%ownerElement => null() + ! and shrink the node list + temp_nl => map%nodes + allocate(map%nodes(size(temp_nl)-1)) + do i2 = 1, i + map%nodes(i2)%this => temp_nl(i2)%this + enddo + do i2 = i + 2, map%length + map%nodes(i2-1)%this => temp_nl(i2)%this + enddo + map%length = size(map%nodes) + deallocate(temp_nl) + if (np%inDocument.and.getGCstate(getOwnerDocument(map%ownerElement))) & + call removeNodesFromDocument(getOwnerDocument(map%ownerElement), np) + !otherwise we are only going to destroy these nodes anyway, + ! and finish + return + endif + enddo + + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + + end function removeNamedItem + + + function item_nnm(map, index, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + integer, intent(in) :: index + type(Node), pointer :: np + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "item_nnm", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (index<0 .or. index>map%length-1) then + np => null() + else + np => map%nodes(index+1)%this + endif + + end function item_nnm + + function getLength_nnm(map, ex)result(n) + type(DOMException), intent(out), optional :: ex + type(namedNodeMap), pointer :: map + integer :: n + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "getLength_nnm", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + n = map%length + + end function getLength_nnm + + + function getNamedItemNS(map, namespaceURI, localName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + type(Node), pointer :: np + + integer :: i + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "getNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (map%ownerElement%nodeType/=ELEMENT_NODE) then + np => null() + return + endif + + do i = 0, getLength(map) - 1 + np => item(map, i) + if (getNamespaceURI(np)==namespaceURI & + .and. getLocalName(np)==localName) then + return + endif + enddo + np => null() + + end function getNamedItemNS + + + function setNamedItemNS(map, arg, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + type(Node), pointer :: arg + type(Node), pointer :: np + + integer :: i + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (map%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (map%ownerElement%nodeType==ELEMENT_NODE) then + if (.not.associated(map%ownerElement%ownerDocument, arg%ownerDocument)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ATTRIBUTE_NODE) then + !Additional check from DOM 3 + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + + if (getNodeType(arg)==ATTRIBUTE_NODE) then + if (associated(map%ownerElement, getOwnerElement(arg))) then + ! we are looking at literally the same node, so do nothing else + np => arg + return + elseif (associated(getOwnerElement(arg))) then + if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then + call throw_exception(INUSE_ATTRIBUTE_ERR, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + arg%elExtras%ownerElement => map%ownerElement + endif + + do i = 0, getLength(map) - 1 + np => item(map, i) + if ((getLocalName(arg)==getLocalName(np) & + .and.getNamespaceURI(arg)==getNamespaceURI(np)) & + ! Additional case to catch adding of specified attributeNS over + ! default (NS but unspecified URI) attribute + .or.(getNamespaceURI(arg)=="".and.getName(arg)==getName(np))) then + map%nodes(i+1)%this => arg + exit + endif + enddo + + if (i null() + call append_nnm(map, arg) + endif + + if (map%ownerElement%nodeType==ELEMENT_NODE) then + if (getGCstate(getOwnerDocument(map%ownerElement))) then + ! We need to worry about importing this node + if (map%ownerElement%inDocument) then + if (.not.arg%inDocument) & + call putNodesInDocument(getOwnerDocument(map%ownerElement), arg) + else + if (arg%inDocument) & + call removeNodesFromDocument(getOwnerDocument(map%ownerElement), arg) + endif + endif + endif + + end function setNamedItemNS + + + function removeNamedItemNS(map, namespaceURI, localName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + type(Node), pointer :: np + + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + type(ListNode), pointer :: temp_nl(:) + integer :: i, i2 + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "removeNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (map%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + do i = 0, getLength(map) - 1 + np => item(map, i) + if (getNamespaceURI(np)==namespaceURI & + .and. getLocalName(np)==localName) then + ! Grab this node + xds => getXds(getOwnerDocument(map%ownerElement)) + elem => get_element(xds%element_list, getNodeName(map%ownerElement)) + att => get_attribute_declaration(elem, getName(np)) + if (associated(att)) then + if (attribute_has_default(att)) then ! there is a default value + ! Well swap the old one out & put a new one in. + ! Do *nothing* about namespace handling at this stage, + ! wait until we are asked for namespace normalization + np => createAttributeNS(getOwnerDocument(map%ownerElement), getNamespaceURI(np), getName(np)) + call setValue(np, str_vs(att%default)) + call setSpecified(np, .false.) + np => setNamedItemNS(map, np) + call setSpecified(np, .true.) + return + endif + endif + ! Otherwise there was no default value, so we just remove the node. + ! and shrink the node list + if (getNodeType(np)==ATTRIBUTE_NODE) np%elExtras%ownerElement => null() + temp_nl => map%nodes + allocate(map%nodes(size(temp_nl)-1)) + do i2 = 1, i + map%nodes(i2)%this => temp_nl(i2)%this + enddo + do i2 = i + 2, map%length + map%nodes(i2-1)%this => temp_nl(i2)%this + enddo + map%length = size(map%nodes) + deallocate(temp_nl) + if (np%inDocument.and.getGCstate(getOwnerDocument(map%ownerElement))) & + call removeNodesFromDocument(getOwnerDocument(map%ownerElement), np) + !otherwise we are only going to destroy these nodes anyway, + ! and finish + return + endif + enddo + + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + + end function removeNamedItemNS + + + subroutine append_nnm(map, arg) + type(namedNodeMap), pointer :: map + type(node), pointer :: arg + + type(ListNode), pointer :: temp_nl(:) + integer :: i + + if (.not.associated(map%nodes)) then + allocate(map%nodes(1)) + map%nodes(1)%this => arg + map%length = 1 + else + temp_nl => map%nodes + allocate(map%nodes(size(temp_nl)+1)) + do i = 1, size(temp_nl) + map%nodes(i)%this => temp_nl(i)%this + enddo + deallocate(temp_nl) + map%nodes(size(map%nodes))%this => arg + map%length = size(map%nodes) + endif + if (getNodeType(arg)==ATTRIBUTE_NODE) arg%elExtras%ownerElement => map%ownerElement + + end subroutine append_nnm + + + subroutine setReadOnlyMap(map, r) + type(namedNodeMap), pointer :: map + logical, intent(in) :: r + + map%readonly = r + end subroutine setReadOnlyMap + + subroutine destroyNamedNodeMap(map) + type(namedNodeMap), pointer :: map + + if (associated(map%nodes)) deallocate(map%nodes) + deallocate(map) + end subroutine destroyNamedNodeMap + + + + function hasFeature(impl, feature, version, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(DOMImplementation), pointer :: impl + character(len=*), intent(in) :: feature + character(len=*), intent(in) :: version + logical :: p + + if (.not.associated(impl)) then + if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then + call throw_exception(FoX_IMPL_IS_NULL, "hasFeature", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (version=="1.0".or.version=="2.0".or.version=="") then + p = (toLower(feature)=="core".or.toLower(feature)=="xml") + else + p = .false. + endif + + end function hasFeature + + function createDocumentType(impl, qualifiedName, publicId, systemId, ex)result(dt) + type(DOMException), intent(out), optional :: ex + type(DOMImplementation), pointer :: impl + character(len=*), intent(in) :: qualifiedName + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + type(Node), pointer :: dt + + type(URI), pointer :: URIref + + dt => null() + + if (.not.associated(impl)) then + if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then + call throw_exception(FoX_IMPL_IS_NULL, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkName(qualifiedName, XML1_0)) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkQName(qualifiedName, XML1_0)) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkPublicId(publicId)) then + if (getFoX_checks().or.FoX_INVALID_PUBLIC_ID<200) then + call throw_exception(FoX_INVALID_PUBLIC_ID, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + URIref => parseURI(systemId) + if (.not.associated(URIref)) then + if (getFoX_checks().or.FoX_INVALID_SYSTEM_ID<200) then + call throw_exception(FoX_INVALID_SYSTEM_ID, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call destroyURI(URIref) + +! Dont use raw null() below or PGI will complain + dt => createNode(dt, DOCUMENT_TYPE_NODE, qualifiedName, "") + allocate(dt%dtdExtras) + dt%readonly = .true. + dt%dtdExtras%publicId => vs_str_alloc(publicId) + dt%dtdExtras%systemId => vs_str_alloc(systemId) + dt%dtdExtras%entities%ownerElement => dt + dt%dtdExtras%notations%ownerElement => dt + + dt%ownerDocument => null() + + end function createDocumentType + + + function createDocument(impl, namespaceURI, qualifiedName, docType, ex)result(doc) + type(DOMException), intent(out), optional :: ex + type(DOMImplementation), pointer :: impl + character(len=*), intent(in), optional :: namespaceURI + character(len=*), intent(in), optional :: qualifiedName + type(Node), pointer :: docType + type(Node), pointer :: doc, dt, de + + doc => null() + + if (.not.associated(impl)) then + if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then + call throw_exception(FoX_IMPL_IS_NULL, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (associated(docType)) then + if (associated(getOwnerDocument(docType))) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + + if (.not.checkName(qualifiedName, XML1_0)) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif(.not.checkQName(qualifiedName, XML1_0)) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="".and.namespaceURI=="") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)=="xml".neqv.namespaceURI=="http://www.w3.org/XML/1998/namespace") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +! Dont use raw null() below or PGI will complain + doc => createNode(doc, DOCUMENT_NODE, "#document", "") + doc%ownerDocument => doc ! Makes life easier. DOM compliance in getter + doc%inDocument = .true. + + allocate(doc%docExtras) + doc%docExtras%implementation => FoX_DOM + allocate(doc%docExtras%nodelists(0)) + allocate(doc%docExtras%xds) + call init_xml_doc_state(doc%docExtras%xds) + allocate(doc%docExtras%xds%documentURI(0)) + allocate(doc%docExtras%domConfig) + + if (associated(docType)) then + dt => docType + dt%ownerDocument => doc + doc%docExtras%docType => appendChild(doc, dt, ex) + endif + + if (qualifiedName/="") then + ! NB It is impossible to create a non-namespaced document. + ! since createDocument doesnt exist in DOM Core 1 + de => createElementNS(doc, namespaceURI, qualifiedName) + de => appendChild(doc, de) + call setDocumentElement(doc, de) + endif + + call setGCstate(doc, .true.) + + end function createDocument + + + function createEmptyDocument() result(doc) + type(Node), pointer :: doc + +! PGI again + doc => null() + doc => createNode(doc, DOCUMENT_NODE, "#document", "") + doc%ownerDocument => doc ! Makes life easier. DOM compliance maintained in getter + doc%inDocument = .true. + + allocate(doc%docExtras) + doc%docExtras%implementation => FoX_DOM + allocate(doc%docExtras%nodelists(0)) + allocate(doc%docExtras%xds) + call init_xml_doc_state(doc%docExtras%xds) + + end function createEmptyDocument + + + subroutine destroyDocument(arg, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "destroyDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "destroyDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +! Switch off all GC - since this is GC! + call setGCstate(arg, .false., ex) + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "destroyDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +! Destroy all remaining nodelists + + do i = 1, size(arg%docExtras%nodelists) + call destroy(arg%docExtras%nodelists(i)%this) + enddo + deallocate(arg%docExtras%nodelists) + + ! Destroy all remaining hanging nodes + do i = 1, arg%docExtras%hangingNodes%length + call destroy(arg%docExtras%hangingNodes%nodes(i)%this) + enddo + if (associated(arg%docExtras%hangingNodes%nodes)) deallocate(arg%docExtras%hangingNodes%nodes) + + call destroy_xml_doc_state(arg%docExtras%xds) + if (present(ex)) then + if (inException(ex)) return + endif + if (associated(arg%docExtras%xds)) deallocate(arg%docExtras%xds) + if (associated(arg%docExtras%domConfig)) deallocate(arg%docExtras%domConfig) + if (associated(arg%docExtras)) deallocate(arg%docExtras) + + call destroyAllNodesRecursively(arg, except=.true.) + + end subroutine destroyDocument + + function getFoX_checks() result(FoX_checks) + logical :: FoX_checks + + FoX_checks = FoX_DOM%FoX_checks + end function getFoX_checks + + subroutine setFoX_checks(FoX_checks) + logical, intent(in) :: FoX_checks + + FoX_DOM%FoX_checks = FoX_checks + end subroutine setFoX_checks + + + + +function getdocType(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdocType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdocType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%docExtras%docType + + end function getdocType + + + subroutine setDocType(arg, np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setDocType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setDocType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + arg%docExtras%docType => np +!NB special case in order to set ownerDocument + np%ownerDocument => arg + end subroutine setDocType + +function getdocumentElement(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%docExtras%documentElement + + end function getdocumentElement + + + subroutine setXds(arg, xds, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(xml_doc_state), pointer :: xds + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setXds", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setXds", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif +!NB special case in order to destroy_xml_doc_state etc + call destroy_xml_doc_state(arg%docExtras%xds) + deallocate(arg%docExtras%xds) + arg%docExtras%xds => xds + + end subroutine setXds + + function getImplementation(arg, ex)result(imp) + type(DOMException), intent(out), optional :: ex + type(Node), pointer, optional :: arg + type(DOMImplementation), pointer :: imp + + ! According to the testsuite, you get to call + ! getImplementation with no args. Dont know + ! where they get that from ... + if (present(arg)) then + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getImplementation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getImplementation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + imp => arg%docExtras%implementation + else + imp => FoX_DOM + endif + end function getImplementation + + + subroutine setDocumentElement(arg, np, ex) + type(DOMException), intent(out), optional :: ex + ! Only for use by FoX, not exported through FoX_DOM interface + type(Node), pointer :: arg + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setDocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +!NB special case due to additional error conditions: + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setDocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (np%nodeType/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setDocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(np%ownerDocument, arg)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setDocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + arg%docExtras%documentElement => np + + end subroutine setDocumentElement + + ! Methods + + function createElement(arg, tagName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: tagName + type(Node), pointer :: np + + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + logical :: defaults_ + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(tagName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + np => createNode(arg, ELEMENT_NODE, tagName, "") + allocate(np%elExtras) + np%elExtras%dom1 = .true. + np%elExtras%attributes%ownerElement => np + allocate(np%elExtras%namespaceURI(0)) + allocate(np%elExtras%prefix(0)) + allocate(np%elExtras%localname(0)) + allocate(np%elExtras%namespaceNodes%nodes(0)) + + np%elExtras%attributes%ownerElement => np + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + ! We only add default attributes if we are *not* building the doc + xds => getXds(arg) + elem => get_element(xds%element_list, tagName) + if (associated(elem)) then + do i = 1, get_attlist_size(elem) + att => get_attribute_declaration(elem, i) + if (attribute_has_default(att)) then + ! Since this is a non-namespaced function, we create + ! a non-namespaced attribute ... + call setAttribute(np, str_vs(att%name), str_vs(att%default)) + endif + enddo + endif + else + np%inDocument = .true. + endif + + end function createElement + + function createEmptyElement(arg, tagName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: tagName + type(Node), pointer :: np + +! NO CHECKS ! + + np => createNode(arg, ELEMENT_NODE, tagName, "") + allocate(np%elExtras) + np%elExtras%dom1 = .true. + np%elExtras%attributes%ownerElement => np + allocate(np%elExtras%namespaceURI(0)) + allocate(np%elExtras%prefix(0)) + allocate(np%elExtras%localname(0)) + allocate(np%elExtras%namespaceNodes%nodes(0)) + + np%elExtras%attributes%ownerElement => np + + if (getGCstate(arg)) then + call append(arg%docExtras%hangingnodes, np) + np%inDocument = .false. + else + np%inDocument = .true. + endif + end function createEmptyElement + + function createDocumentFragment(arg, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createDocumentFragment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createDocumentFragment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, DOCUMENT_FRAGMENT_NODE, "#document-fragment", "") + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createDocumentFragment + + function createTextNode(arg, data, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: data + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createTextNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createTextNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "createTextNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, TEXT_NODE, "#text", data) + np%textContentLength = len(data) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createTextNode + + function createComment(arg, data, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: data + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createComment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createComment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "createComment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (index(data,"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "createComment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, COMMENT_NODE, "#comment", data) + np%textContentLength = len(data) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createComment + + function createCdataSection(arg, data, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: data + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createCdataSection", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createCdataSection", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "createCdataSection", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (index(data,"]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "createCdataSection", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, CDATA_SECTION_NODE, "#cdata-section", data) + np%textContentLength = len(data) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createCdataSection + + function createProcessingInstruction(arg, target, data, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: target + character(len=*), intent(in) :: data + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(target, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (index(data,"?>")>0) then + if (getFoX_checks().or.FoX_INVALID_PI_DATA<200) then + call throw_exception(FoX_INVALID_PI_DATA, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, PROCESSING_INSTRUCTION_NODE, target, data) + np%textContentLength = len(data) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createProcessingInstruction + + function createAttribute(arg, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(name, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, ATTRIBUTE_NODE, name, "") + allocate(np%elExtras) + np%elExtras%dom1 = .true. + allocate(np%elExtras%namespaceURI(0)) + allocate(np%elExtras%prefix(0)) + allocate(np%elExtras%localname(0)) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createAttribute + + + recursive function createEntityReference(arg, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + ! Needs to be recursive in case of entity-references within each other. + type(Node), pointer :: arg + character(len=*), intent(in) :: name + type(Node), pointer :: np + + type(Node), pointer :: ent, newNode + integer :: i + logical :: brokenNS + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(name, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getXmlStandalone(arg).and..not.associated(getDocType(arg))) then + if (getFoX_checks().or.FoX_NO_SUCH_ENTITY<200) then + call throw_exception(FoX_NO_SUCH_ENTITY, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, ENTITY_REFERENCE_NODE, name, "") + if (getGCstate(arg)) then ! otherwise the parser will fill these nodes in itself + if (associated(getDocType(arg))) then + ent => getNamedItem(getEntities(getDocType(arg)), name) + if (associated(ent)) then + if (getIllFormed(ent)) then + if (getFoX_checks().or.FoX_INVALID_ENTITY<200) then + call throw_exception(FoX_INVALID_ENTITY, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + brokenNS = arg%docExtras%brokenNS + arg%docExtras%brokenNS = .true. ! We need to not worry about NS errors for a bit + do i = 0, getLength(getChildNodes(ent)) - 1 + newNode => appendChild(np, cloneNode(item(getChildNodes(ent), i), .true., ex)) + ! No namespace calcs here - wait for a namespace normalization + call setReadOnlyNode(newNode, .true., .true.) + enddo + arg%docExtras%brokenNS = brokenNS ! FIXME also for all new default attributes + elseif (getXmlStandalone(arg)) then + if (getFoX_checks().or.FoX_NO_SUCH_ENTITY<200) then + call throw_exception(FoX_NO_SUCH_ENTITY, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + + if (associated(np)) deallocate(np) + return + endif + endif +endif + + endif + endif + endif + + call setReadOnlyNode(np, .true., .false.) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append_nl(arg%docExtras%hangingNodes, np) + ! All child nodes were created outside the document by cloneNode above + else + np%inDocument = .true. + endif + + end function createEntityReference + + function createEmptyEntityReference(arg, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createEmptyEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createEmptyEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(name, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createEmptyEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, ENTITY_REFERENCE_NODE, name, "") + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createEmptyEntityReference + + function getElementsByTagName(doc, tagName, name, ex)result(list) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + character(len=*), intent(in), optional :: tagName, name + type(NodeList), pointer :: list + + type(NodeListPtr), pointer :: nll(:), temp_nll(:) + type(Node), pointer :: arg, this, treeroot + logical :: doneChildren, doneAttributes, allElements + integer :: i, i_tree + + if (.not.associated(doc)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (doc%nodeType==DOCUMENT_NODE) then + if (present(name).or..not.present(tagName)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + elseif (doc%nodeType==ELEMENT_NODE) then + if (present(name).or..not.present(tagName)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (doc%nodeType==DOCUMENT_NODE) then + arg => getDocumentElement(doc) + else + arg => doc + endif + + allocate(list) + allocate(list%nodes(0)) + list%element => doc + if (present(name)) list%nodeName => vs_str_alloc(name) + if (present(tagName)) list%nodeName => vs_str_alloc(tagName) + + allElements = (str_vs(list%nodeName)=="*") + + if (doc%nodeType==DOCUMENT_NODE) then + nll => doc%docExtras%nodelists + elseif (doc%nodeType==ELEMENT_NODE) then + nll => doc%ownerDocument%docExtras%nodelists + endif + allocate(temp_nll(size(nll)+1)) + do i = 1, size(nll) + temp_nll(i)%this => nll(i)%this + enddo + temp_nll(i)%this => list + deallocate(nll) + if (doc%nodeType==DOCUMENT_NODE) then + doc%docExtras%nodelists => temp_nll + elseif (doc%nodeType==ELEMENT_NODE) then + doc%ownerDocument%docExtras%nodelists => temp_nll + endif + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + if (this%nodeType==ELEMENT_NODE) then + if ((allElements .or. str_vs(this%nodeName)==tagName) & + .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & + call append(list, this) + doneAttributes = .true. + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 function getElementsByTagName + + function importNode(doc , arg, deep , ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + type(Node), pointer :: arg + logical, intent(in) :: deep + type(Node), pointer :: np + + type(Node), pointer :: this, thatParent, new, treeroot + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + logical :: doneAttributes, doneChildren, brokenNS + integer :: i_tree + + if (.not.associated(doc).or..not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(doc)/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)==DOCUMENT_NODE .or. & + getNodeType(arg)==DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + brokenNS = doc%docExtras%brokenNS + doc%docExtras%brokenNS = .true. ! We need to do stupid NS things + xds => getXds(doc) + thatParent => null() + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + new => null() + select case (getNodeType(this, ex)) + case (ELEMENT_NODE) + if (.not.doneAttributes) then + ! We dont create an empty node - we insist on having all default + ! properties created. + if (getParameter(getDomConfig(doc, ex), "namespaces", ex)) then + new => createElementNS(doc, getNamespaceURI(this, ex), getTagName(this, ex), ex) + else + new => createElement(doc, getTagName(this, ex), ex) + endif + endif + case (ATTRIBUTE_NODE) + if (associated(this, arg).or.getSpecified(this, ex)) then + ! We are importing just this attribute node + ! or this was an explicitly specified attribute; either + ! way, we import it as is, and it remains specified. + if (getParameter(getDomConfig(doc), "namespaces")) then + new => createAttributeNS(doc, getNamespaceURI(this, ex), getName(this, ex), ex) + else + new => createAttribute(doc, getName(this), ex) + endif + call setSpecified(new, .true.) + else + ! This is an attribute being imported as part of a hierarchy, + ! but its only here by default. Is there a default attribute + ! of this name in the new document? + elem => get_element(xds%element_list, & + getTagName(getOwnerElement(this))) + att => get_attribute_declaration(elem, getName(this)) + if (attribute_has_default(att)) then + ! Create the new default: + if (getParameter(getDomConfig(doc, ex), "namespaces", ex)) then + ! We create a namespaced attribute. Of course, its + ! namespaceURI remains empty for the moment unless we know it ... + if (prefixOfQName(getName(this, ex))=="xml") then + new => createAttributeNS(doc, & + "http://www.w3.org/XML/1998/namespace", & + getName(this, ex), ex) + elseif (getName(this, ex)=="xmlns" & + .or. prefixOfQName(getName(this, ex))=="xmlns") then + new => createAttributeNS(doc, & + "http://www.w3.org/2000/xmlns/", & + getName(this, ex), ex) + else + ! Wait for namespace fixup ... + new => createAttributeNS(doc, "", & + getName(this, ex), ex) + endif + else + new => createAttribute(doc, getName(this, ex), ex) + endif + call setValue(new, str_vs(att%default), ex) + call setSpecified(new, .false.) + endif + ! In any case, we dont want to copy the children of this node. + doneChildren=.true. + endif + case (TEXT_NODE) + new => createTextNode(doc, getData(this, ex), ex) + case (CDATA_SECTION_NODE) + new => createCDataSection(doc, getData(this, ex), ex) + case (ENTITY_REFERENCE_NODE) + new => createEntityReference(doc, getNodeName(this, ex), ex) + ! This will automatically populate the entity reference if doc defines it, so no children needed + doneChildren = .true. + case (ENTITY_NODE) + new => createEntity(doc, getNodeName(this, ex), & + getPublicId(this, ex), getSystemId(this, ex), & + getNotationName(this, ex), ex) + case (PROCESSING_INSTRUCTION_NODE) + new => createProcessingInstruction(doc, & + getTarget(this, ex), getData(this, ex), ex) + case (COMMENT_NODE) + new => createComment(doc, getData(this, ex), ex) + case (DOCUMENT_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (DOCUMENT_TYPE_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (DOCUMENT_FRAGMENT_NODE) + new => createDocumentFragment(doc, ex) + case (NOTATION_NODE) + new => createNotation(doc, getNodeName(this, ex), & + getPublicId(this, ex), getSystemId(this, ex), ex) + end select + + if (.not.associated(thatParent)) then + thatParent => new + elseif (associated(new)) then + if (getNodeType(this, ex)==ATTRIBUTE_NODE) then + new => setAttributeNode(thatParent, new, ex) + else + new => appendChild(thatParent, new, ex) + endif + endif + + if (.not.deep) then + if (getNodeType(arg, ex)==ATTRIBUTE_NODE & + .or.getNodeType(arg, ex)==ELEMENT_NODE) then + continue + else + exit + endif + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + if (.not.associated(this, treeroot)) thatParent => getLastChild(thatParent) + this => item(getAttributes(this), 0) + else + if (.not.deep) exit + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + if (getNodeType(this)==ELEMENT_NODE.and..not.deep) exit + if (.not.associated(this, treeroot)) then + if (getNodeType(this)==ATTRIBUTE_NODE) then + thatParent => item(getAttributes(thatParent), i_tree) + else + thatParent => getLastChild(thatParent) + endif + endif + 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 item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + if (associated(getParentNode(thatParent))) thatParent => getParentNode(thatParent) + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + if (.not.associated(this, treeroot)) then + if (getNodeType(this)==ATTRIBUTE_NODE) then + thatParent => getOwnerElement(thatParent) + else + thatParent => getParentNode(thatParent) + endif + endif + endif + endif + + enddo + + + + np => thatParent + doc%docExtras%brokenNS = brokenNS +! call namespaceFixup(np) + + end function importNode + + function createElementNS(arg, namespaceURI, qualifiedName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, qualifiedName + type(Node), pointer :: np + + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + integer :: i + logical :: brokenNS + type(URI), pointer :: URIref + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="" & + .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & + prefixOfQName(qualifiedName)=="xml") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + URIref => parseURI(namespaceURI) + if (.not.associated(URIref)) then + if (getFoX_checks().or.FoX_INVALID_URI<200) then + call throw_exception(FoX_INVALID_URI, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call destroyURI(URIref) + + np => createNode(arg, ELEMENT_NODE, qualifiedName, "") + allocate(np%elExtras) + np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) + np%elExtras%prefix => vs_str_alloc(prefixOfQName(qualifiedname)) + np%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) + allocate(np%elExtras%namespaceNodes%nodes(0)) + + np%elExtras%attributes%ownerElement => np + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + ! We only add default attributes if we are *not* building the doc + xds => getXds(arg) + elem => get_element(xds%element_list, qualifiedName) + if (associated(elem)) then + do i = 1, get_attlist_size(elem) + att => get_attribute_declaration(elem, i) + if (attribute_has_default(att)) then + ! Since this is a namespaced function, we create a namespaced + ! attribute. Of course, its namespaceURI remains empty + ! for the moment unless we know it ... + if (prefixOfQName(str_vs(att%name))=="xml") then + call setAttributeNS(np, & + "http://www.w3.org/XML/1998/namespace", & + str_vs(att%name), str_vs(att%default), ex) + elseif (str_vs(att%name)=="xmlns" & + .or. prefixOfQName(str_vs(att%name))=="xmlns") then + call setAttributeNS(np, & + "http://www.w3.org/2000/xmlns/", & + str_vs(att%name), str_vs(att%default), ex) + else + ! Wait for namespace fixup ... + brokenNS = arg%docExtras%brokenNS + arg%docExtras%brokenNS = .true. + call setAttributeNS(np, "", str_vs(att%name), & + str_vs(att%default), ex) + arg%docExtras%brokenNS = brokenNS + endif + endif + enddo + endif + else + np%inDocument = .true. + endif + + end function createElementNS + + function createEmptyElementNS(arg, namespaceURI, qualifiedName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, qualifiedName + type(Node), pointer :: np + +! NO CHECKS ! + + np => createNode(arg, ELEMENT_NODE, qualifiedName, "") + allocate(np%elExtras) + np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) + np%elExtras%prefix => vs_str_alloc(prefixOfQName(qualifiedname)) + np%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) + allocate(np%elExtras%namespaceNodes%nodes(0)) + + np%elExtras%attributes%ownerElement => np + + if (getGCstate(arg)) then + call append(arg%docExtras%hangingnodes, np) + np%inDocument = .false. + else + np%inDocument = .true. + endif + end function createEmptyElementNS + + function createAttributeNS(arg, namespaceURI, qualifiedname, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, qualifiedName + type(Node), pointer :: np + + type(URI), pointer :: URIref + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="" & + .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & + prefixOfQName(qualifiedName)=="xml") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/" .neqv. & + (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns")) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + URIref => parseURI(namespaceURI) + if (.not.associated(URIref)) then + if (getFoX_checks().or.FoX_INVALID_URI<200) then + call throw_exception(FoX_INVALID_URI, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call destroyURI(URIref) + + + np => createNode(arg, ATTRIBUTE_NODE, qualifiedName, "") + allocate(np%elExtras) + np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) + np%elExtras%localname => vs_str_alloc(localPartofQName(qualifiedname)) + np%elExtras%prefix => vs_str_alloc(PrefixofQName(qualifiedname)) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createAttributeNS + + function getElementsByTagNameNS(doc, namespaceURI, localName, ex)result(list) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + character(len=*), intent(in) :: namespaceURI, localName + type(NodeList), pointer :: list + + type(NodeListPtr), pointer :: nll(:), temp_nll(:) + type(Node), pointer :: this, arg, treeroot + logical :: doneChildren, doneAttributes, allLocalNames, allNameSpaces + integer :: i, i_tree + + if (.not.associated(doc)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagNameNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (doc%nodeType/=DOCUMENT_NODE.and.doc%nodeType/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagNameNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + allNamespaces = (namespaceURI=="*") + allLocalNames = (localName=="*") + + if (doc%nodeType==DOCUMENT_NODE) then + arg => getDocumentElement(doc) + else + arg => doc + endif + + allocate(list) + allocate(list%nodes(0)) + list%element => doc + list%localName => vs_str_alloc(localName) + list%namespaceURI => vs_str_alloc(namespaceURI) + + if (doc%nodeType==DOCUMENT_NODE) then + nll => doc%docExtras%nodelists + elseif (doc%nodeType==ELEMENT_NODE) then + nll => doc%ownerDocument%docExtras%nodelists + endif + allocate(temp_nll(size(nll)+1)) + do i = 1, size(nll) + temp_nll(i)%this => nll(i)%this + enddo + temp_nll(i)%this => list + deallocate(nll) + if (doc%nodeType==DOCUMENT_NODE) then + doc%docExtras%nodelists => temp_nll + elseif (doc%nodeType==ELEMENT_NODE) then + doc%ownerDocument%docExtras%nodelists => temp_nll + endif + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)==ELEMENT_NODE) then + if (getNamespaceURI(this)/="") then + if ((allNameSpaces .or. getNameSpaceURI(this)==namespaceURI) & + .and. (allLocalNames .or. getLocalName(this)==localName) & + .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & + call append(list, this) + else + if ((allNameSpaces .or. namespaceURI=="") & + .and. (allLocalNames .or. getNodeName(this)==localName) & + .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & + call append(list, this) + endif + doneAttributes = .true. ! Never search attributes + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 function getElementsByTagNameNS + + + function getElementById(arg, elementId, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: elementId + type(Node), pointer :: np + + type(Node), pointer :: this, treeroot + integer :: i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getElementById", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementById", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => null() + treeroot => getDocumentElement(arg) + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + if (this%nodeType==ATTRIBUTE_NODE) then + if (getIsId(this).and.getValue(this)==elementId) then + np => getOwnerElement(this) + return + endif + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 function getElementById + +function getxmlStandalone(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getxmlStandalone", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getxmlStandalone", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%docExtras%xds%standalone + + end function getxmlStandalone + +subroutine setxmlStandalone(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setxmlStandalone", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setxmlStandalone", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%xds%standalone = c + + end subroutine setxmlStandalone + +! FIXME additional check on setting - do we have any undefined entrefs present? + + function getXmlVersion(arg, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=3) :: s + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE & + .and.arg%nodeType/=ENTITY_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getXmlVersionEnum(arg)==XML1_0) then + s = "1.0" + elseif (getXmlVersionEnum(arg)==XML1_1) then + s = "1.1" + else + s = "XXX" + endif + + end function getXmlVersion + + subroutine setXmlVersion(arg, s, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*) :: s + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (s=="1.0") then + arg%docExtras%xds%xml_version = XML1_0 + elseif (s=="1.1") then + arg%docExtras%xds%xml_version = XML1_1 + else + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "setXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end subroutine setXmlVersion + + pure function getXmlEncoding_len(arg, p) result(n) + type(Node), pointer :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (.not.p) return + if (arg%nodeType==DOCUMENT_NODE) & + n = size(arg%docExtras%xds%encoding) + end function getXmlEncoding_len + + function getXmlEncoding(arg, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getXmlEncoding_len(arg, .true.)) :: s +#else + character(len=getXmlEncoding_len(arg, associated(arg))) :: s +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getXmlEncoding", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType==DOCUMENT_NODE) then + s = str_vs(arg%docExtras%xds%encoding) + elseif (arg%nodeType==ENTITY_NODE) then + s = "" !FIXME revisit when we have working external entities + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getXmlEncoding", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end function getXmlEncoding + + pure function getInputEncoding_len(arg, p) result(n) + type(Node), pointer :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (.not.p) return + if (arg%nodeType==DOCUMENT_NODE) & + n = size(arg%docExtras%xds%inputEncoding) + end function getInputEncoding_len + + function getInputEncoding(arg, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getInputEncoding_len(arg, .true.)) :: s +#else + character(len=getInputEncoding_len(arg, associated(arg))) :: s +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getInputEncoding", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType==DOCUMENT_NODE) then + s = str_vs(arg%docExtras%xds%inputEncoding) + elseif (arg%nodeType==ENTITY_NODE) then + s = "" !FIXME revisit when we have working external entities + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getInputEncoding", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end function getInputEncoding + + + pure function getdocumentURI_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==DOCUMENT_NODE .or. & + .false.)) then + n = size(np%docExtras%xds%documentURI) + else + n = 0 + endif + end function getdocumentURI_len +function getdocumentURI(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getdocumentURI_len(np, .true.)) :: c +#else + character(len=getdocumentURI_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdocumentURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdocumentURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%docExtras%xds%documentURI) + + end function getdocumentURI + +subroutine setdocumentURI(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*) :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setdocumentURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setdocumentURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%docExtras%xds%documentURI)) deallocate(np%docExtras%xds%documentURI) + np%docExtras%xds%documentURI => vs_str_alloc(c) + + end subroutine setdocumentURI + + +function getstrictErrorChecking(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getstrictErrorChecking", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getstrictErrorChecking", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%docExtras%strictErrorChecking + + end function getstrictErrorChecking + +subroutine setstrictErrorChecking(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setstrictErrorChecking", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setstrictErrorChecking", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%strictErrorChecking = c + + end subroutine setstrictErrorChecking + + + function adoptNode(doc , arg , ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + type(Node), pointer :: arg + type(Node), pointer :: np + + type(Node), pointer :: this, thatParent, new, treeroot, parent, dead + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + logical :: doneAttributes, doneChildren, brokenNS + integer :: i_tree + + if (.not.associated(doc).or..not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(doc)/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)==DOCUMENT_NODE .or. & + getNodeType(arg)==DOCUMENT_TYPE_NODE .or. & + getNodeType(arg)==NOTATION_NODE .or. & + getNodeType(arg)==ENTITY_NODE) then + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getReadonly(arg)) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + brokenNS = doc%docExtras%brokenNS + doc%docExtras%brokenNS = .true. ! We need to do stupid NS things + xds => getXds(doc) + + if (associated(getParentNode(arg))) then + np => removeChild(getParentNode(arg), arg) + else + np => arg + endif + + if (associated(arg, getOwnerDocument(arg))) return + + thatParent => null() + treeroot => np + + 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) + if (.not.doneAttributes) call setOwnerDocument(this, doc) + case (ATTRIBUTE_NODE) + if (associated(this, arg).or.getSpecified(this)) then + ! We are importing just this attribute node + ! or this was an explicitly specified attribute; either + ! way, we import it as is, and it becomes/remains specified. + call setOwnerDocument(this, doc) + call setSpecified(this, .true.) + else + ! This is an attribute being imported as part of a hierarchy, + ! but its only here by default. Is there a default attribute + ! of this name in the new document? + elem => get_element(xds%element_list, & + getTagName(getOwnerElement(this))) + att => get_attribute_declaration(elem, getName(this)) + if (attribute_has_default(att)) then + ! Create the new default: + if (getParameter(getDomConfig(doc), "namespaces")) then + ! We create a namespaced attribute. Of course, its + ! namespaceURI remains empty for the moment unless we know it ... + if (prefixOfQName(getName(this))=="xml") then + new => createAttributeNS(np, & + "http://www.w3.org/XML/1998/namespace", & + getName(this)) + elseif (getName(this)=="xmlns" & + .or. prefixOfQName(getName(this))=="xmlns") then + new => createAttributeNS(np, & + "http://www.w3.org/2000/xmlns/", & + getName(this)) + else + ! Wait for namespace fixup ... + new => createAttributeNS(np, "", & + getName(this)) + endif + else + new => createAttribute(doc, getName(this)) + endif + call setValue(new, str_vs(att%default)) + call setSpecified(new, .false.) + ! In any case, we dont want to copy the children of this node. + doneChildren = .true. + dead => setAttributeNode(getOwnerElement(this), new) + this => new + call destroyAllNodesRecursively(dead) + endif + ! Otherwise no attribute here, so go back to previous node + dead => this + if (i_tree==0) then + this => getOwnerElement(this) + else + i_tree = i_tree - 1 + this => item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .true. + endif + call removeAttribute(getOwnerElement(dead), getNodeName(dead)) + endif + case (ENTITY_REFERENCE_NODE) + new => createEntityReference(doc, getNodeName(this)) + ! This will automatically populate the entity reference if doc defines it, so no children needed + parent => getParentNode(this) + if (associated(parent)) then + dead => replaceChild(parent, new, this) + this => new + call destroyAllNodesRecursively(dead) + endif + doneChildren = .true. + case (ENTITY_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (DOCUMENT_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (DOCUMENT_TYPE_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (NOTATION_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case default + call setOwnerDocument(this, doc) + end select + + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 + + + + doc%docExtras%brokenNS = brokenNS +! call namespaceFixup(np) + + end function adoptNode + +function getdomConfig(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(DOMConfiguration), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdomConfig", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdomConfig", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%docExtras%domConfig + + end function getdomConfig + +subroutine setdomConfig(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(DOMConfiguration), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setdomConfig", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setdomConfig", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%domConfig => c + + end subroutine setdomConfig + + + + function renameNode(arg, n, namespaceURI, qualifiedName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: n + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: qualifiedName + type(Node), pointer :: np + + type(Node), pointer :: attNode + integer :: i + logical :: brokenNS + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + type(xml_doc_state), pointer :: xds + type(URI), pointer :: URIref + + if (.not.associated(arg).or..not.associated(n)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg)/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(getOwnerDocument(n), target=arg)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="" & + .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & + prefixOfQName(qualifiedName)=="xml") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + URIref => parseURI(namespaceURI) + if (.not.associated(URIref)) then + if (getFoX_checks().or.FoX_INVALID_URI<200) then + call throw_exception(FoX_INVALID_URI, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call destroyURI(URIref) + +! FIXME what if this is called on a Level 1 node +! FIXME what if this is called on a read-only node +! FIXME what if this is called on an attribute whose specified=fals + select case(getNodeType(n)) + case (ELEMENT_NODE, ATTRIBUTE_NODE) + deallocate(n%nodeName) + n%nodeName => vs_str_alloc(qualifiedName) + deallocate(n%elExtras%namespaceURI) + n%elExtras%namespaceURI => vs_str_alloc(namespaceURI) + deallocate(n%elExtras%localName) + n%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) + case default + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + if (getNodeType(n)==ELEMENT_NODE) then + i = 0 + do while (i item(getAttributes(n), i) + if (.not.getSpecified(attNode)) then + attNode => removeAttributeNode(n, attNode) + call destroyNode(attNode) + else + i = i + 1 + endif + enddo + xds => getXds(arg) + elem => get_element(xds%element_list, qualifiedName) + if (associated(elem)) then + do i = 1, get_attlist_size(elem) + att => get_attribute_declaration(elem, i) + if (attribute_has_default(att)) then + ! Since this is a namespaced function, we create a namespaced + ! attribute. Of course, its namespaceURI remains empty + ! for the moment unless we know it ... + if (prefixOfQName(str_vs(att%name))=="xml") then + call setAttributeNS(np, & + "http://www.w3.org/XML/1998/namespace", & + str_vs(att%name), str_vs(att%default)) + elseif (str_vs(att%name)=="xmlns" & + .or. prefixOfQName(str_vs(att%name))=="xmlns") then + call setAttributeNS(np, & + "http://www.w3.org/2000/xmlns/", & + str_vs(att%name), str_vs(att%default)) + else + ! Wait for namespace fixup ... + brokenNS = arg%docExtras%brokenNS + arg%docExtras%brokenNS = .true. + call setAttributeNS(np, "", str_vs(att%name), & + str_vs(att%default)) + arg%docExtras%brokenNS = brokenNS + endif + endif + enddo + endif + endif + + np => n + + end function renameNode + + ! Internal function, not part of API + + function createNamespaceNode(arg, prefix, URI, specified, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: prefix + character(len=*), intent(in) :: URI + logical, intent(in) :: specified + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createNamespaceNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createNamespaceNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, XPATH_NAMESPACE_NODE, "#namespace", URI) + allocate(np%elExtras) + np%elExtras%prefix => vs_str_alloc(prefix) + np%elExtras%namespaceURI => vs_str_alloc(URI) + np%elExtras%specified = specified + + end function createNamespaceNode + + function createEntity(arg, name, publicId, systemId, notationName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + character(len=*), intent(in) :: notationName + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createEntity", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createEntity", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, ENTITY_NODE, name, "") + allocate(np%dtdExtras) + np%dtdExtras%publicId => vs_str_alloc(publicId) + np%dtdExtras%systemId => vs_str_alloc(systemId) + np%dtdExtras%notationName => vs_str_alloc(notationName) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createEntity + + function createNotation(arg, name, publicId, systemId, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createNotation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createNotation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, NOTATION_NODE, name, "") + allocate(np%dtdExtras) + np%dtdExtras%publicId => vs_str_alloc(publicId) + np%dtdExtras%systemId => vs_str_alloc(systemId) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createNotation + + function getXmlVersionEnum(arg, ex)result(n) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "getXmlVersionEnum", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + n = arg%docExtras%xds%xml_version + + end function getXmlVersionEnum + + function getXds(arg, ex)result(xds) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(xml_doc_state), pointer :: xds + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "getXds", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + xds => arg%docExtras%xds + + end function getXds + + +function getGCstate(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getGCstate", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getGCstate", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%docExtras%xds%building + + end function getGCstate + +subroutine setGCstate(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setGCstate", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setGCstate", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%xds%building = c + + end subroutine setGCstate + + +function getliveNodeLists(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getliveNodeLists", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getliveNodeLists", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%docExtras%liveNodeLists + + end function getliveNodeLists + +subroutine setliveNodeLists(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setliveNodeLists", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setliveNodeLists", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%liveNodeLists = c + + end subroutine setliveNodeLists + + + + +! function getName(docType) result(c) See m_dom_common + + function getEntities(arg, ex)result(nnp) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(NamedNodeMap), pointer :: nnp + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getEntities", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getEntities", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + nnp => arg%dtdExtras%entities + end function getEntities + + function getNotations(arg, ex)result(nnp) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(NamedNodeMap), pointer :: nnp + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getNotations", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getNotations", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + nnp => arg%dtdExtras%notations + end function getNotations + + +! function getPublicId(docType) result(c) See m_dom_common + + +! function getSystemId(docType) result(c) See m_dom_common + + pure function getInternalSubset_len(arg, p) result(n) + type(Node), pointer :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (p) then + if (associated(arg%ownerDocument)) then + if (associated(arg%ownerDocument%docExtras%xds%intSubset)) then + n = size(arg%ownerDocument%docExtras%xds%intSubset) + endif + endif + endif + end function getInternalSubset_len + + function getInternalSubset(arg, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getInternalSubset_len(arg, .true.)) :: s +#else + character(len=getInternalSubset_len(arg, associated(arg))) :: s +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getInternalSubset", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getInternalSubset", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(s)>0) then + s = str_vs(arg%ownerDocument%docExtras%xds%intSubset) + else + s = "" + endif + end function getInternalSubset + + + + + pure function gettagName_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==ELEMENT_NODE .or. & + .false.)) then + n = size(np%nodeName) + else + n = 0 + endif + end function gettagName_len +function gettagName(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=gettagName_len(np, .true.)) :: c +#else + character(len=gettagName_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "gettagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ELEMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "gettagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodeName) + + end function gettagName + + + pure function getAttribute_len(arg, p, name) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + character(len=*), intent(in) :: name + integer :: n + + integer :: i + + n = 0 + if (.not.p) return + if (arg%nodeType/=ELEMENT_NODE) return + + do i = 1, arg%elExtras%attributes%length + if (str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==name) then + n = getTextContent_len(arg%elExtras%attributes%nodes(i)%this, .true.) + exit + endif + enddo + + end function getAttribute_len + + function getAttribute(arg, name, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getAttribute_len(arg, .true., name)) :: c +#else + character(len=getAttribute_len(arg, associated(arg), name)) :: c +#endif + + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg) /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c)>0) then + do i = 1, arg%elExtras%attributes%length + if (str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==name) then + c = getTextContent(arg%elExtras%attributes%nodes(i)%this) + exit + endif + enddo + else + c = "" + endif + + end function getAttribute + + + subroutine setAttribute(arg, name, value, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + + type(Node), pointer :: nn, dummy + logical :: quickFix + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodetype(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(name, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(value, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + quickFix = getGCstate(getOwnerDocument(arg)) & + .and. arg%inDocument + + if (quickFix) call setGCstate(getOwnerDocument(arg), .false.) + ! then the created attribute is going straight into the document, + ! so dont faff with hanging-node lists. + + nn => createAttribute(arg%ownerDocument, name) + call setValue(nn, value) + dummy => setNamedItem(getAttributes(arg), nn) + if (associated(dummy)) then + if (getGCstate(getOwnerDocument(arg)).and..not.dummy%inDocument) & + call putNodesInDocument(getOwnerDocument(arg), dummy) + ! ... so that dummy & children are removed from hangingNodes list. + call destroyAllNodesRecursively(dummy) + endif + + if (quickFix) call setGCstate(getOwnerDocument(arg), .true.) + + end subroutine setAttribute + + + subroutine removeAttribute(arg, name, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + type(DOMException) :: ex2 + type(Node), pointer :: dummy + integer :: e + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodetype(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "removeAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%inDocument) & + call setGCstate(getOwnerDocument(arg), .false.) + + dummy => removeNamedItem(getAttributes(arg), name, ex2) + ! removeNamedItem took care of any default attributes + if (inException(ex2)) then + e = getExceptionCode(ex2) + if (e/=NOT_FOUND_ERR) then + if (getFoX_checks().or.e<200) then + call throw_exception(e, "removeAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (.not.arg%inDocument) then + ! dummy was not in the doc, so was on hangingNode list. + ! To remove it from the list: + call putNodesInDocument(arg%ownerDocument, dummy) + endif + call destroyAllNodesRecursively(dummy) + endif + + if (arg%inDocument) & + call setGCstate(arg%ownerDocument, .true.) + + end subroutine removeAttribute + + + function getAttributeNode(arg, name, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + attr => getNamedItem(getAttributes(arg), name) + + end function getAttributeNode + + + function setAttributeNode(arg, newattr, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newattr + type(Node), pointer :: attr + type(Node), pointer :: dummy + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(arg%ownerDocument, newattr%ownerDocument)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(getOwnerElement(newattr), arg)) then + attr => newattr + return + ! Nothing to do, this attribute is already in this element + elseif (associated(getOwnerElement(newattr))) then + if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then + call throw_exception(INUSE_ATTRIBUTE_ERR, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! this checks if attribute exists already + ! It also does any adding/removing of hangingnodes + ! and sets ownerElement appropriately + dummy => setNamedItem(getAttributes(arg), newattr, ex) + attr => dummy + + end function setAttributeNode + + + function removeAttributeNode(arg, oldattr, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: oldattr + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "removeAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(arg, getOwnerElement(oldattr))) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + attr => removeNamedItem(getAttributes(arg), & + getNodeName(oldattr), ex) + + end function removeAttributeNode + + +! function getElementsByTagName - see m_dom_document + + + pure function getAttributesNS_len(arg, p, localname, namespaceURI) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: namespaceURI + integer :: n + + integer :: i + + n = 0 + if (.not.p) return + if (arg%nodeType/=ELEMENT_NODE) return + + do i = 1, arg%elExtras%attributes%length + if ((str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%localName)==localname & + .and. str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) & + .or. (namespaceURI=="".and.str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==localname)) then + n = getTextContent_len(arg%elExtras%attributes%nodes(i)%this, .true.) + exit + endif + enddo + + end function getAttributesNS_len + + function getAttributeNS(arg, namespaceURI, localName, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getAttributesNS_len(arg, .true., localname, namespaceURI)) :: c +#else + character(len=getAttributesNS_len(arg, associated(arg), localname, namespaceURI)) :: c +#endif + + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c)>0) then + do i = 1, arg%elExtras%attributes%length + if ((str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%localName)==localname & + .and. str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) & + .or. (namespaceURI=="".and.str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==localname)) then + c = getTextContent(arg%elExtras%attributes%nodes(i)%this) + exit + endif + enddo + else + c = "" + endif + + end function getAttributeNS + + + subroutine setAttributeNS(arg, namespaceURI, qualifiedname, value, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: qualifiedName + character(len=*), intent(in) :: value + + type(Node), pointer :: nn, dummy + logical :: quickfix + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(qualifiedname, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (.not.arg%ownerDocument%docExtras%brokenNS) then + if (.not.checkQName(qualifiedname, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="" & + .and. namespaceURI=="") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)=="xml" .neqv. & + namespaceURI=="http://www.w3.org/XML/1998/namespace") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/" .neqv. & + (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns")) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + +! FIXME what if namespace is undeclared? Throw an error *only* if FoX_errors is on, otherwise its taken care of by namespace fixup on serialization + + quickFix = getGCstate(getOwnerDocument(arg)) & + .and. arg%inDocument + + if (quickFix) call setGCstate(getOwnerDocument(arg), .false.) + ! then the created attribute is going straight into the document, + ! so dont faff with hanging-node lists. + + nn => createAttributeNS(arg%ownerDocument, namespaceURI, qualifiedname) + call setValue(nn, value) + dummy => setNamedItemNS(getAttributes(arg), nn) + + if (associated(dummy)) then + if (getGCstate(getOwnerDocument(arg)).and..not.dummy%inDocument) & + call putNodesInDocument(getOwnerDocument(arg), dummy) + ! ... so that dummy & children are removed from hangingNodes list. + call destroyAllNodesRecursively(dummy) + endif + + if (quickFix) call setGCstate(getOwnerDocument(arg), .true.) + + end subroutine setAttributeNS + + + subroutine removeAttributeNS(arg, namespaceURI, localName, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + + type(DOMException) :: ex2 + type(Node), pointer :: dummy + integer :: e + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "removeAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%inDocument) & + call setGCstate(getOwnerDocument(arg), .false.) + ! So we dont add the removed nodes to the hanging node list + + dummy => removeNamedItemNS(getAttributes(arg), namespaceURI, localName, ex2) + ! removeNamedItemNS took care of any default attributes + if (inException(ex2)) then + e = getExceptionCode(ex2) + if (e/=NOT_FOUND_ERR) then + if (getFoX_checks().or.e<200) then + call throw_exception(e, "removeAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (.not.arg%inDocument) then + ! dummy was not in the doc, so was already on hangingNode list. + ! To remove it from the list: + call putNodesInDocument(arg%ownerDocument, dummy) + endif + call destroyAllNodesRecursively(dummy) + endif + + if (arg%inDocument) & + call setGCstate(arg%ownerDocument, .true.) + + end subroutine removeAttributeNS + + + function getAttributeNodeNS(arg, namespaceURI, localName, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + attr => null() ! as per specs, if not found + attr => getNamedItemNS(getAttributes(arg), namespaceURI, localname) + end function getAttributeNodeNS + + + function setAttributeNodeNS(arg, newattr, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newattr + type(Node), pointer :: attr + type(Node), pointer :: dummy + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(arg%ownerDocument, newattr%ownerDocument)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(getOwnerElement(newattr), arg)) then + attr => newattr + return + ! Nothing to do, this attribute is already in this element + elseif (associated(getOwnerElement(newattr))) then + if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then + call throw_exception(INUSE_ATTRIBUTE_ERR, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! this checks if attribute exists already + ! It also does any adding/removing of hangingnodes + ! and sets ownerElement appropriately + dummy => setNamedItemNS(getAttributes(arg), newattr, ex) + attr => dummy + + end function setAttributeNodeNS + + + function removeAttributeNodeNS(arg, oldattr, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: oldattr + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "removeAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(arg, getOwnerElement(oldattr))) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + attr => removeNamedItemNS(getAttributes(arg), & + getNamespaceURI(oldattr), getLocalName(oldattr), ex) + + end function removeAttributeNodeNS + + +! function getElementsByTagNameNS - see m_dom_document + + + function hasAttribute(arg, name, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + logical :: p + + integer :: i + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "hasAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "hasAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + p = .false. + do i = 0, getLength(getAttributes(arg)) - 1 + attr => item(getAttributes(arg), i) + if (getNodeName(attr)==name) then + p = .true. + exit + endif + enddo + + end function hasAttribute + + + function hasAttributeNS(arg, namespaceURI, localName, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + logical :: p + + integer :: i + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "hasAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "hasAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + p = .false. + do i = 0, getLength(getAttributes(arg))-1 + attr => item(getAttributes(arg), i) + if (getNamespaceURI(attr)==namespaceURI & + .and. getLocalName(attr)==localName) then + p = .true. + exit + endif + enddo + + end function hasAttributeNS + + subroutine setIdAttribute(arg, name, isId, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + logical, intent(in) :: isId + + type(Node), pointer :: np + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => getAttributeNode(arg, name) + if (associated(np)) then + call setIsId(np, isId) + else + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "setIdAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end subroutine setIdAttribute + + subroutine setIdAttributeNS(arg, namespaceURI, localname, isId, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + logical, intent(in) :: isId + + type(Node), pointer :: np + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => getAttributeNodeNS(arg, namespaceURI, localname) + if (associated(np)) then + call setIsId(np, isId) + else + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "setIdAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end subroutine setIdAttributeNS + + subroutine setIdAttributeNode(arg, idAttr, isId, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: idAttr + logical, intent(in) :: isId + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(arg, getOwnerElement(idAttr))) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "setIdAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + call setIsId(idAttr, isId) + + end subroutine setIdAttributeNode + + + + ! function getName(attribute) result(c) See m_dom_common + +! NB All functions manipulating attributes play with the nodelist +! directly rather than through helper functions. +! This is so that getValue_length can be pure, and the nodeList +! can be explicitly kept up to dat. + +function getspecified(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getspecified", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getspecified", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%elExtras%specified + + end function getspecified + + +subroutine setspecified(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setspecified", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setspecified", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%elExtras%specified = c + + end subroutine setspecified + + +function getisId_DOM(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getisId_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getisId_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%elExtras%isId + + end function getisId_DOM + + +subroutine setisId_DOM(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setisId_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setisId_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%elExtras%isId = c + + end subroutine setisId_DOM + + +function getownerElement(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getownerElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getownerElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%elExtras%ownerElement + + end function getownerElement + + + function getValue_DOM(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getTextContent_len(arg, .true.)) :: c +#else + character(len=getTextContent_len(arg, associated(arg))) :: c +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getValue_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg)/=ATTRIBUTE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getValue_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = getTextContent(arg, ex) + + end function getValue_DOM + + subroutine setValue(arg, value, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: value + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg)/=ATTRIBUTE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + call setTextContent(arg, value, ex) + + end subroutine setValue + + + + pure function isCharData(nodeType) result(p) + integer, intent(in) :: nodeType + logical :: p + + p = (nodeType == TEXT_NODE .or. & + nodeType == COMMENT_NODE .or. & + nodeType == CDATA_SECTION_NODE) + end function isCharData + + + function getLength_characterdata(arg, ex)result(n) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getLength_characterdata", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getLength_characterdata", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + n = size(arg%nodeValue) + + end function getLength_characterdata + + + function subStringData(arg, offset, count, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + integer, intent(in) :: count + character(len=count) :: c + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "subStringData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "subStringData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "subStringData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (offset+count>size(arg%nodeValue)) then + c = str_vs(arg%nodeValue(offset+1:)) + else + c = str_vs(arg%nodeValue(offset+1:offset+count)) + endif + + end function subStringData + + + subroutine appendData(arg, data, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: data + + character, pointer :: tmp(:) + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + tmp => arg%nodeValue + arg%nodeValue => vs_str_alloc(str_vs(tmp)//data) + deallocate(tmp) + + ! We have to do these checks *after* appending data in case offending string + ! spans old & new data + if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! And propagate length upwards ... + if (getNodeType(arg)/=COMMENT_NODE) & + call updateTextContentLength(arg, len(data)) + + end subroutine appendData + + + subroutine insertData(arg, offset, data, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + character(len=*), intent(in) :: data + + character, pointer :: tmp(:) + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0.or.offset>size(arg%nodeValue)) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + tmp => arg%nodeValue + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data//str_vs(tmp(offset+1:))) + deallocate(tmp) + + ! We have to do these checks *after* appending data in case offending string + ! spans old & new data + if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! And propagate length upwards ... + if (getNodeType(arg)/=COMMENT_NODE) & + call updateTextContentLength(arg, len(data)) + + end subroutine insertData + + + subroutine deleteData(arg, offset, count, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + integer, intent(in) :: count + + character, pointer :: tmp(:) + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "deleteData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "deleteData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "deleteData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "deleteData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (offset+count>size(arg%nodeValue)) then + n = size(arg%nodeValue)-offset + else + n = count + endif + + tmp => arg%nodeValue + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//str_vs(tmp(offset+count+1:))) + deallocate(tmp) + + ! And propagate length upwards ... + if (getNodeType(arg)/=COMMENT_NODE) & + call updateTextContentLength(arg, -n) + + end subroutine deleteData + + + subroutine replaceData(arg, offset, count, data, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + integer, intent(in) :: count + character(len=*), intent(in) :: data + + character, pointer :: tmp(:) + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (offset+count>size(arg%nodeValue)) then + n = len(data)-(size(arg%nodeValue)-offset) + else + n = len(data)-count + endif + + tmp => arg%nodeValue + if (offset+count <= size(arg%nodeValue)) then + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data//str_vs(tmp(offset+count+1:))) + else + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data) + endif + deallocate(tmp) + + ! We have to do these checks *after* appending data in case offending string + ! spans old & new data + if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! And propagate length upwards ... + if (getNodeType(arg)/=COMMENT_NODE) & + call updateTextContentLength(arg, n) + + end subroutine replaceData + + + + + pure function getnotationName_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==ENTITY_NODE .or. & + .false.)) then + n = size(np%dtdExtras%notationName) + else + n = 0 + endif + end function getnotationName_len +function getnotationName(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getnotationName_len(np, .true.)) :: c +#else + character(len=getnotationName_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnotationName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getnotationName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%dtdExtras%notationName) + + end function getnotationName + + +!Internally-used getters/setters: + + function getillFormed(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getillFormed", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getillFormed", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%dtdExtras%illFormed + + end function getillFormed + + subroutine setillFormed(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setillFormed", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setillFormed", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%dtdExtras%illFormed = c + + end subroutine setillFormed + + + + pure function getstringValue_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==ENTITY_NODE .or. & + .false.)) then + n = size(np%nodeValue) + else + n = 0 + endif + end function getstringValue_len +function getstringValue(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getstringValue_len(np, .true.)) :: c +#else + character(len=getstringValue_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getstringValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getstringValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodeValue) + + end function getstringValue + + subroutine setstringValue(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*) :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setstringValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setstringValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%nodeValue)) deallocate(np%nodeValue) + np%nodeValue => vs_str_alloc(c) + + end subroutine setstringValue + + + + + + pure function getTarget_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==PROCESSING_INSTRUCTION_NODE .or. & + .false.)) then + n = size(np%nodename) + else + n = 0 + endif + end function getTarget_len +function getTarget(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getTarget_len(np, .true.)) :: c +#else + character(len=getTarget_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getTarget", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=PROCESSING_INSTRUCTION_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getTarget", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodename) + + end function getTarget + + + + + function splitText(arg, offset, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + + type(Node), pointer :: np + + character, pointer :: tmp(:) + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "splitText", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.(arg%nodeType==TEXT_NODE.or.arg%nodeType==CDATA_SECTION_NODE)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "splitText", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "splitText", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0 .or. offset>size(arg%nodeValue)) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "splitText", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + tmp => arg%nodeValue + if (arg%nodeType==TEXT_NODE) then + np => createTextNode(arg%ownerDocument, str_vs(tmp(offset+1:))) + elseif (arg%nodeType==CDATA_SECTION_NODE) then + np => createCdataSection(arg%ownerDocument, str_vs(tmp(offset+1:))) + endif + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))) + deallocate(tmp) + if (associated(arg%parentNode)) then + if (associated(arg%nextSibling)) then + np => insertBefore(arg%parentNode, np, arg%nextSibling) + else + np => appendChild(arg%parentNode, np) + endif + endif + + end function splitText + +function getisElementContentWhitespace(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getisElementContentWhitespace", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=TEXT_NODE .and. & +getNodeType(np)/=CDATA_SECTION_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getisElementContentWhitespace", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%ignorableWhitespace + + end function getisElementContentWhitespace + + + subroutine setIsElementContentWhitespace(np, isElementContentWhitespace, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: isElementContentWhitespace + + integer :: n + + np%ignorableWhitespace = isElementContentWhitespace + + if (isElementContentWhitespace) then + n = -np%textContentLength + else + n = size(np%nodeValue) + endif + + call updateTextContentLength(np, n) + end subroutine setIsElementContentWhitespace + +! function getWholeText +! function replaceWholeText + + + + + pure function getdata_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==TEXT_NODE .or. & + np%nodeType==COMMENT_NODE .or. & + np%nodeType==CDATA_SECTION_NODE .or. & + np%nodeType==PROCESSING_INSTRUCTION_NODE .or. & + .false.)) then + n = size(np%nodeValue) + else + n = 0 + endif + end function getdata_len +function getdata(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getdata_len(np, .true.)) :: c +#else + character(len=getdata_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdata", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=TEXT_NODE .and. & +getNodeType(np)/=COMMENT_NODE .and. & +getNodeType(np)/=CDATA_SECTION_NODE .and. & +getNodeType(np)/=PROCESSING_INSTRUCTION_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdata", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodeValue) + + end function getdata + + + subroutine setData(arg, data, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*) :: data + + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +!NB special case in order to check readonly correctly + if (arg%nodeType==TEXT_NODE .or. & + arg%nodeType==COMMENT_NODE .or. & + arg%nodeType==CDATA_SECTION_NODE .or. & + arg%nodeType==PROCESSING_INSTRUCTION_NODE) then + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + select case (arg%nodeType) + case (CDATA_SECTION_NODE) + if (index(data,"]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (COMMENT_NODE) + if (index(data,"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (PROCESSING_INSTRUCTION_NODE) + if (index(data,"?>")>0) then + if (getFoX_checks().or.FoX_INVALID_PI_DATA<200) then + call throw_exception(FoX_INVALID_PI_DATA, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + end select + + deallocate(arg%nodeValue) + arg%nodeValue => vs_str_alloc(data) + + if (arg%nodeType==TEXT_NODE .or. & + arg%nodeType==CDATA_SECTION_NODE) then + n = len(data) - arg%textContentLength + call updateTextContentLength(arg, n) + endif + + end subroutine setData + + + pure function getname_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==DOCUMENT_TYPE_NODE .or. & + np%nodeType==ATTRIBUTE_NODE .or. & + .false.)) then + n = size(np%nodeName) + else + n = 0 + endif + end function getname_len +function getname(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getname_len(np, .true.)) :: c +#else + character(len=getname_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getname", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & +getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getname", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodeName) + + end function getname + + + + pure function getpublicId_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==DOCUMENT_TYPE_NODE .or. & + np%nodeType==NOTATION_NODE .or. & + np%nodeType==ENTITY_NODE .or. & + .false.)) then + n = size(np%dtdExtras%publicId) + else + n = 0 + endif + end function getpublicId_len +function getpublicId(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getpublicId_len(np, .true.)) :: c +#else + character(len=getpublicId_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getpublicId", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & +getNodeType(np)/=NOTATION_NODE .and. & +getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getpublicId", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%dtdExtras%publicId) + + end function getpublicId + + + + pure function getsystemId_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==DOCUMENT_TYPE_NODE .or. & + np%nodeType==NOTATION_NODE .or. & + np%nodeType==ENTITY_NODE .or. & + .false.)) then + n = size(np%dtdExtras%systemId) + else + n = 0 + endif + end function getsystemId_len +function getsystemId(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getsystemId_len(np, .true.)) :: c +#else + character(len=getsystemId_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getsystemId", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & +getNodeType(np)/=NOTATION_NODE .and. & +getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getsystemId", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%dtdExtras%systemId) + + end function getsystemId + + + + + function getnamespaceNodes(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(NodeList), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnamespaceNodes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ELEMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getnamespaceNodes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%elExtras%namespaceNodes + + end function getnamespaceNodes + + + subroutine appendNSNode(np, prefix, namespaceURI, specified, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*), intent(in) :: prefix + character(len=*), intent(in) :: namespaceURI + logical, intent(in) :: specified + + type(Node), pointer :: ns + type(NodeList), pointer :: nsnodes + integer :: i + logical :: quickFix + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "appendNSNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (np%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "appendNSNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! We never put namespace nodes in the hanging nodes + ! list since they can never be separated from their + ! parent element node, so will always be destroyed alongside it. + quickFix = getGCState(getOwnerDocument(np)) + call setGCState(getOwnerDocument(np), .false.) + nsnodes => getNamespaceNodes(np) + ! If we already have this prefix registered in the list, then remove it + do i = 0, getLength(nsNodes)-1 + ns => item(nsNodes, i) +! Intel 8.1 & 9.1 insist on separate variable here and just below + if (getPrefix(ns)==prefix) then + call setNamespaceURI(ns, namespaceURI) + exit + endif + enddo + if (i==getLength(nsNodes)) then + ns => createNamespaceNode(getOwnerDocument(np), & + prefix, namespaceURI, specified) + call append_nl(nsNodes, ns) + endif + call setGCState(getOwnerDocument(np), quickFix) + + end subroutine appendNSNode + + subroutine normalizeDocument(doc, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + + type(Node), pointer :: this, treeroot, dummy, new, old, nsp + type(DOMConfiguration), pointer :: dc + logical :: doneAttributes, doneChildren + integer :: i_tree, i_children + + type(Node), pointer :: parent, attr + type(NamedNodeMap), pointer :: attrs + type(NodeList), pointer :: nsNodes, nsNodesParent + integer :: i, nsIndex + logical :: merged, ns + + if (.not.associated(doc)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(doc)/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + dc => getDomConfig(doc) + ns = getParameter(dc, "namespaces") + treeroot => doc + + call setGCstate(doc, .false.) + ! switch off the memory management, we are going + ! to destroy all nodes we remove from the tree + ! immediately. + + ! exception object is *not* passed through in any + ! of the DOM calls below. This is because all of + ! these should succeed - if they dont then there + ! is a problem so we need to terminate immediately + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (.not.getReadonly(this)) then + select case (getNodeType(this)) + case (ELEMENT_NODE) + if (ns) then + + ! Clear all current namespace nodes: + nsnodes => getNamespaceNodes(this) + do i = 1, getLength(nsNodes) + call destroyNode(nsNodes%nodes(i)%this) + enddo + deallocate(nsNodes%nodes) + + parent => getParentNode(this) + do while (associated(parent)) + ! Go up (through perhaps multiple entref nodes) + if (getNodeType(parent)==ELEMENT_NODE) exit + parent => getParentNode(parent) + enddo + ! Inherit from parent (or not ...) + if (associated(parent)) then + nsNodesParent => getNamespaceNodes(parent) + allocate(nsNodes%nodes(getLength(nsNodesParent))) + nsNodes%length = getLength(nsNodesParent) + do i = 0, getLength(nsNodes) - 1 + ! separate variable for intel + nsp => item(nsNodesParent, i) + nsNodes%nodes(i+1)%this => & + createNamespaceNode(getOwnerDocument(this), & + getPrefix(nsp), getNamespaceURI(nsp), & + specified=.false.) + enddo + else + allocate(nsNodes%nodes(0)) + nsNodes%length = 0 + endif + + ! Now check for broken NS declarations, and add namespace + ! nodes for all non-broken declarations + attrs => getAttributes(this) + do i = 0, getLength(attrs)-1 + attr => item(attrs, i) + if ((getLocalName(attr)=="xmlns" & + .or.getPrefix(attr)=="xmlns") & + .and.getNamespaceURI(attr)/="http://www.w3.org/2000/xmlns/") then + ! This can only I think happen if we bugger about with setPrefix ... + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then + if (getLocalName(attr)=="xmlns") then + call appendNSNode(this, "", getValue(attr), specified=.true.) + else + call appendNSNode(this, getLocalName(attr), & + getValue(attr), specified=.true.) + endif + endif + enddo + + + if (getNamespaceURI(this)/="") then + ! Is the nsURI of this node bound to its prefix? + ! This will automatically do any necessary replacements ... + if (getPrefix(this)=="") then + if (.not.isDefaultNamespace(this, getNamespaceURI(this))) then + ! We are dealing with the default prefix + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns", getNamespaceURI(this)) + call appendNSNode(this, "", getNamespaceURI(this), specified=.true.) + endif + elseif (lookupNamespaceURI(this, getPrefix(this))/=getNamespaceURI(this)) then + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(this), getNamespaceURI(this)) + call appendNSNode(this, getPrefix(this), getNamespaceURI(this), specified=.true.) + endif + else + ! No (or empty) namespace URI ... + if (getLocalName(this)=="") then + ! DOM level 1 node ... report error + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + else + ! We must declare the elements prefix to have an empty nsURI + if (lookupNamespaceURI(this, getPrefix(this))/="") then + if (getPrefix(this)=="") then + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns", "") + else + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(this), "") + endif + ! and add a namespace node for the empty nsURI + call appendNSNode(this, getPrefix(this), "", specified=.true.) + endif + endif + endif + + do i = 0, getLength(attrs)-1 + ! This loops over the number of attrs present initially, so any we + ! add within this loop will not get checked - but they will only + ! be namespace declarations about which we dont care anyway. + attr => item(attrs, i) + if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then + cycle ! We already worried about it above. + elseif (getNamespaceURI(attr)=="http://www.w3.org/XML/1998/namespace") then + cycle ! We dont have to declare these + elseif (getNamespaceURI(attr)/="") then + ! This is a namespaced attribute + if (getPrefix(attr)=="" & + .or. lookupNamespaceURI(this, getPrefix(attr))/=getNamespaceURI(attr)) then + ! It has an inappropriate prefix + if (lookupPrefix(this, getNamespaceURI(attr))/="") then + ! then an appropriate prefix exists, use it. + call setPrefix(attr, lookupPrefix(this, getNamespaceURI(attr))) + ! FIXME should be "most local" prefix. Make sure lookupPrefix does that. + else + ! No suitable prefix exists, declare one. + if (getPrefix(attr)/="") then + ! Then the current prefix is not in use, its just undeclared. + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(attr), getNamespaceURI(attr)) + call appendNSNode(this, getPrefix(attr), getNamespaceURI(attr), specified=.true.) + else + ! This node has no prefix, but needs one. Make it up. + nsIndex = 1 + do while (lookupNamespaceURI(this, "NS"//nsIndex)/="") + ! FIXME this will exit if the namespace is undeclared *or* if it is declared to be empty. + nsIndex = nsIndex+1 + enddo + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:NS"//nsIndex, getNamespaceURI(attr)) + ! and create namespace node + call appendNSNode(this, "NS"//nsIndex, getNamespaceURI(attr), specified=.true.) + call setPrefix(attr, "NS"//nsIndex) + endif + endif + endif + else + ! attribute has no namespace URI + if (getLocalName(this)=="") then + ! DOM level 1 node ... report error + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + ! otherwise no problem + endif + enddo + + endif + + case (ATTRIBUTE_NODE) + if (getParameter(dc, "entities")) then + ! we dont care about any attribute children, + ! we arent going to do anything + doneChildren = .true. + endif + + case (TEXT_NODE) + ! we may need to reset "this" later on ... + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + merged = .false. + if (getIsElementContentWhitespace(this) & + .and..not.getParameter(dc, "element-content-whitespace")) then + dummy => removeChild(getParentNode(this), this) + call destroy(dummy) + this => old + merged = .true. + endif + if (.not.merged) then + ! We didnt just remove this node. + ! Do we need to normalize? + dummy => getPreviousSibling(this) + if (associated(dummy)) then + if (getNodeType(dummy)==TEXT_NODE) then + call appendData(dummy, getData(this)) + parent => getParentNode(this) + dummy => removeChild(parent, this) + call destroy(dummy) + this => old + endif + endif + endif + + case (CDATA_SECTION_NODE) + if (.not.getParameter(dc, "cdata-sections")) then + ! we may need to reset "this" later on ... + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + merged = .false. + dummy => getPreviousSibling(this) + if (associated(dummy)) then + if (getNodeType(dummy)==TEXT_NODE) then + ! append the data to the previous node & chuck away this node + call appendData(dummy, getData(this)) + dummy => removeChild(getParentNode(this), this) + call destroy(dummy) + this => old + merged =.true. + endif + endif + if (.not.merged) then + ! we didnt merge it so just convert this to a text node + new => createTextNode(doc, getData(this)) + dummy => replaceChild(getParentNode(this), new, this) + call destroy(dummy) + this => new + endif + elseif (.not.getParameter(dc, "split-cdata-sections")) then + ! Actually, on re-reading DOM 3, this is a ridiculous + ! option. Ignoring for now. + endif + + case (ENTITY_REFERENCE_NODE) + if (.not.getParameter(dc, "entities")) then + if (associated(getFirstChild(this))) then + !If this node is not representing an unexpanded entity + ! we will need to reset "this" later on ... + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + ! take each child, and insert it immediately before the current node + do i_children = 0, getLength(getChildNodes(this))-1 + dummy => insertBefore(getParentNode(this), getFirstChild(this), this) + enddo + ! and finally remove the current node + dummy => removeChild(getParentNode(this), this) + call destroy(dummy) + ! and set the "this" pointer back so we go over these again + this => old + endif + endif + + case (COMMENT_NODE) + if (.not.getParameter(dc, "comments")) then + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + dummy => removeChild(getParentNode(this), this) + call destroy(dummy) + this => old + endif + + case (DOCUMENT_TYPE_NODE) + if (getParameter(dc, "canonical-form")) then + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + dummy => removeChild(getParentNode(this), this) + call destroy(this) + this => old + endif + + end select + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + 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 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 normalizeDocument + + recursive subroutine namespaceFixup(this, deep, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: this + logical, intent(in) :: deep + + type(Node), pointer :: parent, child, attr, nsp + type(NamedNodeMap), pointer :: attrs + type(NodeList), pointer :: nsNodes, nsNodesParent + integer :: i, nsIndex + + if (getNodeType(this) /= ELEMENT_NODE & + .and. getNodeType(this) /= ENTITY_REFERENCE_NODE & + .and. getNodeType(this)/=DOCUMENT_FRAGMENT_NODE) then + return + endif + + if (this%nodeType==ELEMENT_NODE) then + + ! Clear all current namespace nodes: + nsnodes => getNamespaceNodes(this) + do i = 1, getLength(nsNodes) + call destroyNode(nsNodes%nodes(i)%this) + enddo + deallocate(nsNodes%nodes) + + parent => getParentNode(this) + do while (associated(parent)) + ! Go up (through perhaps multiple entref nodes) + if (getNodeType(parent)==ELEMENT_NODE) exit + parent => getParentNode(parent) + enddo + ! Inherit from parent (or not ...) + if (associated(parent)) then + nsNodesParent => getNamespaceNodes(parent) + allocate(nsNodes%nodes(getLength(nsNodesParent))) + nsNodes%length = getLength(nsNodesParent) + do i = 0, getLength(nsNodes) - 1 + ! separate variable for intel + nsp => item(nsNodesParent, i) + nsNodes%nodes(i+1)%this => & + createNamespaceNode(getOwnerDocument(this), & + getPrefix(nsp), getNamespaceURI(nsp), & + specified=.false.) + enddo + else + allocate(nsNodes%nodes(0)) + nsNodes%length = 0 + endif + + ! Now check for broken NS declarations, and add namespace + ! nodes for all non-broken declarations + attrs => getAttributes(this) + do i = 0, getLength(attrs)-1 + attr => item(attrs, i) + if ((getLocalName(attr)=="xmlns" & + .or.getPrefix(attr)=="xmlns") & + .and.getNamespaceURI(attr)/="http://www.w3.org/2000/xmlns/") then + ! This can only I think happen if we bugger about with setPrefix ... + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then + if (getLocalName(attr)=="xmlns") then + call appendNSNode(this, "", getValue(attr), specified=.true.) + else + call appendNSNode(this, getLocalName(attr), & + getValue(attr), specified=.true.) + endif + endif + enddo + + + if (getNamespaceURI(this)/="") then + ! Is the nsURI of this node bound to its prefix? + ! This will automatically do any necessary replacements ... + if (getPrefix(this)=="") then + if (.not.isDefaultNamespace(this, getNamespaceURI(this))) then + ! We are dealing with the default prefix + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns", getNamespaceURI(this)) + call appendNSNode(this, "", getNamespaceURI(this), specified=.true.) + endif + elseif (lookupNamespaceURI(this, getPrefix(this))/=getNamespaceURI(this)) then + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(this), getNamespaceURI(this)) + call appendNSNode(this, getPrefix(this), getNamespaceURI(this), specified=.true.) + endif + else + ! No (or empty) namespace URI ... + if (getLocalName(this)=="") then + ! DOM level 1 node ... report error + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + else + ! We must declare the elements prefix to have an empty nsURI + if (lookupNamespaceURI(this, getPrefix(this))/="") then + if (getPrefix(this)=="") then + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns", "") + else + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(this), "") + endif + ! and add a namespace node for the empty nsURI + call appendNSNode(this, getPrefix(this), "", specified=.true.) + endif + endif + endif + + do i = 0, getLength(attrs)-1 + ! This loops over the number of attrs present initially, so any we + ! add within this loop will not get checked - but they will only + ! be namespace declarations about which we dont care anyway. + attr => item(attrs, i) + if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then + cycle ! We already worried about it above. + elseif (getNamespaceURI(attr)=="http://www.w3.org/XML/1998/namespace") then + cycle ! We dont have to declare these + elseif (getNamespaceURI(attr)/="") then + ! This is a namespaced attribute + if (getPrefix(attr)=="" & + .or. lookupNamespaceURI(this, getPrefix(attr))/=getNamespaceURI(attr)) then + ! It has an inappropriate prefix + if (lookupPrefix(this, getNamespaceURI(attr))/="") then + ! then an appropriate prefix exists, use it. + call setPrefix(attr, lookupPrefix(this, getNamespaceURI(attr))) + ! FIXME should be "most local" prefix. Make sure lookupPrefix does that. + else + ! No suitable prefix exists, declare one. + if (getPrefix(attr)/="") then + ! Then the current prefix is not in use, its just undeclared. + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(attr), getNamespaceURI(attr)) + call appendNSNode(this, getPrefix(attr), getNamespaceURI(attr), specified=.true.) + else + ! This node has no prefix, but needs one. Make it up. + nsIndex = 1 + do while (lookupNamespaceURI(this, "NS"//nsIndex)/="") + ! FIXME this will exit if the namespace is undeclared *or* if it is declared to be empty. + nsIndex = nsIndex+1 + enddo + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:NS"//nsIndex, getNamespaceURI(attr)) + ! and create namespace node + call appendNSNode(this, "NS"//nsIndex, getNamespaceURI(attr), specified=.true.) + call setPrefix(attr, "NS"//nsIndex) + endif + endif + endif + else + ! attribute has no namespace URI + if (getLocalName(this)=="") then + ! DOM level 1 node ... report error + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + ! otherwise no problem + endif + enddo + + endif + + if (deep) then + ! And now call this on all appropriate children ... + child => getFirstChild(this) + do while (associated(child)) + call namespaceFixup(child, .true.) + child => getNextSibling(child) + enddo + endif + + end subroutine namespaceFixup + + +end module m_dom_dom diff --git a/src/xml/dom/m_dom_error.F90 b/src/xml/dom/m_dom_error.F90 new file mode 100644 index 000000000..c6fdae418 --- /dev/null +++ b/src/xml/dom/m_dom_error.F90 @@ -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 diff --git a/src/xml/dom/m_dom_extras.F90 b/src/xml/dom/m_dom_extras.F90 new file mode 100644 index 000000000..790561746 --- /dev/null +++ b/src/xml/dom/m_dom_extras.F90 @@ -0,0 +1,2444 @@ +module m_dom_extras + + use fox_m_fsys_realtypes, only: sp, dp + use fox_m_fsys_parse_input, only: rts + + use m_dom_error, only: DOMException, inException, throw_exception, & + FoX_NODE_IS_NULL, FoX_INVALID_NODE + use m_dom_dom, only: Node, ELEMENT_NODE, & + getAttribute, getAttributeNS, getTextContent, getNodeType, getFoX_checks + + implicit none + private + + public :: extractDataContent + public :: extractDataAttribute + public :: extractDataAttributeNS + + interface extractDataContent + module procedure extractDataContentCmplxDpSca + module procedure extractDataContentCmplxDpArr + module procedure extractDataContentCmplxDpMat + module procedure extractDataContentCmplxSpSca + module procedure extractDataContentCmplxSpArr + module procedure extractDataContentCmplxSpMat + module procedure extractDataContentRealDpSca + module procedure extractDataContentRealDpArr + module procedure extractDataContentRealDpMat + module procedure extractDataContentRealSpSca + module procedure extractDataContentRealSpArr + module procedure extractDataContentRealSpMat + module procedure extractDataContentIntSca + module procedure extractDataContentIntArr + module procedure extractDataContentIntMat + module procedure extractDataContentLongSca + module procedure extractDataContentLgSca + module procedure extractDataContentLgArr + module procedure extractDataContentLgMat + module procedure extractDataContentChSca + module procedure extractDataContentChArr + module procedure extractDataContentChMat + + end interface extractDataContent + + interface extractDataAttribute + module procedure extractDataAttributeCmplxDpSca + module procedure extractDataAttributeCmplxDpArr + module procedure extractDataAttributeCmplxDpMat + module procedure extractDataAttributeCmplxSpSca + module procedure extractDataAttributeCmplxSpArr + module procedure extractDataAttributeCmplxSpMat + module procedure extractDataAttributeRealDpSca + module procedure extractDataAttributeRealDpArr + module procedure extractDataAttributeRealDpMat + module procedure extractDataAttributeRealSpSca + module procedure extractDataAttributeRealSpArr + module procedure extractDataAttributeRealSpMat + module procedure extractDataAttributeIntSca + module procedure extractDataAttributeIntArr + module procedure extractDataAttributeIntMat + module procedure extractDataAttributeLongSca + module procedure extractDataAttributeLgSca + module procedure extractDataAttributeLgArr + module procedure extractDataAttributeLgMat + module procedure extractDataAttributeChSca + module procedure extractDataAttributeChArr + module procedure extractDataAttributeChMat + + end interface extractDataAttribute + + interface extractDataAttributeNS + module procedure extractDataAttNSCmplxDpSca + module procedure extractDataAttNSCmplxDpArr + module procedure extractDataAttNSCmplxDpMat + module procedure extractDataAttNSCmplxSpSca + module procedure extractDataAttNSCmplxSpArr + module procedure extractDataAttNSCmplxSpMat + module procedure extractDataAttNSRealDpSca + module procedure extractDataAttNSRealDpArr + module procedure extractDataAttNSRealDpMat + module procedure extractDataAttNSRealSpSca + module procedure extractDataAttNSRealSpArr + module procedure extractDataAttNSRealSpMat + module procedure extractDataAttNSIntSca + module procedure extractDataAttNSIntArr + module procedure extractDataAttNSIntMat + module procedure extractDataAttNSLgSca + module procedure extractDataAttNSLgArr + module procedure extractDataAttNSLgMat + module procedure extractDataAttNSChSca + module procedure extractDataAttNSChArr + module procedure extractDataAttNSChMat + + end interface extractDataAttributeNS + +contains + +subroutine extractDataContentCmplxDpSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(dp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxDpSca + +subroutine extractDataContentCmplxSpSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(sp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxSpSca + +subroutine extractDataContentRealDpSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(dp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealDpSca + +subroutine extractDataContentRealSpSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(sp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealSpSca + +subroutine extractDataContentIntSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentIntSca + +subroutine extractDataContentLongSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer(8), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentLongSca + +subroutine extractDataContentLgSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical, intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentLgSca + +subroutine extractDataContentChSca(arg, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + if (present(ex)) then + call rts(getTextContent(arg, ex), data, separator, csv, num, iostat) + else + call rts(getTextContent(arg), data, separator, csv, num, iostat) + endif + + end subroutine extractDataContentChSca + + +subroutine extractDataContentCmplxDpArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(dp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxDpArr + +subroutine extractDataContentCmplxSpArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(sp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxSpArr + +subroutine extractDataContentRealDpArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(dp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealDpArr + +subroutine extractDataContentRealSpArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(sp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealSpArr + +subroutine extractDataContentIntArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentIntArr + +subroutine extractDataContentLgArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical, dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentLgArr + +subroutine extractDataContentChArr(arg, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), dimension(:), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + if (present(ex)) then + call rts(getTextContent(arg, ex), data, separator, csv, num, iostat) + else + call rts(getTextContent(arg), data, separator, csv, num, iostat) + endif + + end subroutine extractDataContentChArr + + +subroutine extractDataContentCmplxDpMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(dp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxDpMat + +subroutine extractDataContentCmplxSpMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(sp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxSpMat + +subroutine extractDataContentRealDpMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(dp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealDpMat + +subroutine extractDataContentRealSpMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(sp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealSpMat + +subroutine extractDataContentIntMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentIntMat + +subroutine extractDataContentLgMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical, dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentLgMat + +subroutine extractDataContentChMat(arg, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), dimension(:,:), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + if (present(ex)) then + call rts(getTextContent(arg, ex), data, separator, csv, num, iostat) + else + call rts(getTextContent(arg), data, separator, csv, num, iostat) + endif + + end subroutine extractDataContentChMat + + +subroutine extractDataAttributeCmplxDpSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(dp), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxDpSca + +subroutine extractDataAttributeCmplxSpSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(sp), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxSpSca + +subroutine extractDataAttributeRealDpSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(dp), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealDpSca + +subroutine extractDataAttributeRealSpSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(sp), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealSpSca + +subroutine extractDataAttributeIntSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + integer, intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeIntSca + +subroutine extractDataAttributeLongSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + integer(8), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeLongSca + +subroutine extractDataAttributeLgSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeLgSca + +subroutine extractDataAttributeChSca(arg, name, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + character(len=*), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, separator, csv, num, iostat) + else + call rts(getAttribute(arg, name), data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttributeChSca + + +subroutine extractDataAttributeCmplxDpArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(dp), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxDpArr + +subroutine extractDataAttributeCmplxSpArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(sp), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxSpArr + +subroutine extractDataAttributeRealDpArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(dp), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealDpArr + +subroutine extractDataAttributeRealSpArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(sp), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealSpArr + +subroutine extractDataAttributeIntArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + integer, dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeIntArr + +subroutine extractDataAttributeLgArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeLgArr + +subroutine extractDataAttributeChArr(arg, name, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + character(len=*), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, separator, csv, num, iostat) + else + call rts(getAttribute(arg, name), data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttributeChArr + + +subroutine extractDataAttributeCmplxDpMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(dp), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxDpMat + +subroutine extractDataAttributeCmplxSpMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(sp), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxSpMat + +subroutine extractDataAttributeRealDpMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(dp), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealDpMat + +subroutine extractDataAttributeRealSpMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(sp), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealSpMat + +subroutine extractDataAttributeIntMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + integer, dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeIntMat + +subroutine extractDataAttributeLgMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeLgMat + +subroutine extractDataAttributeChMat(arg, name, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + character(len=*), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, separator, csv, num, iostat) + else + call rts(getAttribute(arg, name), data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttributeChMat + + +subroutine extractDataAttNSCmplxDpSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(dp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxDpSca + +subroutine extractDataAttNSCmplxSpSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(sp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxSpSca + +subroutine extractDataAttNSRealDpSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(dp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealDpSca + +subroutine extractDataAttNSRealSpSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(sp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealSpSca + +subroutine extractDataAttNSIntSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + integer, intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSIntSca + +subroutine extractDataAttNSLgSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + logical, intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSLgSca + +subroutine extractDataAttNSChSca(arg, namespaceURI, localName, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + character(len=*), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, separator, csv, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttNSChSca + + +subroutine extractDataAttNSCmplxDpArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(dp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxDpArr + +subroutine extractDataAttNSCmplxSpArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(sp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxSpArr + +subroutine extractDataAttNSRealDpArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(dp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealDpArr + +subroutine extractDataAttNSRealSpArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(sp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealSpArr + +subroutine extractDataAttNSIntArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + integer, dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSIntArr + +subroutine extractDataAttNSLgArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + logical, dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSLgArr + +subroutine extractDataAttNSChArr(arg, namespaceURI, localName, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + character(len=*), dimension(:), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, separator, csv, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttNSChArr + + +subroutine extractDataAttNSCmplxDpMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(dp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxDpMat + +subroutine extractDataAttNSCmplxSpMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(sp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxSpMat + +subroutine extractDataAttNSRealDpMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(dp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealDpMat + +subroutine extractDataAttNSRealSpMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(sp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealSpMat + +subroutine extractDataAttNSIntMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + integer, dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSIntMat + +subroutine extractDataAttNSLgMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + logical, dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSLgMat + +subroutine extractDataAttNSChMat(arg, namespaceURI, localName, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + character(len=*), dimension(:,:), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, separator, csv, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttNSChMat + + + +end module m_dom_extras diff --git a/src/xml/dom/m_dom_parse.F90 b/src/xml/dom/m_dom_parse.F90 new file mode 100644 index 000000000..72e683732 --- /dev/null +++ b/src/xml/dom/m_dom_parse.F90 @@ -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 diff --git a/src/xml/dom/m_dom_utils.F90 b/src/xml/dom/m_dom_utils.F90 new file mode 100644 index 000000000..1234c48ad --- /dev/null +++ b/src/xml/dom/m_dom_utils.F90 @@ -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 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 diff --git a/src/xml/fsys/Makefile b/src/xml/fsys/Makefile new file mode 100644 index 000000000..6e80265b0 --- /dev/null +++ b/src/xml/fsys/Makefile @@ -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 diff --git a/src/xml/fsys/fox_m_fsys_abort_flush.F90 b/src/xml/fsys/fox_m_fsys_abort_flush.F90 new file mode 100644 index 000000000..29af292fc --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_abort_flush.F90 @@ -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, 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 diff --git a/src/xml/fsys/fox_m_fsys_array_str.F90 b/src/xml/fsys/fox_m_fsys_array_str.F90 new file mode 100644 index 000000000..88d565256 --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_array_str.F90 @@ -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 diff --git a/src/xml/fsys/fox_m_fsys_count_parse_input.F90 b/src/xml/fsys/fox_m_fsys_count_parse_input.F90 new file mode 100644 index 000000000..b158d26fa --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_count_parse_input.F90 @@ -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 (ijlen(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 (ijlen(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 (ijlen(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 (ijlen(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 (ijlen(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 (ijlen(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 diff --git a/src/xml/fsys/fox_m_fsys_format.F90 b/src/xml/fsys/fox_m_fsys_format.F90 new file mode 100644 index 000000000..448f44ebd --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_format.F90 @@ -0,0 +1,2250 @@ +module fox_m_fsys_format + +!Note that there are several oddities to this package, +!to get round assorted compiler bugs. + +!All the _matrix_ subroutines should be straight +!call-throughs to the relevant _array_ subroutine, +!but with flattened arrays. (this would allow easy +!generation of all functions up to 7 dimensions) +!but unfortunately that breaks PGI-6.1, and causes +!errors on Pathscale-2.4. + +!The Logical array/matrix functions should be able +!to COUNT their length inline in the specification +!expression, but Pathscale-2.4 gives an error on that. + + use fox_m_fsys_abort_flush, only: pxfflush + use fox_m_fsys_realtypes, only: sp, dp + + implicit none + private + +#ifndef DUMMYLIB + integer, parameter :: sig_sp = digits(1.0_sp)/4 + integer, parameter :: sig_dp = digits(1.0_dp)/4 ! Approximate precision worth outputting of each type. + + character(len=*), parameter :: digit = "0123456789:" + character(len=*), parameter :: hexdigit = "0123456789abcdefABCDEF" +#endif + + interface str +! This is for external use only: str should not be called within this +! file. +! All *_chk subroutines check that the fmt they are passed is valid. + module procedure str_string, str_string_array, str_string_matrix, & + str_integer, str_integer_array, str_integer_matrix, & + str_integer_fmt, str_integer_array_fmt, str_integer_matrix_fmt, & + str_logical, str_logical_array, str_logical_matrix, & + str_real_sp, str_real_sp_fmt_chk, & + str_real_sp_array, str_real_sp_array_fmt_chk, & + str_real_sp_matrix, str_real_sp_matrix_fmt_chk, & + str_real_dp, str_real_dp_fmt_chk, & + str_real_dp_array, str_real_dp_array_fmt_chk, & + str_real_dp_matrix, str_real_dp_matrix_fmt_chk, & + str_complex_sp, str_complex_sp_fmt_chk, & + str_complex_sp_array, str_complex_sp_array_fmt_chk, & + str_complex_sp_matrix, str_complex_sp_matrix_fmt_chk, & + str_complex_dp, str_complex_dp_fmt_chk, & + str_complex_dp_array, str_complex_dp_array_fmt_chk, & + str_complex_dp_matrix, str_complex_dp_matrix_fmt_chk + end interface str + +#ifndef DUMMYLIB + interface safestr +! This is for internal use only - no check is made on the validity of +! any fmt input. + module procedure str_string, str_string_array, str_string_matrix, & + str_integer, str_integer_array, str_integer_matrix, & + str_logical, str_logical_array, str_logical_matrix, & + str_real_sp, str_real_sp_fmt, & + str_real_sp_array, str_real_sp_array_fmt, & + str_real_sp_matrix, str_real_sp_matrix_fmt, & + str_real_dp, str_real_dp_fmt, & + str_real_dp_array, str_real_dp_array_fmt, & + str_real_dp_matrix, str_real_dp_matrix_fmt, & + str_complex_sp, str_complex_sp_fmt, & + str_complex_sp_array, str_complex_sp_array_fmt, & + str_complex_sp_matrix, str_complex_sp_matrix_fmt, & + str_complex_dp, str_complex_dp_fmt, & + str_complex_dp_array, str_complex_dp_array_fmt, & + str_complex_dp_matrix, str_complex_dp_matrix_fmt + end interface safestr + + interface len + module procedure str_integer_len, str_integer_array_len, str_integer_matrix_len, & + str_integer_fmt_len, str_integer_array_fmt_len, str_integer_matrix_fmt_len, & + str_logical_len, str_logical_array_len, str_logical_matrix_len, & + str_real_sp_len, str_real_sp_fmt_len, & + str_real_sp_array_len, str_real_sp_array_fmt_len, & + str_real_sp_matrix_len, str_real_sp_matrix_fmt_len, & + str_real_dp_len, str_real_dp_fmt_len, & + str_real_dp_array_len, str_real_dp_array_fmt_len, & + str_real_dp_matrix_len, str_real_dp_matrix_fmt_len, & + str_complex_sp_len, str_complex_sp_fmt_len, & + str_complex_sp_array_len, str_complex_sp_array_fmt_len, & + str_complex_sp_matrix_len, str_complex_sp_matrix_fmt_len, & + str_complex_dp_len, str_complex_dp_fmt_len, & + str_complex_dp_array_len, str_complex_dp_array_fmt_len, & + str_complex_dp_matrix_len, str_complex_dp_matrix_fmt_len + end interface +#endif + + interface operator(//) + module procedure concat_str_int, concat_int_str, & + concat_str_logical, concat_logical_str, & + concat_real_sp_str, concat_str_real_sp, & + concat_real_dp_str, concat_str_real_dp, & + concat_complex_sp_str, concat_str_complex_sp, & + concat_complex_dp_str, concat_str_complex_dp + end interface + + public :: str + public :: operator(//) + +#ifndef DUMMYLIB + public :: str_to_int_10 + public :: str_to_int_16 +#endif + +contains + +#ifndef DUMMYLIB + ! NB: The len generic module procedure is used in + ! many initialisation statments (to set the + ! length of the output string needed for the + ! converted number). As of the Fortran 2008 + ! spec every specific function belonging to + ! a generic used in this way must be defined + ! in the module before use. This is enforced + ! by at least version 7.4.4 of the Cray + ! Fortran compiler. Hence we put all the *_len + ! functions here at the top of the file. + pure function str_string_array_len(st) result(n) + character(len=*), dimension(:), intent(in) :: st + integer :: n + + integer :: k + + n = size(st) - 1 + do k = 1, size(st) + n = n + len(st(k)) + enddo + + end function str_string_array_len + + pure function str_string_matrix_len(st) result(n) + character(len=*), dimension(:, :), intent(in) :: st + integer :: n + + n = len(st) * size(st) + size(st) - 1 + end function str_string_matrix_len + + pure function str_integer_len(i) result(n) + integer, intent(in) :: i + integer :: n + + n = int(log10(real(max(abs(i),1)))) + 1 + dim(-i,0)/max(abs(i),1) + + end function str_integer_len + + pure function str_integer_base_len(i, b) result(n) + integer, intent(in) :: i, b + integer :: n + + n = int(log10(real(max(abs(i),1)))/log10(real(b))) & + + 1 + dim(-i,0)/max(abs(i),1) + + end function str_integer_base_len + + pure function str_integer_fmt_len(i, fmt) result(n) + integer, intent(in) :: i + character(len=*), intent(in) :: fmt + integer :: n + + select case (len(fmt)) + case(0) + n = 0 + case(1) + if (fmt=="x") then + n = int(log10(real(max(abs(i),1)))/log10(16.0)) + 1 + dim(-i,0)/max(abs(i),1) + elseif (fmt=="d") then + n = int(log10(real(max(abs(i),1)))) + 1 + dim(-i,0)/max(abs(i),1) + else + return + endif + case default + if (fmt(1:1)/='x'.and.fmt(1:1)/='d') then + n = 0 + elseif (verify(fmt(2:), digit)==0) then + n = str_to_int_10(fmt(2:)) + else + n = 0 + endif + end select + + end function str_integer_fmt_len + + pure function str_integer_array_len(ia) result(n) + integer, dimension(:), intent(in) :: ia + integer :: n + + integer :: j + + n = size(ia) - 1 + + do j = 1, size(ia) + n = n + len(ia(j)) + enddo + + end function str_integer_array_len + + pure function str_integer_array_fmt_len(ia, fmt) result(n) + integer, dimension(:), intent(in) :: ia + character(len=*), intent(in) :: fmt + integer :: n + + integer :: j + + n = size(ia) - 1 + + do j = 1, size(ia) + n = n + len(ia(j), fmt) + enddo + + end function str_integer_array_fmt_len + + pure function str_integer_matrix_len(ia) result(n) + integer, dimension(:,:), intent(in) :: ia + integer :: n + + integer :: j, k + + n = size(ia) - 1 + + do k = 1, size(ia, 2) + do j = 1, size(ia, 1) + n = n + len(ia(j, k)) + enddo + enddo + + end function str_integer_matrix_len + + pure function str_integer_matrix_fmt_len(ia, fmt) result(n) + integer, dimension(:,:), intent(in) :: ia + character(len=*), intent(in) :: fmt + integer :: n + + integer :: j, k + + n = size(ia) - 1 + + do k = 1, size(ia, 2) + do j = 1, size(ia, 1) + n = n + len(ia(j, k), fmt) + enddo + enddo + + end function str_integer_matrix_fmt_len + + pure function str_logical_len(l) result (n) + logical, intent(in) :: l + integer :: n + + if (l) then + n = 4 + else + n = 5 + endif + end function str_logical_len + + pure function str_logical_array_len(la) result(n) +! This function should be inlined in the declarations of +! str_logical_array below but PGI and pathscale don't like it. + logical, dimension(:), intent(in) :: la + integer :: n + n = 5*size(la) - 1 + count(.not.la) + end function str_logical_array_len + + pure function str_logical_matrix_len(la) result(n) +! This function should be inlined in the declarations of +! str_logical_matrix below but PGI and pathscale don't like it. + logical, dimension(:,:), intent(in) :: la + integer :: n + n = 5*size(la) - 1 + count(.not.la) + end function str_logical_matrix_len + + pure function str_real_sp_fmt_len(x, fmt) result(n) + real(sp), intent(in) :: x + character(len=*), intent(in) :: fmt + integer :: n + + integer :: dec, sig + integer :: e + + if (.not.checkFmt(fmt)) then + n = 0 + return + endif + + if (x == 0.0_sp) then + e = 1 + else + e = floor(log10(abs(x))) + endif + + if (x < 0.0_sp) then + n = 1 + else + n = 0 + endif + + if (len(fmt) == 0) then + sig = sig_sp + + n = n + sig + 2 + len(e) + ! for the decimal point and the e + + elseif (fmt(1:1) == "s") then + if (len(fmt) > 1) then + sig = str_to_int_10(fmt(2:)) + else + sig = sig_sp + endif + sig = max(sig, 1) + sig = min(sig, digits(1.0_sp)) + + if (sig > 1) n = n + 1 + ! for the decimal point + + n = n + sig + 1 + len(e) + + elseif (fmt(1:1) == "r") then + + if (len(fmt) > 1) then + dec = str_to_int_10(fmt(2:)) + else + dec = sig_sp - e - 1 + endif + dec = min(dec, digits(1.0_sp)-e) + dec = max(dec, 0) + + if (dec > 0) n = n + 1 + if (abs(x) >= 1.0_sp) n = n + 1 + + ! Need to know if there's an overflow .... + if (e+dec+1 > 0) then + if (index(real_sp_str(abs(x), e+dec+1), "!") == 1) & + e = e + 1 + endif + + n = n + abs(e) + dec + + endif + + end function str_real_sp_fmt_len + + pure function str_real_sp_len(x) result(n) + real(sp), intent(in) :: x + integer :: n + + n = len(x, "") + + end function str_real_sp_len + + pure function str_real_sp_array_len(xa) result(n) + real(sp), dimension(:), intent(in) :: xa + integer :: n + + integer :: k + + n = size(xa) - 1 + do k = 1, size(xa) + n = n + len(xa(k), "") + enddo + + end function str_real_sp_array_len + + pure function str_real_sp_array_fmt_len(xa, fmt) result(n) + real(sp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + integer :: n + + integer :: k + + n = size(xa) - 1 + do k = 1, size(xa) + n = n + len(xa(k), fmt) + enddo + + end function str_real_sp_array_fmt_len + + pure function str_real_sp_matrix_fmt_len(xa, fmt) result(n) + real(sp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt + integer :: n + + integer :: j, k + + n = size(xa) - 1 + do k = 1, size(xa, 2) + do j = 1, size(xa, 1) + n = n + len(xa(j,k), fmt) + enddo + enddo + + end function str_real_sp_matrix_fmt_len + + pure function str_real_sp_matrix_len(xa) result(n) + real(sp), dimension(:,:), intent(in) :: xa + integer :: n + + n = len(xa, "") + end function str_real_sp_matrix_len + + pure function str_real_dp_fmt_len(x, fmt) result(n) + real(dp), intent(in) :: x + character(len=*), intent(in) :: fmt + integer :: n + + integer :: dec, sig + integer :: e + + if (.not.checkFmt(fmt)) then + n = 0 + return + endif + + if (x == 0.0_dp) then + e = 1 + else + e = floor(log10(abs(x))) + endif + + if (x < 0.0_dp) then + n = 1 + else + n = 0 + endif + + if (len(fmt) == 0) then + sig = sig_dp + + n = n + sig + 2 + len(e) + ! for the decimal point and the e + + elseif (fmt(1:1) == "s") then + if (len(fmt) > 1) then + sig = str_to_int_10(fmt(2:)) + else + sig = sig_dp + endif + sig = max(sig, 1) + sig = min(sig, digits(1.0_dp)) + + if (sig > 1) n = n + 1 + ! for the decimal point + + n = n + sig + 1 + len(e) + + elseif (fmt(1:1) == "r") then + + if (len(fmt) > 1) then + dec = str_to_int_10(fmt(2:)) + else + dec = sig_dp - e - 1 + endif + dec = min(dec, digits(1.0_dp)-e) + dec = max(dec, 0) + + if (dec > 0) n = n + 1 + if (abs(x) >= 1.0_dp) n = n + 1 + + ! Need to know if there's an overflow .... + if (e+dec+1 > 0) then + if (index(real_dp_str(abs(x), e+dec+1), "!") == 1) & + e = e + 1 + endif + + n = n + abs(e) + dec + + endif + + end function str_real_dp_fmt_len + + pure function str_real_dp_len(x) result(n) + real(dp), intent(in) :: x + integer :: n + + n = len(x, "") + + end function str_real_dp_len + + pure function str_real_dp_array_len(xa) result(n) + real(dp), dimension(:), intent(in) :: xa + integer :: n + + integer :: k + + n = size(xa) - 1 + do k = 1, size(xa) + n = n + len(xa(k), "") + enddo + + end function str_real_dp_array_len + + pure function str_real_dp_array_fmt_len(xa, fmt) result(n) + real(dp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + integer :: n + + integer :: k + + n = size(xa) - 1 + do k = 1, size(xa) + n = n + len(xa(k), fmt) + enddo + + end function str_real_dp_array_fmt_len + + pure function str_real_dp_matrix_fmt_len(xa, fmt) result(n) + real(dp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt + integer :: n + + integer :: j, k + + n = size(xa) - 1 + do k = 1, size(xa, 2) + do j = 1, size(xa, 1) + n = n + len(xa(j,k), fmt) + enddo + enddo + + end function str_real_dp_matrix_fmt_len + + pure function str_real_dp_matrix_len(xa) result(n) + real(dp), dimension(:,:), intent(in) :: xa + integer :: n + + n = len(xa, "") + end function str_real_dp_matrix_len + + pure function str_complex_sp_fmt_len(c, fmt) result(n) + complex(sp), intent(in) :: c + character(len=*), intent(in) :: fmt + integer :: n + + real(sp) :: re, im + re = real(c) + im = aimag(c) + + n = len(re, fmt) + len(im, fmt) + 6 + end function str_complex_sp_fmt_len + + pure function str_complex_sp_len(c) result(n) + complex(sp), intent(in) :: c + integer :: n + + n = len(c, "") + end function str_complex_sp_len + + pure function str_complex_sp_array_fmt_len(ca, fmt) result(n) + complex(sp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt + integer :: n + + integer :: i + + n = size(ca) - 1 + do i = 1, size(ca) + n = n + len(ca(i), fmt) + enddo + end function str_complex_sp_array_fmt_len + + pure function str_complex_sp_array_len(ca) result(n) + complex(sp), dimension(:), intent(in) :: ca + integer :: n + + n = len(ca, "") + end function str_complex_sp_array_len + + pure function str_complex_sp_matrix_fmt_len(ca, fmt) result(n) + complex(sp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt + integer :: n + + integer :: i, j + + n = size(ca) - 1 + do i = 1, size(ca, 1) + do j = 1, size(ca, 2) + n = n + len(ca(i, j), fmt) + enddo + enddo + end function str_complex_sp_matrix_fmt_len + + pure function str_complex_sp_matrix_len(ca) result(n) + complex(sp), dimension(:, :), intent(in) :: ca + integer :: n + + n = len(ca, "") + end function str_complex_sp_matrix_len + + pure function str_complex_dp_fmt_len(c, fmt) result(n) + complex(dp), intent(in) :: c + character(len=*), intent(in) :: fmt + integer :: n + + real(dp) :: re, im + re = real(c) + im = aimag(c) + + n = len(re, fmt) + len(im, fmt) + 6 + end function str_complex_dp_fmt_len + + pure function str_complex_dp_len(c) result(n) + complex(dp), intent(in) :: c + integer :: n + + n = len(c, "") + end function str_complex_dp_len + + pure function str_complex_dp_array_fmt_len(ca, fmt) result(n) + complex(dp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt + integer :: n + + integer :: i + + n = size(ca) - 1 + do i = 1, size(ca) + n = n + len(ca(i), fmt) + enddo + end function str_complex_dp_array_fmt_len + + pure function str_complex_dp_array_len(ca) result(n) + complex(dp), dimension(:), intent(in) :: ca + integer :: n + + n = len(ca, "") + end function str_complex_dp_array_len + + pure function str_complex_dp_matrix_fmt_len(ca, fmt) result(n) + complex(dp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt + integer :: n + + integer :: i, j + + n = size(ca) - 1 + do i = 1, size(ca, 1) + do j = 1, size(ca, 2) + n = n + len(ca(i, j), fmt) + enddo + enddo + end function str_complex_dp_matrix_fmt_len + + pure function str_complex_dp_matrix_len(ca) result(n) + complex(dp), dimension(:, :), intent(in) :: ca + integer :: n + + n = len(ca, "") + end function str_complex_dp_matrix_len +#endif + +#ifndef DUMMYLIB + subroutine FoX_error(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 + + write(0,'(a)') 'ERROR(FoX)' + write(0,'(a)') msg + call pxfflush(0) + + stop + + end subroutine FoX_error + + + pure function str_to_int_10(str) result(n) + ! Takes a string containing digits, and returns + ! the integer representable by those digits. + ! Does not deal with negative numbers, and + ! presumes that the number is representable + ! in a default integer + ! Error is flagged by returning -1 + character(len=*), intent(in) :: str + integer :: n + + integer :: max_power, i, j + + if (verify(str, digit) > 0) then + n = -1 + return + endif + + max_power = len(str) - 1 + + n = 0 + do i = 0, max_power + j = max_power - i + 1 + n = n + (index(digit, str(j:j)) - 1) * 10**i + enddo + + end function str_to_int_10 + + pure function str_to_int_16(str) result(n) + ! Takes a string containing hexadecimal digits, and returns + ! the integer representable by those digits. + ! Does not deal with negative numbers, and + ! presumes that the number is representable + ! in a default integer + ! Error is flagged by returning -1 + character(len=*), intent(in) :: str + integer :: n + + character(len=len(str)) :: str_l + integer :: max_power, i, j + + if (verify(str, hexdigit) == 0) then + str_l = to_lower(str) + else + n = -1 + return + endif + + max_power = len(str) - 1 + + n = 0 + do i = 0, max_power + j = max_power - i + 1 + n = n + (index(hexdigit, str_l(j:j)) - 1) * 16**i + enddo + + contains + pure function to_lower(s) result(s2) + character(len=*), intent(in) :: s + character(len=len(s)) :: s2 + character(len=*), parameter :: hex = "abcdef" + integer :: j, k + do j = 1, len(s) + k = index('ABCDEF', s(j:j)) + if (k > 0) then + s2(j:j) = hex(k:k) + else + s2(j:j) = s(j:j) + endif + enddo + end function to_lower + + end function str_to_int_16 +#endif + + pure function str_string(st) result(s) + character(len=*), intent(in) :: st +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(st)) :: s + s = st +#endif + end function str_string + + pure function str_string_array(st, delimiter) result(s) + character(len=*), dimension(:), intent(in) :: st + character(len=1), intent(in), optional :: delimiter +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=str_string_array_len(st)) :: s + + integer :: k, n + character(len=1) :: d + + if (present(delimiter)) then + d = delimiter + else + d = " " + endif + + n = 1 + do k = 1, size(st) - 1 + s(n:n+len(st(k))) = st(k)//d + n = n + len(st(k)) + 1 + enddo + s(n:) = st(k) +#endif + end function str_string_array + + pure function str_string_matrix(st, delimiter) result(s) + character(len=*), dimension(:, :), intent(in) :: st + character(len=1), intent(in), optional :: delimiter +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=str_string_matrix_len(st)) :: s + + integer :: j, k, n + character(len=1) :: d + + if (present(delimiter)) then + d = delimiter + else + d = " " + endif + + s(1:len(st)) = st(1,1) + n = len(st) + 1 + do j = 2, size(st, 1) + s(n:n+len(st)) = d//st(j,1) + n = n + len(st) + 1 + enddo + do k = 2, size(st, 2) + do j = 1, size(st, 1) + s(n:n+len(st(j,k))) = d//st(j,k) + n = n + len(st) + 1 + enddo + enddo +#endif + end function str_string_matrix + + pure function str_integer(i) result(s) + integer, intent(in) :: i +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=str_integer_len(i)) :: s + + integer :: b, ii, j, k, n + + b = 10 + + if (i < 0) then + s(1:1) = "-" + n = 2 + else + n = 1 + endif + ii = abs(i) + do k = len(s) - n, 0, -1 + j = ii/(b**k) + ii = ii - j*(b**k) + s(n:n) = digit(j+1:j+1) + n = n + 1 + enddo +#endif + end function str_integer + + pure function str_integer_fmt(i, fmt) result(s) + integer, intent(in) :: i + character(len=*), intent(in):: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=str_integer_fmt_len(i, fmt)) :: s + + character :: f + integer :: b, ii, j, k, n, ls + + if (len(fmt)>0) then + if (fmt(1:1)=="d") then + f = 'd' + b = 10 + elseif (fmt(1:1)=="x") then + f = 'x' + b = 16 + else + ! Undefined outcome + s = "" + return + endif + else + ! Undefined outcome + s = "" + return + endif + + ls = str_integer_base_len(i, b) + n = len(s) - ls + 1 + + if (i < 0) then + if (n>0) s(:n) = "-"//repeat("0", n-1) + n = n + 1 + else + if (n>1) s(:n) = repeat("0", n) + endif + + ii = abs(i) + do k = 1, -n + 1 + j = ii/(b**k) + ii = ii - j*(b**k) + n = n + 1 + enddo + do k = len(s) - n, 0, -1 + j = ii/(b**k) + ii = ii - j*(b**k) + s(n:n) = hexdigit(j+1:j+1) + n = n + 1 + enddo +#endif + end function str_integer_fmt + + pure function str_integer_array(ia) result(s) + integer, dimension(:), intent(in) :: ia +#ifdef DUMMYLIB + character(len=1) :: s +#else + character(len=len(ia, "d")) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(ia) - 1 + j = len(ia(k)) + s(n:n+j) = str(ia(k))//" " + n = n + j + 1 + enddo + s(n:) = str(ia(k)) +#endif + end function str_integer_array + + + function str_integer_array_fmt(ia, fmt) result(s) + integer, dimension(:), intent(in) :: ia + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ia, fmt)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(ia) - 1 + j = len(ia(k), fmt) + s(n:n+j) = str(ia(k), fmt)//" " + n = n + j + 1 + enddo + s(n:) = str(ia(k), fmt) +#endif + end function str_integer_array_fmt + + pure function str_integer_matrix(ia) result(s) + integer, dimension(:,:), intent(in) :: ia +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ia, "d")) :: s + + integer :: j, k, n + + s(:len(ia(1,1))) = str(ia(1,1)) + n = len(ia(1,1)) + 1 + do j = 2, size(ia, 1) + s(n:n+len(ia(j,1))) = " "//str(ia(j,1)) + n = n + len(ia(j,1)) + 1 + enddo + do k = 2, size(ia, 2) + do j = 1, size(ia, 1) + s(n:n+len(ia(j,k))) = " "//str(ia(j,k)) + n = n + len(ia(j,k)) + 1 + enddo + enddo +#endif + end function str_integer_matrix + + + pure function str_integer_matrix_fmt(ia, fmt) result(s) + integer, dimension(:,:), intent(in) :: ia + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ia, fmt)) :: s + + integer :: j, k, n + + s(:len(ia(1,1), fmt)) = str(ia(1,1), fmt) + n = len(ia(1,1), fmt) + 1 + do j = 2, size(ia, 1) + s(n:n+len(ia(j,1), fmt)) = " "//str(ia(j,1), fmt) + n = n + len(ia(j,1), fmt) + 1 + enddo + do k = 2, size(ia, 2) + do j = 1, size(ia, 1) + s(n:n+len(ia(j,k), fmt)) = " "//str(ia(j,k), fmt) + n = n + len(ia(j,k), fmt) + 1 + enddo + enddo +#endif + end function str_integer_matrix_fmt + + pure function str_logical(l) result(s) + logical, intent(in) :: l +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else +! Pathscale 2.5 gets it wrong if we use merge here +! character(len=merge(4,5,l)) :: s +! And g95 (sep2007) cant resolve the generic here + character(len=str_logical_len(l)) :: s + + if (l) then + s="true" + else + s="false" + endif +#endif + end function str_logical + + pure function str_logical_array(la) result(s) + logical, dimension(:), intent(in) :: la +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(la)) :: s + + integer :: k, n + + n = 1 + do k = 1, size(la) - 1 + if (la(k)) then + s(n:n+3) = "true" + n = n + 5 + else + s(n:n+4) = "false" + n = n + 6 + endif + s(n-1:n-1) = " " + enddo + if (la(k)) then + s(n:) = "true" + else + s(n:) = "false" + endif +#endif + end function str_logical_array + + pure function str_logical_matrix(la) result(s) + logical, dimension(:,:), intent(in) :: la +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(la)) :: s + + integer :: j, k, n + + if (la(1,1)) then + s(:4) = "true" + n = 5 + else + s(:5) = "false" + n = 6 + endif + do j = 2, size(la, 1) + s(n:n) = " " + if (la(j,1)) then + s(n+1:n+4) = "true" + n = n + 5 + else + s(n+1:n+5) = "false" + n = n + 6 + endif + enddo + do k = 2, size(la, 2) + do j = 1, size(la, 1) + s(n:n) = " " + if (la(j,k)) then + s(n+1:n+4) = "true" + n = n + 5 + else + s(n+1:n+5) = "false" + n = n + 6 + endif + enddo + enddo +#endif + end function str_logical_matrix + +#ifndef DUMMYLIB + ! In order to convert real numbers to strings, we need to + ! perform an internal write - but how long will the + ! resultant string be? We don't know & there is no way + ! to discover for an arbitrary format. Therefore, + ! (if we have the capability; f95 or better) + ! we assume it will be less than 100 characters, write + ! it to a string of that length, then remove leading & + ! trailing whitespace. (this means that if the specified + ! format includes whitespace, this will be lost.) + ! + ! If we are working with an F90-only compiler, then + ! we cannot do this trick - the output string will + ! always be 100 chars in length, though we will remove + ! leading whitespace. + + + ! The standard Fortran format functions do not give us + ! enough control, so we write our own real number formatting + ! routines here. For each real type, we optionally take a + ! format like so: + ! "r" which will produce output without an exponent, + ! and digits after the decimal point. + ! or + ! "s": which implies scientific notation, with an + ! exponent, with significant figures. + ! If the integer is absent, then the precision will be + ! half of the number of significant figures available + ! for that real type. + ! The absence of a format implies scientific notation, with + ! the default precision. + + ! These routines are fairly imperfect - they are inaccurate for + ! the lower-end bits of the number, since they work by simple + ! multiplications by 10. + ! Also they will probably be orders of magnitude slower than library IO. + ! Ideally they'd be rewritten to convert from teh native format by + ! bit-twidding. Not sure how to do that portably though. + + ! The format specification could be done more nicely - but unfortunately + ! not in F95 due to *stupid* restrictions on specification expressions. + + ! And I wouldn't have to invent my own format specification if Fortran + ! had a proper IO library anyway. + +!FIXME Signed zero is not handled correctly; don't quite understand why. +!FIXME too much duplication between sp & dp, we should m4. + + pure function real_sp_str(x, sig) result(s) + real(sp), intent(in) :: x + integer, intent(in) :: sig + character(len=sig) :: s + ! make a string of numbers sig long of x. + integer :: e, i, j, k, n + real(sp) :: x_ + + if (sig < 1) then + s ="" + return + endif + + if (x == 0.0_sp) then + e = 1 + else + e = floor(log10(abs(x))) + endif + x_ = abs(x) + ! Have to do this next in a loop rather than just exponentiating in + ! order to avoid under/over-flow. + do i = 1, abs(e) + ! Have to multiply by 10^-e rather than divide by 10^e + ! to avoid rounding errors. + x_ = x_ * (10.0_sp**(-abs(e)/e)) + enddo + n = 1 + do k = sig - 2, 0, -1 + ! This baroque way of taking int() ensures the optimizer + ! stores it in j without keeping a different value in cache. + j = iachar(digit(int(x_)+1:int(x_)+1)) - 48 + if (j==10) then + ! This can happen if, on the previous cycle, int(x_) in + ! the line above gave a result approx. 1.0 less than + ! expected. + ! In this case we want to quit the cycle & just get 999... to the end + s(n:) = repeat("9", sig - n + 1) + return + endif + s(n:n) = digit(j+1:j+1) + n = n + 1 + x_ = (x_ - j) * 10.0_sp + enddo + j = nint(x_) + if (j == 10) then + ! Now round ... + s(n:n) = "9" + ! Are they all 9's? + i = verify(s, "9", .true.) + if (i == 0) then + s(1:1) = "!" + ! overflow + return + endif + j = index(digit, s(i:i)) + s(i:i) = digit(j+1:j+1) + s(i+1:) = repeat("0", sig - i + 1) + else + s(n:n) = digit(j+1:j+1) + endif + + end function real_sp_str + +#endif + + function str_real_sp_fmt_chk(x, fmt) result(s) + real(sp), intent(in) :: x + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(x, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(x, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_real_sp_fmt_chk + +#ifndef DUMMYLIB + pure function str_real_sp_fmt(x, fmt) result(s) + real(sp), intent(in) :: x + character(len=*), intent(in) :: fmt + character(len=len(x, fmt)) :: s + + integer :: sig, dec + integer :: e, n + character(len=len(x, fmt)) :: num !this will always be enough memory. + + if (x == 0.0_sp) then + e = 0 + else + e = floor(log10(abs(x))) + endif + + if (x < 0.0_sp) then + s(1:1) = "-" + n = 2 + else + n = 1 + endif + + if (len(fmt) == 0) then + + sig = sig_sp + + num = real_sp_str(abs(x), sig) + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (sig == 1) then + s(n:n) = num + n = n + 1 + else + s(n:n+1) = num(1:1)//"." + s(n+2:n+sig) = num(2:) + n = n + sig + 1 + endif + + s(n:n) = "e" + s(n+1:) = str(e) + + elseif (fmt(1:1) == "s") then + + if (len(fmt) > 1) then + sig = str_to_int_10(fmt(2:)) + else + sig = sig_sp + endif + sig = max(sig, 1) + sig = min(sig, digits(1.0_sp)) + + num = real_sp_str(abs(x), sig) + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (sig == 1) then + s(n:n) = num + n = n + 1 + else + s(n:n+1) = num(1:1)//"." + s(n+2:n+sig) = num(2:) + n = n + sig + 1 + endif + + s(n:n) = "e" + s(n+1:) = str(e) + + elseif (fmt(1:1) == "r") then + + if (len(fmt) > 1) then + dec = str_to_int_10(fmt(2:)) + else + dec = sig_sp - e - 1 + endif + dec = min(dec, digits(1.0_sp)-e-1) + dec = max(dec, 0) + + if (e+dec+1 > 0) then + num = real_sp_str(abs(x), e+dec+1) + else + num = "" + endif + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (abs(x) >= 1.0_sp) then + s(n:n+e) = num(:e+1) + n = n + e + 1 + if (dec > 0) then + s(n:n) = "." + n = n + 1 + s(n:) = num(e+2:) + endif + else + s(n:n) = "0" + if (dec > 0) then + s(n+1:n+1) = "." + n = n + 2 + if (dec < -e-1) then + s(n:) = repeat("0", dec) + else + s(n:n-e-2) = repeat("0", max(-e-1,0)) + n = n - min(e,-1) - 1 + if (n <= len(s)) then + s(n:) = num + endif + endif + endif + endif + + endif + + end function str_real_sp_fmt +#endif + + pure function str_real_sp(x) result(s) + real(sp), intent(in) :: x +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(x)) :: s + + s = safestr(x, "") +#endif + end function str_real_sp + + pure function str_real_sp_array(xa) result(s) + real(sp), dimension(:), intent(in) :: xa +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(xa) - 1 + j = len(xa(k), "") + s(n:n+j) = safestr(xa(k), "")//" " + n = n + j + 1 + enddo + s(n:) = safestr(xa(k), "") +#endif + end function str_real_sp_array + +#ifndef DUMMYLIB + pure function str_real_sp_array_fmt(xa, fmt) result(s) + real(sp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + character(len=len(xa, fmt)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(xa) - 1 + j = len(xa(k), fmt) + s(n:n+j) = safestr(xa(k), fmt)//" " + n = n + j + 1 + enddo + s(n:) = safestr(xa(k), fmt) + + end function str_real_sp_array_fmt +#endif + + function str_real_sp_array_fmt_chk(xa, fmt) result(s) + real(sp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(xa, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_real_sp_array_fmt_chk + +#ifndef DUMMYLIB + pure function str_real_sp_matrix_fmt(xa, fmt) result(s) + real(sp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt + character(len=len(xa,fmt)) :: s + + integer :: i, j, k, n + + i = len(xa(1,1), fmt) + s(:i) = safestr(xa(1,1), fmt) + n = i + 1 + do j = 2, size(xa, 1) + i = len(xa(j,1), fmt) + s(n:n+i) = " "//safestr(xa(j,1), fmt) + n = n + i + 1 + enddo + do k = 2, size(xa, 2) + do j = 1, size(xa, 1) + i = len(xa(j,k), fmt) + s(n:n+i) = " "//safestr(xa(j,k), fmt) + n = n + i + 1 + enddo + enddo + + end function str_real_sp_matrix_fmt +#endif + + function str_real_sp_matrix_fmt_chk(xa, fmt) result(s) + real(sp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa,fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(xa, fmt) + else + call FoX_error("Invalid format: "//fmt) + end if +#endif + end function str_real_sp_matrix_fmt_chk + + pure function str_real_sp_matrix(xa) result(s) + real(sp), dimension(:,:), intent(in) :: xa +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa)) :: s + + s = safestr(xa, "") +#endif + end function str_real_sp_matrix + +#ifndef DUMMYLIB + pure function real_dp_str(x, sig) result(s) + real(dp), intent(in) :: x + integer, intent(in) :: sig + character(len=sig) :: s + ! make a string of numbers sig long of x. + integer :: e, i, j, k, n + real(dp) :: x_ + + if (sig < 1) then + s ="" + return + endif + + if (x == 0.0_dp) then + e = 1 + else + e = floor(log10(abs(x))) + endif + x_ = abs(x) + ! Have to do this next in a loop rather than just exponentiating in + ! order to avoid under/over-flow. + do i = 1, abs(e) + ! Have to multiply by 10^-e rather than divide by 10^e + ! to avoid rounding errors. + x_ = x_ * (10.0_dp**(-abs(e)/e)) + enddo + n = 1 + do k = sig - 2, 0, -1 + ! This baroque way of taking int() ensures the optimizer definitely + ! stores it in j without keeping a different value in cache. + j = iachar(digit(int(x_)+1:int(x_)+1)) - 48 + if (j==10) then + ! This can happen if, on the previous cycle, int(x_) in + ! the line above gave a result almost exactly 1.0 less than + ! expected - but FP arithmetic is not consistent. + ! In this case we want to quit the cycle & just get 999... to the end + s(n:) = repeat("9", sig - n + 1) + return + endif + s(n:n) = digit(j+1:j+1) + n = n + 1 + x_ = (x_ - j) * 10.0_dp + enddo + j = nint(x_) + if (j == 10) then + ! Now round ... + s(n:n) = "9" + i = verify(s, "9", .true.) + if (i == 0) then + s(1:1) = "!" + !overflow + return + endif + j = index(digit, s(i:i)) + s(i:i) = digit(j+1:j+1) + s(i+1:) = repeat("0", sig - i + 1) + else + s(n:n) = digit(j+1:j+1) + endif + + end function real_dp_str + + +#endif + + function str_real_dp_fmt_chk(x, fmt) result(s) + real(dp), intent(in) :: x + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(x, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(x, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_real_dp_fmt_chk + +#ifndef DUMMYLIB + pure function str_real_dp_fmt(x, fmt) result(s) + real(dp), intent(in) :: x + character(len=*), intent(in) :: fmt + character(len=len(x, fmt)) :: s + + integer :: sig, dec + integer :: e, n + character(len=len(x, fmt)) :: num !this will always be enough memory. + + if (x == 0.0_dp) then + e = 0 + else + e = floor(log10(abs(x))) + endif + + if (x < 0.0_dp) then + s(1:1) = "-" + n = 2 + else + n = 1 + endif + + if (len(fmt) == 0) then + + sig = sig_dp + + num = real_dp_str(abs(x), sig) + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (sig == 1) then + s(n:n) = num + n = n + 1 + else + s(n:n+1) = num(1:1)//"." + s(n+2:n+sig) = num(2:) + n = n + sig + 1 + endif + + s(n:n) = "e" + s(n+1:) = safestr(e) + + elseif (fmt(1:1) == "s") then + + if (len(fmt) > 1) then + sig = str_to_int_10(fmt(2:)) + else + sig = sig_dp + endif + sig = max(sig, 1) + sig = min(sig, digits(1.0_dp)) + + num = real_dp_str(abs(x), sig) + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (sig == 1) then + s(n:n) = num + n = n + 1 + else + s(n:n+1) = num(1:1)//"." + s(n+2:n+sig) = num(2:) + n = n + sig + 1 + endif + + s(n:n) = "e" + s(n+1:) = safestr(e) + + elseif (fmt(1:1) == "r") then + + if (len(fmt) > 1) then + dec = str_to_int_10(fmt(2:)) + else + dec = sig_dp - e - 1 + endif + dec = min(dec, digits(1.0_dp)-e-1) + dec = max(dec, 0) + + if (e+dec+1 > 0) then + num = real_dp_str(abs(x), e+dec+1) + else + num = "" + endif + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (abs(x) >= 1.0_dp) then + s(n:n+e) = num(:e+1) + n = n + e + 1 + if (dec > 0) then + s(n:n) = "." + n = n + 1 + s(n:) = num(e+2:) + endif + else + s(n:n) = "0" + if (dec > 0) then + s(n+1:n+1) = "." + n = n + 2 + if (dec < -e-1) then + s(n:) = repeat("0", dec) + else + s(n:n-e-2) = repeat("0", max(-e-1,0)) + n = n - min(e,-1) - 1 + if (n <= len(s)) then + s(n:) = num + endif + endif + endif + endif + + endif + + end function str_real_dp_fmt + +#endif + + pure function str_real_dp(x) result(s) + real(dp), intent(in) :: x +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(x)) :: s + + s = safestr(x, "") +#endif + end function str_real_dp + + pure function str_real_dp_array(xa) result(s) + real(dp), dimension(:), intent(in) :: xa +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(xa) - 1 + j = len(xa(k), "") + s(n:n+j) = safestr(xa(k), "")//" " + n = n + j + 1 + enddo + s(n:) = safestr(xa(k)) +#endif + end function str_real_dp_array + +#ifndef DUMMYLIB + pure function str_real_dp_array_fmt(xa, fmt) result(s) + real(dp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + character(len=len(xa, fmt)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(xa) - 1 + j = len(xa(k), fmt) + s(n:n+j) = safestr(xa(k), fmt)//" " + n = n + j + 1 + enddo + s(n:) = safestr(xa(k), fmt) + + end function str_real_dp_array_fmt +#endif + + function str_real_dp_array_fmt_chk(xa, fmt) result(s) + real(dp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(xa, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_real_dp_array_fmt_chk + +#ifndef DUMMYLIB + function str_real_dp_matrix_fmt(xa, fmt) result(s) + real(dp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt + character(len=len(xa,fmt)) :: s + + integer :: i, j, k, n + + i = len(xa(1,1), fmt) + s(:i) = safestr(xa(1,1), fmt) + n = i + 1 + do j = 2, size(xa, 1) + i = len(xa(j,1), fmt) + s(n:n+i) = " "//safestr(xa(j,1), fmt) + n = n + i + 1 + enddo + do k = 2, size(xa, 2) + do j = 1, size(xa, 1) + i = len(xa(j,k), fmt) + s(n:n+i) = " "//safestr(xa(j,k), fmt) + n = n + i + 1 + enddo + enddo + + end function str_real_dp_matrix_fmt +#endif + + function str_real_dp_matrix_fmt_chk(xa, fmt) result(s) + real(dp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa,fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(xa, fmt) + else + call FoX_error("Invalid format: "//fmt) + end if +#endif + end function str_real_dp_matrix_fmt_chk + + function str_real_dp_matrix(xa) result(s) + real(dp), dimension(:,:), intent(in) :: xa +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa)) :: s + + s = safestr(xa, "") +#endif + end function str_real_dp_matrix + +! For complex numbers, there's not really much prior art, so +! we use the easy solution: a+bi, where a & b are real numbers +! as output above. + + function str_complex_sp_fmt_chk(c, fmt) result(s) + complex(sp), intent(in) :: c + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(c, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(c, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_sp_fmt_chk + +#ifndef DUMMYLIB + pure function str_complex_sp_fmt(c, fmt) result(s) + complex(sp), intent(in) :: c + character(len=*), intent(in) :: fmt + character(len=len(c, fmt)) :: s + + real(sp) :: re, im + integer :: i + re = real(c) + im = aimag(c) + i = len(re, fmt) + s(:i+4) = "("//safestr(re, fmt)//")+i" + s(i+5:)="("//safestr(im,fmt)//")" + end function str_complex_sp_fmt +#endif + + pure function str_complex_sp(c) result(s) + complex(sp), intent(in) :: c +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(c, "")) :: s + + s = safestr(c, "") +#endif + end function str_complex_sp + +#ifndef DUMMYLIB + pure function str_complex_sp_array_fmt(ca, fmt) result(s) + complex(sp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt + character(len=len(ca, fmt)) :: s + + integer :: i, n + + s(1:len(ca(1), fmt)) = safestr(ca(1), fmt) + n = len(ca(1), fmt)+1 + do i = 2, size(ca) + s(n:n+len(ca(i), fmt)) = " "//safestr(ca(i), fmt) + n = n + len(ca(i), fmt)+1 + enddo + end function str_complex_sp_array_fmt +#endif + + function str_complex_sp_array_fmt_chk(ca, fmt) result(s) + complex(sp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(ca, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_sp_array_fmt_chk + + pure function str_complex_sp_array(ca) result(s) + complex(sp), dimension(:), intent(in) :: ca +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca)) :: s + + s = safestr(ca, "") +#endif + end function str_complex_sp_array + +#ifndef DUMMYLIB + pure function str_complex_sp_matrix_fmt(ca, fmt) result(s) + complex(sp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt + character(len=len(ca, fmt)) :: s + + integer :: i, j, k, n + + i = len(ca(1,1), fmt) + s(:i) = safestr(ca(1,1), fmt) + n = i + 1 + do j = 2, size(ca, 1) + i = len(ca(j,1), fmt) + s(n:n+i) = " "//safestr(ca(j,1), fmt) + n = n + i + 1 + enddo + do k = 2, size(ca, 2) + do j = 1, size(ca, 1) + i = len(ca(j,k), fmt) + s(n:n+i) = " "//safestr(ca(j,k), fmt) + n = n + i + 1 + enddo + enddo + + end function str_complex_sp_matrix_fmt +#endif + + function str_complex_sp_matrix_fmt_chk(ca, fmt) result(s) + complex(sp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(ca, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_sp_matrix_fmt_chk + + pure function str_complex_sp_matrix(ca) result(s) + complex(sp), dimension(:, :), intent(in) :: ca +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca)) :: s + + s = safestr(ca, "") +#endif + end function str_complex_sp_matrix + + function str_complex_dp_fmt_chk(c, fmt) result(s) + complex(dp), intent(in) :: c + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(c, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(c, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_dp_fmt_chk + +#ifndef DUMMYLIB + pure function str_complex_dp_fmt(c, fmt) result(s) + complex(dp), intent(in) :: c + character(len=*), intent(in) :: fmt + character(len=len(c, fmt)) :: s + + real(dp) :: re, im + integer :: i + re = real(c) + im = aimag(c) + i = len(re, fmt) + s(:i+4) = "("//safestr(re, fmt)//")+i" + s(i+5:)="("//safestr(im,fmt)//")" + end function str_complex_dp_fmt +#endif + + pure function str_complex_dp(c) result(s) + complex(dp), intent(in) :: c +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(c, "")) :: s + + s = safestr(c, "") +#endif + end function str_complex_dp + +#ifndef DUMMYLIB + pure function str_complex_dp_array_fmt(ca, fmt) result(s) + complex(dp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt + character(len=len(ca, fmt)) :: s + + integer :: i, n + + s(1:len(ca(1), fmt)) = safestr(ca(1), fmt) + n = len(ca(1), fmt)+1 + do i = 2, size(ca) + s(n:n+len(ca(i), fmt)) = " "//safestr(ca(i), fmt) + n = n + len(ca(i), fmt)+1 + enddo + end function str_complex_dp_array_fmt +#endif + + function str_complex_dp_array_fmt_chk(ca, fmt) result(s) + complex(dp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(ca, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_dp_array_fmt_chk + + pure function str_complex_dp_array(ca) result(s) + complex(dp), dimension(:), intent(in) :: ca +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca)) :: s + + s = safestr(ca, "") +#endif + end function str_complex_dp_array + +#ifndef DUMMYLIB + pure function str_complex_dp_matrix_fmt(ca, fmt) result(s) + complex(dp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt + character(len=len(ca, fmt)) :: s + + integer :: i, j, k, n + + i = len(ca(1,1), fmt) + s(:i) = safestr(ca(1,1), fmt) + n = i + 1 + do j = 2, size(ca, 1) + i = len(ca(j,1), fmt) + s(n:n+i) = " "//safestr(ca(j,1), fmt) + n = n + i + 1 + enddo + do k = 2, size(ca, 2) + do j = 1, size(ca, 1) + i = len(ca(j,k), fmt) + s(n:n+i) = " "//safestr(ca(j,k), fmt) + n = n + i + 1 + enddo + enddo + + end function str_complex_dp_matrix_fmt +#endif + + function str_complex_dp_matrix_fmt_chk(ca, fmt) result(s) + complex(dp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(ca, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_dp_matrix_fmt_chk + + pure function str_complex_dp_matrix(ca) result(s) + complex(dp), dimension(:, :), intent(in) :: ca +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca)) :: s + + s = safestr(ca, "") +#endif + end function str_complex_dp_matrix + +#ifndef DUMMYLIB + pure function checkFmt(fmt) result(good) + character(len=*), intent(in) :: fmt + logical :: good + + ! should be ([rs]\d*)? + + if (len(fmt) > 0) then + if (fmt(1:1) == "r" .or. fmt(1:1) == "s") then + if (len(fmt) > 1) then + good = (verify(fmt(2:), digit) == 0) + else + good = .true. + endif + else + good = .false. + endif + else + good = .true. + endif + end function checkFmt +#endif + + pure function concat_str_int(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + integer, intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_int + pure function concat_int_str(s1, s2) result(s3) + integer, intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_int_str + + pure function concat_str_logical(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + logical, intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_logical + pure function concat_logical_str(s1, s2) result(s3) + logical, intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_logical_str + + pure function concat_str_real_sp(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + real(sp), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_real_sp + pure function concat_real_sp_str(s1, s2) result(s3) + real(sp), intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_real_sp_str + + pure function concat_str_real_dp(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + real(dp), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_real_dp + pure function concat_real_dp_str(s1, s2) result(s3) + real(dp), intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_real_dp_str + + pure function concat_str_complex_sp(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + complex(sp), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_complex_sp + pure function concat_complex_sp_str(s1, s2) result(s3) + complex(sp), intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_complex_sp_str + + pure function concat_str_complex_dp(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + complex(dp), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_complex_dp + pure function concat_complex_dp_str(s1, s2) result(s3) + complex(dp), intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_complex_dp_str + +end module fox_m_fsys_format diff --git a/src/xml/fsys/fox_m_fsys_parse_input.F90 b/src/xml/fsys/fox_m_fsys_parse_input.F90 new file mode 100644 index 000000000..45551c1d6 --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_parse_input.F90 @@ -0,0 +1,2281 @@ +module fox_m_fsys_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 rts + module procedure scalartostring + module procedure scalartological + module procedure scalartointeger + module procedure scalartolong + module procedure scalartorealsp + module procedure scalartorealdp + module procedure scalartocomplexsp + module procedure scalartocomplexdp + module procedure arraytostring + module procedure arraytological + module procedure arraytointeger + module procedure arraytorealsp + module procedure arraytorealdp + module procedure arraytocomplexsp + module procedure arraytocomplexdp + module procedure matrixtostring + module procedure matrixtological + module procedure matrixtointeger + module procedure matrixtorealsp + module procedure matrixtorealdp + module procedure matrixtocomplexsp + module procedure matrixtocomplexdp + end interface + + public :: rts + +contains + + subroutine scalartostring(s, data, separator, csv, num, iostat) + character(len=*), intent(in) :: s + character(len=*), intent(out) :: data + character, intent(in), optional :: separator + logical, intent(in), optional :: csv + integer, intent(out), optional :: num, iostat +#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, sp + integer :: m + + csv_ = .false. + if (present(csv)) then + csv_ = csv + endif + + s_i = 1 + err = 0 + eof = .false. + data = "" + ij = 0 + length = 1 + loop: do + if (csv_) then + if (s_i>len(s)) then + data = "" + ij = ij + 1 + exit loop + endif + k = verify(s(s_i:), achar(10)//achar(13)) + if (k==0) then + data = "" + 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 + data = s2 + 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 + if (ij+1==length.and.s(s_i+k-1:s_i+k-1)==",") err = 1 + k = s_i + k - 2 + endif + data = s(s_i:k) + if (index(data, """")/=0) then + err = 2 + exit loop + endif + endif + ij = ij + 1 + s_i = k + 2 + if (eof) exit loop + + if (present(num)) num = ij + if (ijlen(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 (s(s_i:k)=="true".or.s(s_i:k)=="1") then + data = .true. + elseif (s(s_i:k)=="false".or.s(s_i:k)=="0") then + data = .false. + else + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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) data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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) data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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) data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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) data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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 + data = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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 + data = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + data(i) = "" + ij = ij + 1 + exit loop + endif + k = verify(s(s_i:), achar(10)//achar(13)) + if (k==0) then + data(i) = "" + 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 + data(i) = s2 + 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 + if (ij+1==length.and.s(s_i+k-1:s_i+k-1)==",") err = 1 + k = s_i + k - 2 + endif + data(i) = s(s_i:k) + if (index(data(i), """")/=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 + data(i) = s(s_i:k) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + endif + end do loop + + if (present(num)) num = ij + if (ij=0) & + err = 1 + else + if (verify(s(s_i:), whitespace)/=0) & + err = 1 + endif + endif + + if (present(iostat)) then + iostat = err + else + select case (err) + case(-1) + write(0, *) "Error in arraytostring" + write(0, *) "Too few elements found" + stop + case(1) + write(0, *) "Error in arraytostring" + write(0, *) "Too many elements found" + stop + case(2) + write(0, *) "Error in arraytostring" + write(0, *) "Malformed input" + stop + end select + end if + +#else + data = "" +#endif + end subroutine arraytostring + + subroutine matrixtostring(s, data, separator, csv, num, iostat) + character(len=*) :: data(:,:) + character, intent(in), optional :: separator + logical, intent(in), optional :: csv + character(len=*), intent(in) :: s + integer, intent(out), optional :: num + integer, intent(out), optional :: iostat + +#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. + data = "" + ij = 0 + length = size(data) + loop: do j = 1, size(data, 2) + do i = 1, size(data, 1) + if (csv_) then + if (s_i>len(s)) then + data(i, j) = "" + ij = ij + 1 + exit loop + endif + k = verify(s(s_i:), achar(10)//achar(13)) + if (k==0) then + data(i, j) = "" + 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 + data(i, j) = s2 + 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 + if (ij+1==length.and.s(s_i+k-1:s_i+k-1)==",") err = 1 + k = s_i + k - 2 + endif + data(i, j) = s(s_i:k) + if (index(data(i, j), """")/=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 + data(i, j) = s(s_i:k) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + endif + end do + end do loop + + if (present(num)) num = ij + if (ij=0) & + err = 1 + else + if (verify(s(s_i:), whitespace)/=0) & + err = 1 + endif + endif + + if (present(iostat)) then + iostat = err + else + select case (err) + case(-1) + write(0, *) "Error in matrixtostring" + write(0, *) "Too few elements found" + stop + case(1) + write(0, *) "Error in matrixtostring" + write(0, *) "Too many elements found" + stop + case(2) + write(0, *) "Error in matrixtostring" + write(0, *) "Malformed input" + stop + end select + end if + +#else + data = "" +#endif + end subroutine matrixtostring + + subroutine arraytological(s, data, num, iostat) + logical, intent(out) :: data(:) + character(len=*), intent(in) :: s + integer, intent(out), optional :: num + integer, intent(out), optional :: iostat + +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + + s_i = 1 + err = 0 + data = .false. + ij = 0 + length = size(data) + loop: do i = 1, size(data) + 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 (s(s_i:k)=="true".or.s(s_i:k)=="1") then + data(i) = .true. + elseif (s(s_i:k)=="false".or.s(s_i:k)=="0") then + data(i) = .false. + else + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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 (s(s_i:k)=="true".or.s(s_i:k)=="1") then + data(i, j) = .true. + elseif (s(s_i:k)=="false".or.s(s_i:k)=="0") then + data(i, j) = .false. + else + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(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) data(i) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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) data(i, j) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(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) data(i) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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) data(i, j) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(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) data(i) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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) data(i, j) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(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 + data(i) = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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 + data(i, j) = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(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 + data(i) = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(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 + data(i, j) = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ij0) 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 diff --git a/src/xml/fsys/fox_m_fsys_string_list.F90 b/src/xml/fsys/fox_m_fsys_string_list.F90 new file mode 100644 index 000000000..ecf407483 --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_string_list.F90 @@ -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 diff --git a/src/xml/fsys/fox_m_fsys_varstr.F90 b/src/xml/fsys/fox_m_fsys_varstr.F90 new file mode 100644 index 000000000..52efa5fde --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_varstr.F90 @@ -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 diff --git a/src/xml/fsys/m_ieee.F90 b/src/xml/fsys/m_ieee.F90 new file mode 100644 index 000000000..afec6f080 --- /dev/null +++ b/src/xml/fsys/m_ieee.F90 @@ -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 diff --git a/src/xml/sax/FoX_sax.F90 b/src/xml/sax/FoX_sax.F90 new file mode 100644 index 000000000..17dc2280e --- /dev/null +++ b/src/xml/sax/FoX_sax.F90 @@ -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 diff --git a/src/xml/sax/Makefile b/src/xml/sax/Makefile new file mode 100644 index 000000000..c0a134055 --- /dev/null +++ b/src/xml/sax/Makefile @@ -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 diff --git a/src/xml/sax/m_sax_operate.F90 b/src/xml/sax/m_sax_operate.F90 new file mode 100644 index 000000000..531618ad2 --- /dev/null +++ b/src/xml/sax/m_sax_operate.F90 @@ -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 diff --git a/src/xml/sax/m_sax_parser.F90 b/src/xml/sax/m_sax_parser.F90 new file mode 100644 index 000000000..c2f2283fb --- /dev/null +++ b/src/xml/sax/m_sax_parser.F90 @@ -0,0 +1,3029 @@ +module m_sax_parser + +#ifndef DUMMYLIB + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc + use fox_m_fsys_string_list, only: string_list, destroy_string_list, & + tokenize_to_string_list, registered_string, init_string_list, & + add_string, tokenize_and_add_strings, destroy + use fox_m_fsys_varstr + use m_common_attrs, only: init_dict, destroy_dict, reset_dict, & + add_item_to_dict, has_key, get_value, get_att_index_pointer, & + getLength, setIsId, setBase + use m_common_charset, only: XML1_0, XML1_1, XML_WHITESPACE + use m_common_element, only: element_t, existing_element, add_element, & + get_element, parse_dtd_element, parse_dtd_attlist, report_declarations, & + declared_element, attribute_t, att_value_normalize, & + get_attribute_declaration, & + ATT_CDATA, ATT_ID, ATT_IDREF, ATT_IDREFS, ATT_ENTITY, ATT_ENTITIES, & + ATT_NMTOKEN, ATT_NMTOKENS, ATT_NOTATION, ATT_ENUM, & + ATT_REQUIRED, ATT_IMPLIED, ATT_DEFAULT, ATT_FIXED + use m_common_elstack, only: push_elstack, pop_elstack, init_elstack, & + destroy_elstack, is_empty, len, get_top_elstack, checkContentModel, & + elementContent, emptyContent, checkContentModelToEnd + use m_common_entities, only: existing_entity, init_entity_list, & + destroy_entity_list, add_internal_entity, is_unparsed_entity, & + expand_entity, expand_char_entity, pop_entity_list, size, & + entity_t, getEntityByIndex, getEntityByName + use m_common_entity_expand, only: expand_entity_value_alloc + use m_common_error, only: FoX_error, add_error, & + init_error_stack, destroy_error_stack, in_error + use m_common_namecheck, only: checkName, checkPublicId, & + checkCharacterEntityReference, likeCharacterEntityReference, & + checkQName, checkNCName, checkPITarget, checkNmtoken, checkNmtokens, & + checkRepCharEntityReference, checkNames, checkNCNames + use m_common_namespaces, only: getnamespaceURI, invalidNS, & + checkNamespaces, checkEndNamespaces, namespaceDictionary, & + initNamespaceDictionary, destroyNamespaceDictionary + use m_common_notations, only: init_notation_list, destroy_notation_list, & + add_notation, notation_exists + use m_common_struct, only: init_xml_doc_state, & + destroy_xml_doc_state, register_internal_PE, register_external_PE, & + register_internal_GE, register_external_GE + + use FoX_utils, only: URI, parseURI, rebaseURI, copyURI, destroyURI, & + hasFragment, expressURI + + use m_sax_reader, only: file_buffer_t, pop_buffer_stack, open_new_string, & + open_new_file, parse_xml_declaration, parse_text_declaration, & + reading_main_file, reading_first_entity, add_error_position + use m_sax_tokenizer, only: sax_tokenize, normalize_attribute_text, & + expand_pe_text + use m_sax_types ! everything, really + + implicit none + private + + public :: getNSDict + + public :: sax_parser_init + public :: sax_parser_destroy + public :: sax_parse + +contains + + function getNSDict(fx) result(ns) + type(sax_parser_t), target :: fx + type(namespaceDictionary), pointer :: ns + + ns => fx%nsDict + end function getNSDict + + subroutine sax_parser_init(fx, fb) + type(sax_parser_t), intent(out) :: fx + type(file_buffer_t), intent(in) :: fb +#ifdef PGF90 + type(URI), pointer :: nullURI + + nullURI => null() +#endif + + call init_varstr(fx%token) + call init_varstr(fx%content) + call init_varstr(fx%name) + call init_varstr(fx%attname) + call init_varstr(fx%PublicId) + call init_varstr(fx%systemId) + call init_varstr(fx%Ndata) + call init_varstr(fx%root_element) + + call init_error_stack(fx%error_stack) + call init_elstack(fx%elstack) + call init_dict(fx%attributes) + + call initNamespaceDictionary(fx%nsdict) + call init_notation_list(fx%nlist) + ! FIXME do we copy correctly from fx%nlist to fx%xds%nlist? + allocate(fx%xds) + call init_xml_doc_state(fx%xds) + deallocate(fx%xds%inputEncoding) + fx%xds%inputEncoding => vs_str_alloc("us-ascii") + ! because it always is ... + if (fb%f(1)%lun>0) then + fx%xds%documentURI => vs_vs_alloc(fb%f(1)%filename) + else + fx%xds%documentURI => vs_str_alloc("") + endif + + fx%xds%standalone = fb%standalone + + call init_entity_list(fx%forbidden_ge_list) + call init_entity_list(fx%forbidden_pe_list) + call init_entity_list(fx%predefined_e_list) + +#ifdef PGF90 + call add_internal_entity(fx%predefined_e_list, 'amp', '&', nullURI, .false.) + call add_internal_entity(fx%predefined_e_list, 'lt', '<', nullURI, .false.) + call add_internal_entity(fx%predefined_e_list, 'gt', '>', nullURI, .false.) + call add_internal_entity(fx%predefined_e_list, 'apos', "'", nullURI, .false.) + call add_internal_entity(fx%predefined_e_list, 'quot', '"', nullURI, .false.) +#else + call add_internal_entity(fx%predefined_e_list, 'amp', '&', null(), .false.) + call add_internal_entity(fx%predefined_e_list, 'lt', '<', null(), .false.) + call add_internal_entity(fx%predefined_e_list, 'gt', '>', null(), .false.) + call add_internal_entity(fx%predefined_e_list, 'apos', "'", null(), .false.) + call add_internal_entity(fx%predefined_e_list, 'quot', '"', null(), .false.) +#endif + end subroutine sax_parser_init + + subroutine sax_parser_destroy(fx) + type(sax_parser_t), intent(inout) :: fx + + fx%context = CTXT_NULL + fx%state = ST_NULL + + call destroy_varstr(fx%token) + call destroy_varstr(fx%root_element) + + call destroy_error_stack(fx%error_stack) + call destroy_elstack(fx%elstack) + call destroy_dict(fx%attributes) + call destroyNamespaceDictionary(fx%nsdict) + call destroy_notation_list(fx%nlist) + if (.not.fx%xds_used) then + call destroy_xml_doc_state(fx%xds) + deallocate(fx%xds) + endif + + call destroy_entity_list(fx%forbidden_ge_list) + call destroy_entity_list(fx%forbidden_pe_list) + call destroy_entity_list(fx%predefined_e_list) + + call destroy_varstr(fx%token) + call destroy_varstr(fx%content) + call destroy_varstr(fx%name) + call destroy_varstr(fx%attname) + call destroy_varstr(fx%publicId) + call destroy_varstr(fx%systemId) + call destroy_varstr(fx%Ndata) + call destroy_varstr(fx%root_element) + + end subroutine sax_parser_destroy + + recursive subroutine sax_parse(fx, fb, & + ! org.xml.sax + ! SAX ContentHandler + characters_handler, & + endDocument_handler, & + endElement_handler, & + endPrefixMapping_handler, & + ignorableWhitespace_handler, & + processingInstruction_handler, & + ! setDocumentLocator + skippedEntity_handler, & + startDocument_handler, & + startElement_handler, & + startPrefixMapping_handler, & + ! SAX DTDHandler + notationDecl_handler, & + unparsedEntityDecl_handler, & + ! SAX ErrorHandler + error_handler, & + fatalError_handler, & + warning_handler, & + ! org.xml.sax.ext + ! SAX DeclHandler + attributeDecl_handler, & + elementDecl_handler, & + externalEntityDecl_handler, & + internalEntityDecl_handler, & + ! SAX LexicalHandler + comment_handler, & + endCdata_handler, & + endDTD_handler, & + endEntity_handler, & + startCdata_handler, & + startDTD_handler, & + startEntity_handler, & + namespaces, & + namespace_prefixes, & + xmlns_uris, & + validate, & + FoX_endDTD_handler, & + startInCharData, & + externalEntity, & + xmlVersion, & + initial_entities) + + type(sax_parser_t), intent(inout) :: fx + type(file_buffer_t), intent(inout) :: fb + 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 :: FoX_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 :: xmlns_uris + + logical, intent(in), optional :: validate + logical, intent(in), optional :: startInCharData + logical, intent(in), optional :: externalEntity + character(len=*), intent(in), optional :: xmlVersion + + type(entity_list), optional :: initial_entities +#ifdef PGF90 + type(URI), pointer :: nullURI +#endif + + 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 FoX_endDTD_handler(state) + use m_common_struct, only: xml_doc_state + type(xml_doc_state), pointer :: state + end subroutine FoX_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 + + logical :: validCheck, startInCharData_, processDTD, pe, nameOK, eof + logical :: namespaces_, namespace_prefixes_, xmlns_uris_, externalEntity_ + integer :: i, iostat, temp_i, nextState, ignoreDepth, declSepValue + character, pointer :: tempString(:), tempString2(:) + character :: dummy + type(element_t), pointer :: elem + type(attribute_t), pointer :: attDecl + type(entity_t), pointer :: ent + type(URI), pointer :: extSubsetURI, URIref, newURI + integer, pointer :: wf_stack(:), temp_wf_stack(:), extEntStack(:) + logical :: inExtSubset + type(string_list) :: id_list, idref_list + +#ifdef PGF90 + nullURI => null() +#endif + tempString => null() + tempString2 => null() + elem => null() + attDecl => null() + + if (present(namespaces)) then + namespaces_ = namespaces + else + namespaces_ = .true. + endif + if (present(namespace_prefixes)) then + namespace_prefixes_ = namespace_prefixes + else + namespace_prefixes_ = .false. + endif + if (present(xmlns_uris)) then + xmlns_uris_ = xmlns_uris + else + xmlns_uris_ = .false. + endif + if (present(validate)) then + validCheck = validate + else + validCheck = .false. + endif + if (present(startInCharData)) then + startInCharData_ = startInCharData + else + startInCharData_ = .false. + endif + if (present(externalEntity)) then + externalEntity_ = externalEntity + else + externalEntity_ = .false. + endif + if (present(initial_entities)) then + do i = 1, size(initial_entities) + ent => getEntityByIndex(initial_entities, i) + if (ent%external) then + call register_external_GE(fx%xds, & + name=str_vs(ent%name), systemId=str_vs(ent%systemId), & + publicId=str_vs(ent%publicId), & + wfc=ent%wfc, baseURI=copyURI(ent%baseURI)) + else + call register_internal_GE(fx%xds, & + name=str_vs(ent%name), text=str_vs(ent%text), & + wfc=ent%wfc, baseURI=copyURI(ent%baseURI)) + endif + enddo + endif + + allocate(wf_stack(1)) + wf_stack(1) = 0 + allocate(extEntStack(0)) + fx%inIntSubset = .false. + extSubsetURI => null() + inExtSubset = .false. + declSepValue = 0 + processDTD = .true. + iostat = 0 + + if (startInCharData_) then + fx%context = CTXT_IN_CONTENT + fx%state = ST_CHAR_IN_CONTENT + fx%well_formed = .true. + if (externalEntity_) call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + if (present(xmlVersion)) then + if (xmlVersion=="1.0") then + fx%xds%xml_version = XML1_0 + elseif (xmlVersion=="1.1") then + fx%xds%xml_version = XML1_1 + endif + endif + elseif (reading_main_file(fb)) then + fx%context = CTXT_BEFORE_DTD + fx%state = ST_MISC + if (present(startDocument_handler)) then + call startDocument_handler() + if (fx%state==ST_STOP) goto 100 + endif + call parse_xml_declaration(fb, fx%xds%xml_version, fx%xds%encoding, fx%xds%standalone, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + call init_string_list(id_list) + call init_string_list(idref_list) + endif + + do + call sax_tokenize(fx, fb, eof) + if (in_error(fx%error_stack)) then + ! Any error, we want to quit sax_tokenizer + call add_error(fx%error_stack, 'Error getting token') + goto 100 + elseif (eof.and..not.reading_main_file(fb)) then + if (inExtSubset.and.reading_first_entity(fb)) then + if (wf_stack(1)>0) then + call add_error(fx%error_stack, & + "Unclosed conditional section or markup in external subset") + goto 100 + elseif (fx%state_dtd/=ST_DTD_SUBSET) then + call add_error(fx%error_stack, & + "Markup not terminated in external subset") + goto 100 + endif + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + inExtSubset = .false. + fx%state = ST_MISC + fx%context = CTXT_BEFORE_CONTENT + elseif (fx%context==CTXT_IN_DTD) then + if (validCheck) then + if (wf_stack(1)/=0) then + call add_error(fx%error_stack, & + "Markup not terminated in parameter entity") + goto 100 + endif + endif + if (declSepValue==size(wf_stack)) then + if (wf_stack(1)/=0) then + call add_error(fx%error_stack, & + "Markup not terminated in parameter entity") + goto 100 + else + declSepValue = 0 + endif + endif + if (present(endEntity_handler)) then + call endEntity_handler('%'//pop_entity_list(fx%forbidden_pe_list)) + if (fx%state==ST_STOP) goto 100 + else + dummy = pop_entity_list(fx%forbidden_pe_list) + endif + if (fx%state_dtd==ST_DTD_ATTLIST_CONTENTS & + .or.fx%state_dtd==ST_DTD_ELEMENT_CONTENTS) then + ! stick the token back in contents ... + call move_varstr_varstr(fx%token,fx%content) + endif + if (reading_main_file(fb)) & + fx%inIntSubset = .true. + elseif (fx%context==CTXT_IN_CONTENT) then + if (fx%state==ST_TAG_IN_CONTENT) fx%state = ST_CHAR_IN_CONTENT + ! because CHAR_IN_CONTENT *always* leads to TAG_IN_CONTENT + ! *except* when it is the end of an entity expansion + if (present(endEntity_handler)) then + call endEntity_handler(pop_entity_list(fx%forbidden_ge_list)) + if (fx%state==ST_STOP) goto 100 + else + dummy = pop_entity_list(fx%forbidden_ge_list) + endif + if (fx%state/=ST_CHAR_IN_CONTENT.or.wf_stack(1)/=0) then + call add_error(fx%error_stack, 'Ill-formed entity') + goto 100 + endif + endif + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)-1)) + wf_stack = temp_wf_stack(2:) + ! If we are not doing validity checking, we might have + ! finished PE expansion with wf_stack(1) non-zero + wf_stack(1) = wf_stack(1) + temp_wf_stack(1) + deallocate(temp_wf_stack) + temp_wf_stack => extEntStack + allocate(extEntStack(size(temp_wf_stack)-1)) + extEntStack = temp_wf_stack(2:) + deallocate(temp_wf_stack) + call pop_buffer_stack(fb) + cycle + endif + if (fx%tokenType==TOK_NULL) then + call add_error(fx%error_stack, 'Internal error! No token found!') + goto 100 + endif + + nextState = ST_NULL + + select case (fx%state) + + case (ST_MISC) + !write(*,*) 'ST_MISC', str_varstr(fx%token) + select case (fx%tokenType) + case (TOK_PI_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_START_PI + case (TOK_BANG_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_BANG_TAG + case (TOK_OPEN_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_START_TAG + end select + + + case (ST_BANG_TAG) + !write(*,*) 'ST_BANG_TAG' + select case (fx%tokenType) + case (TOK_OPEN_SB) + nextState = ST_START_CDATA_DECLARATION + case (TOK_OPEN_COMMENT) + nextState = ST_START_COMMENT + case (TOK_NAME) + if (equal_varstr_str(fx%token,'DOCTYPE')) then + fx%context = CTXT_IN_DTD + nextState = ST_IN_DOCTYPE + endif + end select + + + case (ST_START_PI) + !write(*,*)'ST_START_PI' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (nameOk) then + if (equal_varstr_str(fx%token,'xml')) then + call add_error(fx%error_stack, "XML declaration must be at start of document") + goto 100 + elseif (checkPITarget(str_varstr(fx%token), fx%xds%xml_version)) then + nextState = ST_PI_CONTENTS + call move_varstr_varstr(fx%token,fx%name) + else + call add_error(fx%error_stack, "Invalid PI target name") + goto 100 + endif + endif + end select + + case (ST_PI_CONTENTS) + !write(*,*)'ST_PI_CONTENTS' + if (validCheck) then + if (emptyContent(fx%elstack)) then + call add_error(fx%error_stack, "Content inside empty element") + goto 100 + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case(fx%tokenType) + case (TOK_CHAR) + if (present(processingInstruction_handler)) then + call processingInstruction_handler(str_varstr(fx%name), str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + call set_varstr_null(fx%name) + nextState = ST_PI_END + case (TOK_PI_END) + if (present(processingInstruction_handler)) then + call processingInstruction_handler(str_varstr(fx%name), "") + if (fx%state==ST_STOP) goto 100 + endif + call set_varstr_null(fx%name) + if (fx%context==CTXT_IN_CONTENT) then + nextState = ST_CHAR_IN_CONTENT + else + nextState = ST_MISC + endif + end select + + case (ST_PI_END) + !write(*,*)'ST_PI_END' + select case(fx%tokenType) + case (TOK_PI_END) + if (fx%context==CTXT_IN_CONTENT) then + nextState = ST_CHAR_IN_CONTENT + else + nextState = ST_MISC + endif + end select + + case (ST_START_COMMENT) + !write(*,*)'ST_START_COMMENT' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%name) + nextState = ST_COMMENT_END + end select + + case (ST_COMMENT_END) + !write(*,*)'ST_COMMENT_END' + if (validCheck) then + if (emptyContent(fx%elstack)) then + call add_error(fx%error_stack, "Content inside empty element") + goto 100 + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case (fx%tokenType) + case (TOK_COMMENT_END) + if (present(comment_handler)) then + call comment_handler(str_varstr(fx%name)) + if (fx%state==ST_STOP) goto 100 + endif + call set_varstr_null(fx%name) + if (fx%context==CTXT_IN_CONTENT) then + nextState = ST_CHAR_IN_CONTENT + else + nextState = ST_MISC + endif + end select + + case (ST_START_TAG) + !write(*,*)'ST_START_TAG', fx%context + select case (fx%tokenType) + case (TOK_NAME) + if (fx%context==CTXT_BEFORE_DTD & + .or. fx%context==CTXT_BEFORE_CONTENT & + .or. fx%context==CTXT_IN_CONTENT) then + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Illegal element name") + goto 100 + endif + call move_varstr_varstr(fx%token,fx%name) + nextState = ST_IN_TAG + elseif (fx%context == CTXT_AFTER_CONTENT) then + call add_error(fx%error_stack, "Cannot open second root element") + goto 100 + elseif (fx%context == CTXT_IN_DTD) then + call add_error(fx%error_stack, "Cannot open root element before DTD is finished") + goto 100 + endif + end select + + case (ST_START_CDATA_DECLARATION) + !write(*,*) "ST_START_CDATA_DECLARATION" + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,"CDATA")) then + if (fx%context/=CTXT_IN_CONTENT) then + call add_error(fx%error_stack, "CDATA section only allowed in text content.") + goto 100 + else + nextState = ST_FINISH_CDATA_DECLARATION + endif + else + call add_error(fx%error_stack, "Unknown keyword found in marked section declaration.") + endif + end select + + case (ST_FINISH_CDATA_DECLARATION) + !write(*,*) "ST_FINISH_CDATA_DECLARATION" + select case (fx%tokenType) + case (TOK_OPEN_SB) + nextState = ST_CDATA_CONTENTS + end select + + + case (ST_CDATA_CONTENTS) + !write(*,*)'ST_CDATA_CONTENTS' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%name) + nextState = ST_CDATA_END + end select + + case (ST_CDATA_END) + !write(*,*)'ST_CDATA_END' + if (validCheck) then + if (emptyContent(fx%elstack).or.elementContent(fx%elstack)) then + call add_error(fx%error_stack, "Content inside empty element") + goto 100 + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case(fx%tokenType) + case (TOK_SECTION_END) + if (present(startCdata_handler)) then + call startCdata_handler + if (fx%state==ST_STOP) goto 100 + endif + if (.not.is_varstr_empty(fx%name)) then + if (present(characters_handler)) then + call characters_handler(str_varstr(fx%name)) + if (fx%state==ST_STOP) goto 100 + endif + endif + if (present(endCdata_handler)) then + call endCdata_handler + if (fx%state==ST_STOP) goto 100 + endif + call set_varstr_null(fx%name) + nextState = ST_CHAR_IN_CONTENT + end select + + case (ST_IN_TAG) + !write(*,*)'ST_IN_TAG' + select case (fx%tokenType) + case (TOK_END_TAG) + if (fx%context /= CTXT_IN_CONTENT) then + if (.not.is_varstr_null(fx%root_element)) then + if (validCheck) then + if (.not.equal_varstr_varstr(fx%name,fx%root_element)) then + call add_error(fx%error_stack, "Root element name does not match document name") + goto 100 + endif + endif + call set_varstr_null(fx%root_element) + elseif (validCheck) then + call add_error(fx%error_stack, "No DTD defined") + goto 100 + else + ! We havent had a DTD, so we havent handed xds + ! over to the DOM. + if (present(FoX_endDTD_handler)) then + fx%xds_used = .true. + call FoX_endDTD_handler(fx%xds) + endif + endif + fx%context = CTXT_IN_CONTENT + endif + call open_tag + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + call set_varstr_null(fx%name) + nextState = ST_CHAR_IN_CONTENT + + case (TOK_END_TAG_CLOSE) + if (fx%context==CTXT_IN_CONTENT) then + nextState = ST_CHAR_IN_CONTENT + else + ! only a single element in this doc + if (.not.is_varstr_null(fx%root_element)) then + if (validCheck) then + if (.not.equal_varstr_varstr(fx%name,fx%root_element)) then + call add_error(fx%error_stack, "Root element name does not match document name") + goto 100 + endif + endif + call set_varstr_null(fx%root_element) + elseif (validCheck) then + call add_error(fx%error_stack, "No DTD defined") + goto 100 + else + ! No DTD, so we havent handed over xds + if (present(FoX_endDTD_handler)) then + fx%xds_used = .true. + call FoX_endDTD_handler(fx%xds) + endif + endif + endif + call open_tag + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + call close_tag + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + call set_varstr_null(fx%name) + if (fx%context/=CTXT_IN_CONTENT) then + fx%well_formed = .true. + fx%context = CTXT_AFTER_CONTENT + nextState = ST_MISC + endif + + case (TOK_NAME) + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Illegal attribute name") + goto 100 + endif + !Have we already had this dictionary item? + if (has_key(fx%attributes, str_varstr(fx%token))) then + call add_error(fx%error_stack, "Duplicate attribute name") + goto 100 + endif + call move_varstr_varstr(fx%token,fx%attname) + if (associated(elem)) then + attDecl => get_attribute_declaration(elem, str_varstr(fx%attname)) + else + attDecl => null() + endif + nextState = ST_ATT_NAME + end select + + case (ST_ATT_NAME) + !write(*,*)'ST_ATT_NAME' + select case (fx%tokenType) + case (TOK_EQUALS) + nextState = ST_ATT_EQUALS + end select + + case (ST_ATT_EQUALS) + !write(*,*)'ST_ATT_EQUALS' + ! token is pre-processed attribute value. + ! fx%name still contains attribute name + select case (fx%tokenType) + case (TOK_CHAR) + !First, expand all entities: + tempString2 => vs_varstr_alloc(fx%token) + tempString => normalize_attribute_text(fx, tempString2, fb) + call varstr_vs( fx%token, tempString ) + deallocate(tempString) + deallocate(tempString2) + tempString => null() + !If this attribute is not CDATA, we must process further; + if (associated(attDecl)) then + temp_i = attDecl%attType + else + temp_i = ATT_CDATA + endif + if (temp_i==ATT_CDATA) then + call add_item_to_dict(fx%attributes, str_varstr(fx%attname), & + str_varstr(fx%token), itype=ATT_CDATA, declared=associated(attDecl)) + else + if (validCheck) then + if (fx%xds%standalone.and..not.attDecl%internal & + .and.(str_varstr(fx%token)//"x"/=att_value_normalize(str_varstr(fx%token))//"x")) then + call add_error(fx%error_stack, & + "Externally-declared attribute value normalization results in changed value "// & + "in standalone document") + goto 100 + endif + endif + call add_item_to_dict(fx%attributes, str_varstr(fx%attname), & + att_value_normalize(str_varstr(fx%token)), itype=temp_i, & + declared=.true.) + endif + call set_varstr_null(fx%attname) + nextState = ST_IN_TAG + end select + + case (ST_CHAR_IN_CONTENT) + !write(*,*)'ST_CHAR_IN_CONTENT' + select case (fx%tokenType) + case (TOK_CHAR) + if (varstr_len(fx%token)>0) then + if (validCheck) then + if (elementContent(fx%elstack)) then + if (verify(str_varstr(fx%token), XML_WHITESPACE)==0) then + if (fx%xds%standalone.and..not.elem%internal) then + call add_error(fx%error_stack, & + "Externally-specified ignorable whitespace used in standalone document") + goto 100 + endif + if (present(ignorableWhitespace_handler)) then + call ignorableWhitespace_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + else + call add_error(fx%error_stack, "Forbidden content inside elementc: "//get_top_elstack(fx%elstack)) + goto 100 + endif + elseif (emptyContent(fx%elstack)) then + call add_error(fx%error_stack, "Forbidden content inside element: "//get_top_elstack(fx%elstack)) + goto 100 + else + if (present(characters_handler)) then + call characters_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + endif + else + if (present(characters_handler)) then + call characters_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + endif + endif + nextState = ST_TAG_IN_CONTENT + end select + + case (ST_TAG_IN_CONTENT) + !write(*,*) 'ST_TAG_IN_CONTENT' + select case (fx%tokenType) + case (TOK_ENTITY) + nextState = ST_START_ENTITY + case (TOK_PI_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_START_PI + case (TOK_BANG_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_BANG_TAG + case (TOK_CLOSE_TAG) + nextState = ST_CLOSING_TAG + case (TOK_OPEN_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_START_TAG + end select + + case (ST_START_ENTITY) + !write(*,*) 'ST_START_ENTITY' + select case (fx%tokenType) + case (TOK_NAME) + if (validCheck) then + elem => get_element(fx%xds%element_list, get_top_elstack(fx%elstack)) + if (associated(elem)) then + if (elem%empty) then + call add_error(fx%error_stack, & + "Forbidden content inside element") + goto 100 + endif + else + call add_error(fx%error_stack, & + 'Encountered reference to undeclared entity') + endif + endif + ent => getEntityByName(fx%forbidden_ge_list, str_varstr(fx%token)) + if (associated(ent)) then + call add_error(fx%error_stack, 'Recursive entity reference') + goto 100 + endif + ent => getEntityByName(fx%predefined_e_list, str_varstr(fx%token)) + if (associated(ent)) then + if (present(startEntity_handler)) then + call startEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + if (validCheck) then + if (associated(elem)) then + if (.not.elem%mixed.and..not.elem%any) then + call add_error(fx%error_stack, & + "Forbidden content inside element") + goto 100 + endif + endif + endif + if (present(characters_handler)) then + call characters_handler(expand_entity(fx%predefined_e_list, str_varstr(fx%token))) + if (fx%state==ST_STOP) goto 100 + endif + if (present(endEntity_handler)) then + call endEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + elseif (likeCharacterEntityReference(str_varstr(fx%token))) then + if (checkRepCharEntityReference(str_varstr(fx%token), fx%xds%xml_version)) then + if (validCheck) then + if (associated(elem)) then + if (.not.elem%mixed.and..not.elem%any) then + call add_error(fx%error_stack, & + "Forbidden content inside element") + goto 100 + endif + endif + endif + if (present(characters_handler)) then + call characters_handler(expand_char_entity(str_varstr(fx%token))) + if (fx%state==ST_STOP) goto 100 + endif + elseif (checkCharacterEntityReference(str_varstr(fx%token), fx%xds%xml_version)) then + call add_error(fx%error_stack, "Unable to digest character entity reference in content, sorry.") + goto 100 + else + call add_error(fx%error_stack, "Illegal character reference") + goto 100 + endif + elseif (existing_entity(fx%xds%entityList, str_varstr(fx%token))) then + ent => getEntityByName(fx%xds%entityList, str_varstr(fx%token)) + if (ent%wfc.and.fx%xds%standalone) then + call add_error(fx%error_stack, & + 'Externally declared entity referenced in standalone document') + goto 100 + elseif (str_vs(ent%notation)/="") then + call add_error(fx%error_stack, & + 'Cannot reference unparsed entity in content') + goto 100 + elseif (ent%external) then + call open_new_file(fb, ent%baseURI, iostat) + if (iostat/=0) then + if (validCheck) then + call add_error(fx%error_stack, & + "Unable to retrieve external entity "//str_varstr(fx%token)) + goto 100 + endif + if (present(skippedEntity_handler)) then + call skippedEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + else + if (present(startEntity_handler)) then + call startEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_ge_list, str_varstr(fx%token), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_ge_list, str_varstr(fx%token), "", null(), .false.) +#endif + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)+1)) + wf_stack = (/0, temp_wf_stack/) + deallocate(temp_wf_stack) + temp_wf_stack => extEntStack + allocate(extEntStack(size(temp_wf_stack)+1)) + extEntStack = (/len(fx%elstack), temp_wf_stack/) + deallocate(temp_wf_stack) + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + endif + else + if (validCheck.and.associated(elem)) then + if (elem%empty) then + call add_error(fx%error_stack, & + "Forbidden content inside element") + goto 100 + endif + endif + if (present(startEntity_handler)) then + call startEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_ge_list, str_varstr(fx%token), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_ge_list, str_varstr(fx%token), "", null(), .false.) +#endif + call open_new_string(fb, expand_entity(fx%xds%entityList, str_varstr(fx%token)), & + str_varstr(fx%token), baseURI=ent%baseURI) + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)+1)) + wf_stack = (/0, temp_wf_stack/) + deallocate(temp_wf_stack) + endif + else + ! Unknown entity check standalone etc + if (fx%skippedExternal.and..not.fx%xds%standalone) then + if (present(skippedEntity_handler)) then + call skippedEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + else + call add_error(fx%error_stack, & + 'Encountered reference to undeclared entity') + endif + endif + nextState = ST_CHAR_IN_CONTENT + end select + + case (ST_CLOSING_TAG) + !write(*,*)'ST_CLOSING_TAG' + select case (fx%tokenType) + case (TOK_NAME) + if (checkName(str_varstr(fx%token), fx%xds%xml_version)) then + call move_varstr_varstr(fx%token,fx%name) + nextState = ST_IN_CLOSING_TAG + else + call add_error(fx%error_stack, "Closing tag: expecting a Name") + goto 100 + end if + end select + + case (ST_IN_CLOSING_TAG) + !write(*,*)'ST_IN_CLOSING_TAG' + select case (fx%tokenType) + case (TOK_END_TAG) + call close_tag + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + call set_varstr_null(fx%name) + if (is_empty(fx%elstack)) then + if (startInCharData_) then + fx%well_formed = .true. + nextState = ST_CHAR_IN_CONTENT + else + !we're done + if (validCheck) then + call checkIdRefs + if (in_error(fx%error_stack)) goto 100 + endif + fx%well_formed = .true. + nextState = ST_MISC + fx%context = CTXT_AFTER_CONTENT + endif + else + nextState = ST_CHAR_IN_CONTENT + endif + end select + + case (ST_IN_DOCTYPE) + !write(*,*)'ST_IN_DOCTYPE' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid document name") + goto 100 + endif + call move_varstr_varstr(fx%token,fx%root_element) + nextState = ST_DOC_NAME + end select + + case (ST_DOC_NAME) + !write(*,*) 'ST_DOC_NAME ', str_varstr(fx%token) + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,'SYSTEM')) then + nextState = ST_DOC_SYSTEM + elseif (equal_varstr_str(fx%token,'PUBLIC')) then + nextState = ST_DOC_PUBLIC + endif + case (TOK_OPEN_SB) + if (present(startDTD_handler)) then + call startDTD_handler(str_varstr(fx%root_element), "", "") + if (fx%state==ST_STOP) goto 100 + endif + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_IN_SUBSET + fx%inIntSubset = .true. + case (TOK_END_TAG) + if (present(startDTD_handler)) then + call startDTD_handler(str_varstr(fx%root_element), "", "") + if (fx%state==ST_STOP) goto 100 + endif + wf_stack(1) = wf_stack(1) - 1 + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + fx%context = CTXT_BEFORE_CONTENT + nextState = ST_MISC + case default + call add_error(fx%error_stack, "Unexpected token") + goto 100 + end select + + case (ST_DOC_PUBLIC) + !write(*,*) 'ST_DOC_PUBLIC' + select case (fx%tokenType) + case (TOK_CHAR) + if (checkPublicId(str_varstr(fx%token))) then + call move_varstr_varstr(fx%token,fx%publicId) + nextState = ST_DOC_SYSTEM + else + call add_error(fx%error_stack, "Invalid document public id") + goto 100 + endif + end select + + case (ST_DOC_SYSTEM) + !write(*,*) 'ST_DOC_SYSTEM' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%systemId) + nextState = ST_DOC_DECL + end select + + case (ST_DOC_DECL) + !write(*,*) 'ST_DOC_DECL' + select case (fx%tokenType) + case (TOK_OPEN_SB) + if (present(startDTD_handler)) then + if (.not.is_varstr_null(fx%publicId)) then + call startDTD_handler(str_varstr(fx%root_element), & + publicId=str_varstr(fx%publicId), systemId=str_varstr(fx%systemId)) + elseif (.not.is_varstr_null(fx%systemId)) then + call startDTD_handler(str_varstr(fx%root_element), & + publicId="", systemId=str_varstr(fx%systemId)) + else + call startDTD_handler(str_varstr(fx%root_element), "", "") + endif + if (fx%state==ST_STOP) goto 100 + endif + if (.not.is_varstr_null(fx%systemId)) then + extSubsetURI => parseURI(str_varstr(fx%systemId)) + call set_varstr_null(fx%systemId) + endif + call set_varstr_null(fx%publicId) + fx%inIntSubset = .true. + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_IN_SUBSET + case (TOK_END_TAG) + if (present(startDTD_handler)) then + if (.not.is_varstr_null(fx%publicId)) then + call startDTD_handler(str_varstr(fx%root_element), publicId=str_varstr(fx%publicId), systemId=str_varstr(fx%systemId)) + call set_varstr_null(fx%publicId) + elseif (.not.is_varstr_null(fx%systemId)) then + call startDTD_handler(str_varstr(fx%root_element), publicId="", systemId=str_varstr(fx%systemId)) + else + call startDTD_handler(str_varstr(fx%root_element), "", "") + endif + if (fx%state==ST_STOP) goto 100 + endif + if (.not.is_varstr_null(fx%systemId)) then + extSubsetURI => parseURI(str_varstr(fx%systemId)) + if (.not.associated(extSubsetURI)) then + call add_error(fx%error_stack, "Invalid URI specified for DTD SYSTEM") + goto 100 + endif + call open_new_file(fb, extSubsetURI, iostat) + if (iostat==0) then + fx%inIntSubset=.false. + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)+1)) + wf_stack = (/0, temp_wf_stack/) + deallocate(temp_wf_stack) + inExtSubset = .true. + nextState = ST_IN_SUBSET + else + if (validCheck) then + call add_error(fx%error_stack, & + "Unable to retrieve external subset "//str_varstr(fx%systemId)) + goto 100 + endif + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + fx%context = CTXT_BEFORE_CONTENT + nextState = ST_MISC + endif + call destroyURI(extSubsetURI) + else + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + fx%context = CTXT_BEFORE_CONTENT + nextState = ST_MISC + endif + call set_varstr_null(fx%systemId) + call set_varstr_null(fx%publicId) + case default + call add_error(fx%error_stack, "Unexpected token in DTD") + goto 100 + end select + + + case (ST_CLOSE_DOCTYPE) + !write(*,*) "ST_CLOSE_DOCTYPE" + select case (fx%tokenType) + case (TOK_END_TAG) + if (wf_stack(1)>1) then + call add_error(fx%error_stack, "Cannot end DTD while conditional section is still open") + goto 100 + endif + if (associated(extSubsetURI)) then + call open_new_file(fb, extSubsetURI, iostat) + call destroyURI(extSubsetURI) + if (iostat==0) then + fx%inIntSubset = .false. + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)+1)) + wf_stack = (/0, temp_wf_stack/) + deallocate(temp_wf_stack) + inExtSubset = .true. + nextState = ST_IN_SUBSET + else + if (validCheck) then + call add_error(fx%error_stack, & + "Unable to retrieve external subset") + goto 100 + endif + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + wf_stack(1) = wf_stack(1) - 1 + nextState = ST_MISC + fx%context = CTXT_BEFORE_CONTENT + endif + else + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + wf_stack(1) = wf_stack(1) - 1 + nextState = ST_MISC + fx%context = CTXT_BEFORE_CONTENT + endif + end select + + case (ST_IN_SUBSET) + select case(fx%tokenType) + case (TOK_ENTITY) + nextState = ST_START_PE + case default + call parseDTD + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + if (fx%state_dtd==ST_DTD_DONE) & + fx%state_dtd = ST_DTD_SUBSET + end select + + case (ST_START_PE) + !write(*,*) 'ST_START_PE' + select case (fx%tokenType) + case (TOK_NAME) + if (existing_entity(fx%forbidden_pe_list, str_varstr(fx%token))) then + call add_error(fx%error_stack, & + 'Recursive entity reference') + goto 100 + endif + ent => getEntityByName(fx%xds%PEList, str_varstr(fx%token)) + if (associated(ent)) then + if (ent%wfc.and.fx%xds%standalone) then + call add_error(fx%error_stack, & + "Externally declared entity used in standalone document") + goto 100 + elseif (ent%external) then + if (present(startEntity_handler)) then + call startEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", null(), .false.) +#endif + call open_new_file(fb, ent%baseURI, iostat, pe=.true.) + if (iostat/=0) then + if (validCheck) then + call add_error(fx%error_stack, & + "Unable to retrieve external parameter entity "//str_varstr(fx%token)) + goto 100 + endif + if (present(skippedEntity_handler)) then + call skippedEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + ! having skipped a PE, we must now not process + ! declarations any further (unless we are declared standalone) + ! (XML section 5.1) + fx%skippedExternal = .true. + processDTD = fx%xds%standalone + else + fx%inIntSubset = .false. + if (present(startEntity_handler)) then + call startEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", null(), .false.) +#endif + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + allocate(temp_wf_stack(size(wf_stack)+1)) + temp_wf_stack = (/0, wf_stack/) + deallocate(wf_stack) + wf_stack => temp_wf_stack + if (fx%state_dtd==ST_DTD_SUBSET) & + declSepValue = size(wf_stack) + endif + else + ! Expand the entity, + if (present(startEntity_handler)) then + call startEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", nullURI, .false.) + call open_new_string(fb, & + expand_entity(fx%xds%PEList, str_varstr(fx%token)), str_varstr(fx%token), baseURI=nullURI, pe=.true.) +#else + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", null(), .false.) + call open_new_string(fb, & + expand_entity(fx%xds%PEList, str_varstr(fx%token)), str_varstr(fx%token), baseURI=null(), pe=.true.) +#endif + ! NB because we are just expanding a string here, anything + ! evaluated as a result of this string is evaluated in the + ! context of the currently open file, so has a baseURI of + ! this file + allocate(temp_wf_stack(size(wf_stack)+1)) + temp_wf_stack = (/0, wf_stack/) + deallocate(wf_stack) + wf_stack => temp_wf_stack + if (fx%state_dtd==ST_DTD_SUBSET) & + declSepValue = size(wf_stack) + endif + ! and do nothing else, carry on ... + else + ! Have we previously skipped an external entity? + if (fx%skippedExternal.and..not.fx%xds%standalone) then + if (processDTD) then + if (present(skippedEntity_handler)) then + call skippedEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + endif + else + ! If not, + call add_error(fx%error_stack, & + "Reference to undeclared parameter entity.") + goto 100 + endif + endif + nextState = ST_IN_SUBSET + + end select + + end select + + if (nextState/=ST_NULL) then + fx%state = nextState + else + call add_error(fx%error_stack, "Internal error in parser - no suitable token found.") + goto 100 + endif + + end do + +100 continue + if (in_error(fx%error_stack)) call add_error_position(fx%error_stack, fb) + if (associated(tempString)) deallocate(tempString) + if (associated(tempString2)) deallocate(tempString2) + if (associated(extSubsetURI)) call destroyURI(extSubsetURI) + call destroy_string_list(id_list) + call destroy_string_list(idref_list) + deallocate(wf_stack) + if (associated(extEntStack)) deallocate(extEntStack) + + if (fx%state==ST_STOP) return + if (.not.eof) then + ! We have encountered an error before the end of a file + if (.not.reading_main_file(fb)) then !we are parsing an entity + if (inExtSubset) then + call add_error(fx%error_stack, "Error encountered processing external subset.") + else + call add_error(fx%error_stack, "Error encountered processing entity.") + endif + call sax_error(fx, fatalError_handler) + else + call sax_error(fx, fatalError_handler) + endif + else + ! EOF of main file + if (startInChardata_) then + if (fx%well_formed) then + !Note: it used to be as follows: + !if (fx%state==ST_CHAR_IN_CONTENT.and.associated(fx%token%data)) then + !It is probably safe now not to check if token%data is allocated, as in case it is not, + !token%length should be -1... but if it crashes, you know the culprit. + if (fx%state==ST_CHAR_IN_CONTENT) then + if (varstr_len(fx%token)>0.and.present(characters_handler)) & + call characters_handler(str_varstr(fx%token)) + endif + else + if (present(fatalError_handler)) & + call fatalError_handler("Ill-formed XML fragment") + endif + elseif (fx%well_formed.and.fx%state==ST_MISC) then + if (present(endDocument_handler)) & + call endDocument_handler() + else + call add_error(fx%error_stack, "File is not well-formed") + call sax_error(fx, fatalError_handler) + endif + endif + + contains + + subroutine parseDTD + + integer :: nextDTDState +#ifdef PGF90 + type(element_t), pointer :: nullElement + + nullElement => null() +#endif + + nextDTDState = ST_DTD_NULL + + select case (fx%state_dtd) + + case (ST_DTD_SUBSET) + !write(*,*) "ST_DTD_SUBSET" + select case (fx%tokenType) + case (TOK_CLOSE_SB) + if (.not.reading_main_file(fb)) then + call add_error(fx%error_stack, "Cannot close DOCTYPE in external entity") + return + endif + wf_stack(1) = wf_stack(1) - 1 + fx%inIntSubset = .false. + nextState = ST_CLOSE_DOCTYPE + nextDTDState = ST_DTD_DONE + case (TOK_SECTION_END) + if (wf_stack(1)==0) then + call add_error(fx%error_stack, "Unbalanced conditional section in parameter entity") + return + endif + wf_stack(1) = wf_stack(1) - 2 + nextDTDState = ST_DTD_SUBSET + case (TOK_PI_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextDTDState = ST_DTD_START_PI + case (TOK_BANG_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextDTDState = ST_DTD_BANG_TAG + case default + call add_error(fx%error_stack, "Unexpected token in document subset") + return + end select + + + case (ST_DTD_BANG_TAG) + !write(*,*) 'ST_DTD_BANG_TAG' + select case (fx%tokenType) + case (TOK_OPEN_SB) + nextDTDState = ST_DTD_START_SECTION_DECL + case (TOK_OPEN_COMMENT) + nextDTDState = ST_DTD_START_COMMENT + case (TOK_NAME) + if (equal_varstr_str(fx%token,'ATTLIST')) then + nextDTDState = ST_DTD_ATTLIST + elseif (equal_varstr_str(fx%token,'ELEMENT')) then + nextDTDState = ST_DTD_ELEMENT + elseif (equal_varstr_str(fx%token,'ENTITY')) then + nextDTDState = ST_DTD_ENTITY + elseif (equal_varstr_str(fx%token,'NOTATION')) then + nextDTDState = ST_DTD_NOTATION + endif + end select + + case (ST_DTD_START_SECTION_DECL) + !write(*,*) "ST_DTD_START_SECTION_DECL" + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,"IGNORE")) then + if (fx%context/=CTXT_IN_DTD.or.reading_main_file(fb)) then + call add_error(fx%error_stack, "IGNORE section only allowed in external subset.") + return + else + ignoreDepth = 0 + fx%context = CTXT_IGNORE + nextDTDState = ST_DTD_FINISH_SECTION_DECL + endif + elseif (equal_varstr_str(fx%token,"INCLUDE")) then + if (fx%context/=CTXT_IN_DTD.or.reading_main_file(fb)) then + call add_error(fx%error_stack, "INCLUDE section only allowed in external subset.") + return + else + nextDTDState = ST_DTD_FINISH_SECTION_DECL + endif + else + call add_error(fx%error_stack, "Unknown keyword found in marked section declaration.") + endif + end select + + + case (ST_DTD_FINISH_SECTION_DECL) + !write(*,*) "ST_FINISH_SECTION_DECL" + select case (fx%tokenType) + case (TOK_OPEN_SB) + wf_stack(1) = wf_stack(1) + 1 + if (fx%context==CTXT_IGNORE) then + nextDTDState = ST_DTD_IN_IGNORE_SECTION + ignoreDepth = ignoreDepth + 1 + else + nextDTDState = ST_DTD_SUBSET + endif + end select + + + case (ST_DTD_IN_IGNORE_SECTION) + !write(*,*) "ST_IN_IGNORE_SECTION" + select case (fx%tokenType) + case (TOK_SECTION_START) + wf_stack(1) = wf_stack(1) + 2 + ignoreDepth = ignoreDepth + 1 + nextDTDState = ST_DTD_IN_IGNORE_SECTION + case (TOK_SECTION_END) + wf_stack(1) = wf_stack(1) - 2 + ignoreDepth = ignoreDepth - 1 + if (ignoreDepth==0) then + fx%context = CTXT_IN_DTD + nextDTDState = ST_DTD_SUBSET + else + nextDTDState = ST_DTD_IN_IGNORE_SECTION + endif + end select + + case (ST_DTD_START_PI) + !write(*,*)'ST_DTD_START_PI' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (nameOk) then + if (equal_varstr_str(fx%token,'xml')) then + call add_error(fx%error_stack, "XML declaration must be at start of document") + return + elseif (checkPITarget(str_varstr(fx%token), fx%xds%xml_version)) then + nextDTDState = ST_DTD_PI_CONTENTS + call move_varstr_varstr(fx%token,fx%name) + else + call add_error(fx%error_stack, "Invalid PI target name") + return + endif + endif + end select + + case (ST_DTD_PI_CONTENTS) + !write(*,*)'ST_DTD_PI_CONTENTS' + if (validCheck) then + if (fx%context==CTXT_IN_DTD.and.wf_stack(1)==0) then + call add_error(fx%error_stack, & + "PI not balanced in parameter entity") + return + endif + if (len(fx%elstack)>0) then + elem => & + get_element(fx%xds%element_list, get_top_elstack(fx%elstack)) + if (associated(elem)) then + if (elem%empty) then + call add_error(fx%error_stack, "Content inside empty element") + endif + endif + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case(fx%tokenType) + case (TOK_CHAR) + if (present(processingInstruction_handler)) then + call processingInstruction_handler(str_varstr(fx%name), str_varstr(fx%token)) + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_PI_END + case (TOK_PI_END) + if (present(processingInstruction_handler)) then + call processingInstruction_handler(str_varstr(fx%name), '') + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_PI_END) + !write(*,*)'ST_DTD_PI_END' + select case(fx%tokenType) + case (TOK_PI_END) + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_START_COMMENT) + !write(*,*)'ST_DTD_START_COMMENT' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_COMMENT_END + end select + + case (ST_DTD_COMMENT_END) + !write(*,*)'ST_DTD_COMMENT_END' + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "Comment not balanced in entity") + return + endif + if (len(fx%elstack)>0) then + elem => & + get_element(fx%xds%element_list, get_top_elstack(fx%elstack)) + if (associated(elem)) then + if (elem%empty) then + call add_error(fx%error_stack, "Content inside empty element") + endif + endif + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case (fx%tokenType) + case (TOK_COMMENT_END) + if (present(comment_handler)) then + call comment_handler(str_varstr(fx%name)) + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_ATTLIST) + !write(*,*) 'ST_DTD_ATTLIST' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid element name for ATTLIST") + return + endif + if (existing_element(fx%xds%element_list, str_varstr(fx%token))) then + elem => get_element(fx%xds%element_list, str_varstr(fx%token)) + else + elem => add_element(fx%xds%element_list, str_varstr(fx%token)) + endif + nextDTDState = ST_DTD_ATTLIST_CONTENTS + end select + + case (ST_DTD_ATTLIST_CONTENTS) + !write(*,*) 'ST_DTD_ATTLIST_CONTENTS' + select case (fx%tokenType) + case (TOK_ENTITY) + !Weve found a PEref in the middle of the element contents + ! Leave DTD state as it is & expand the entity ... + nextState = ST_START_PE + case (TOK_DTD_CONTENTS) + if (processDTD) then + call parse_dtd_attlist(str_varstr(fx%token), fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, elem, & + internal=reading_main_file(fb)) + else +#ifdef PGF90 + call parse_dtd_attlist(str_varstr(fx%token), fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, nullElement, & + internal=reading_main_file(fb)) +#else + call parse_dtd_attlist(str_varstr(fx%token), fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, null(), & + internal=reading_main_file(fb)) +#endif + endif + if (in_error(fx%error_stack)) return + ! Normalize attribute values in attlist + if (processDTD) then + do i = 1, size(elem%attlist%list) + if (associated(elem%attlist%list(i)%default)) then + tempString => elem%attlist%list(i)%default + elem%attlist%list(i)%default => & + normalize_attribute_text(fx, tempString, fb) + deallocate(tempString) + if (in_error(fx%error_stack)) return + endif + enddo + endif + nextDTDState = ST_DTD_ATTLIST_END + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ATTLIST not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + call parse_dtd_attlist("", fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, elem, & + internal=reading_main_file(fb)) + else +#ifdef PGF90 + call parse_dtd_attlist("", fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, nullElement, & + internal=reading_main_file(fb)) +#else + call parse_dtd_attlist("", fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, null(), & + internal=reading_main_file(fb)) +#endif + endif + if (in_error(fx%error_stack)) return + if (processDTD) then + if (present(attributeDecl_handler)) then + call report_declarations(elem, attributeDecl_handler) + if (fx%state==ST_STOP) return + endif + endif + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_ATTLIST_END) + !write(*,*) 'ST_DTD_ATTLIST_END' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ATTLIST not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + if (present(attributeDecl_handler)) then + call report_declarations(elem, attributeDecl_handler) + if (fx%state==ST_STOP) return + endif + endif + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_ELEMENT) + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid name for ELEMENT") + return + endif + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_ELEMENT_CONTENTS + end select + + case (ST_DTD_ELEMENT_CONTENTS) + !write(*,*)'ST_DTD_ELEMENT_CONTENTS' + select case (fx%tokenType) + case (TOK_OPEN_PAR) + ! increment well_formedness + wf_stack(1) = wf_stack(1) + 1 + nextDTDState = ST_DTD_ELEMENT_CONTENTS + case (TOK_CLOSE_PAR) + ! increment well_formedness + wf_stack(1) = wf_stack(1) - 1 + nextDTDState = ST_DTD_ELEMENT_CONTENTS + case (TOK_ENTITY) + !Weve found a PEref in the middle of the element contents + ! Leave DTD state as it is & expand the entity ... + nextState = ST_START_PE + case (TOK_DTD_CONTENTS) + if (declared_element(fx%xds%element_list, str_varstr(fx%name))) then + if (validCheck) then + call add_error(fx%error_stack, "Duplicate Element declaration") + return + else + ! Ignore contents ... + elem => null() + endif + elseif (processDTD) then + if (existing_element(fx%xds%element_list, str_varstr(fx%name))) then + elem => get_element(fx%xds%element_list, str_varstr(fx%name)) + else + elem => add_element(fx%xds%element_list, str_varstr(fx%name)) + endif + else + elem => null() + endif + call parse_dtd_element(str_varstr(fx%token), fx%xds%xml_version, fx%error_stack, & + elem, reading_main_file(fb)) + if (in_error(fx%error_stack)) return + nextDTDState = ST_DTD_ELEMENT_END + end select + + case (ST_DTD_ELEMENT_END) + !write(*,*)'ST_DTD_ELEMENT_END' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ELEMENT not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD.and.associated(elem)) then + if (present(elementDecl_handler)) then + call elementDecl_handler(str_varstr(fx%name), str_vs(elem%model)) + if (fx%state==ST_STOP) return + endif + endif + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_ENTITY) + !write(*,*) 'ST_DTD_ENTITY' + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,"%")) then + pe = .true. + ! this will be a PE + nextDTDState = ST_DTD_ENTITY_PE + else + pe = .false. + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Illegal name for general entity") + return + endif + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_ENTITY_ID + endif + end select + + case (ST_DTD_ENTITY_PE) + !write(*,*) 'ST_DTD_ENTITY_PE' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Illegal name for parameter entity") + return + endif + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_ENTITY_ID + end select + + case (ST_DTD_ENTITY_ID) + !write(*,*) 'ST_DTD_ENTITY_ID' + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,"PUBLIC")) then + nextDTDState = ST_DTD_ENTITY_PUBLIC + elseif (equal_varstr_str(fx%token,"SYSTEM")) then + nextDTDState = ST_DTD_ENTITY_SYSTEM + else + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + endif + case (TOK_CHAR) + if (reading_main_file(fb)) then + tempString => vs_varstr_alloc(fx%token) + else + tempString2 => vs_varstr_alloc(fx%token) + tempString => expand_pe_text(fx, tempString2, fb) + deallocate(tempString2) + endif + tempString2 => expand_entity_value_alloc(tempString, fx%xds, fx%error_stack) + call varstr_vs( fx%attname, tempString2 ) + deallocate(tempString2) + if (reading_main_file(fb)) then + tempString => null() + else + deallocate(tempString) + endif + if (in_error(fx%error_stack)) return + nextDTDState = ST_DTD_ENTITY_END + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_PUBLIC) + !write(*,*) 'ST_DTD_ENTITY_PUBLIC' + select case (fx%tokenType) + case (TOK_CHAR) + if (checkPublicId(str_varstr(fx%token))) then + call move_varstr_varstr(fx%token,fx%publicId) + nextDTDState = ST_DTD_ENTITY_SYSTEM + else + call add_error(fx%error_stack, "Invalid PUBLIC id in ENTITY") + return + endif + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_SYSTEM) + !write(*,*) 'ST_DTD_ENTITY_SYSTEM' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%systemId) + nextDTDState = ST_DTD_ENTITY_NDATA + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_NDATA) + !write(*,*) 'ST_DTD_ENTITY_NDATA' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ENTITY not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + call add_entity + if (in_error(fx%error_stack)) return + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + call set_varstr_null(fx%attname) + call set_varstr_null(fx%systemId) + call set_varstr_null(fx%publicId) + call set_varstr_null(fx%Ndata) + nextDTDState = ST_DTD_SUBSET + case (TOK_NAME) + if (equal_varstr_str(fx%token,'NDATA')) then + if (pe) then + call add_error(fx%error_stack, "Parameter entity cannot have NDATA declaration") + return + endif + nextDTDState = ST_DTD_ENTITY_NDATA_VALUE + else + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + endif + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_NDATA_VALUE) + !write(*,*) 'ST_DTD_ENTITY_NDATA_VALUE' + !check is a name and exists in notationlist + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid name for Notation") + return + endif + call move_varstr_varstr(fx%token,fx%Ndata) + nextDTDState = ST_DTD_ENTITY_END + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_END) + !write(*,*) 'ST_DTD_ENTITY_END' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ENTITY not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + call add_entity + if (in_error(fx%error_stack)) return + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + call set_varstr_null(fx%attname) + call set_varstr_null(fx%systemId) + call set_varstr_null(fx%publicId) + call set_varstr_null(fx%Ndata) + nextDTDState = ST_DTD_SUBSET + case default + call add_error(fx%error_stack, "Unexpected token at end of ENTITY") + return + end select + + case (ST_DTD_NOTATION) + !write(*,*) 'ST_DTD_NOTATION' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid name for Notation") + return + endif + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_NOTATION_ID + case default + call add_error(fx%error_stack, "Unexpected token in NOTATION") + return + end select + + case (ST_DTD_NOTATION_ID) + !write(*,*)'ST_DTD_NOTATION_ID' + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,'SYSTEM')) then + nextDTDState = ST_DTD_NOTATION_SYSTEM + elseif (equal_varstr_str(fx%token,'PUBLIC')) then + nextDTDState = ST_DTD_NOTATION_PUBLIC + else + call add_error(fx%error_stack, "Unexpected token after NOTATION") + return + endif + case default + call add_error(fx%error_stack, "Unexpected token after NOTATION") + return + end select + + case (ST_DTD_NOTATION_SYSTEM) + !write(*,*)'ST_DTD_NOTATION_SYSTEM' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%systemId) + nextDTDState = ST_DTD_NOTATION_END + case default + call add_error(fx%error_stack, "Unexpected token in NOTATION") + return + end select + + case (ST_DTD_NOTATION_PUBLIC) + !write(*,*)'ST_DTD_NOTATION_PUBLIC' + select case (fx%tokenType) + case (TOK_CHAR) + if (checkPublicId(str_varstr(fx%token))) then + call move_varstr_varstr(fx%token,fx%publicId) + nextDTDState = ST_DTD_NOTATION_PUBLIC_2 + else + call add_error(fx%error_stack, "Invalid PUBLIC id in NOTATION") + return + endif + case default + call add_error(fx%error_stack, "Unexpected token in NOTATION") + return + end select + + case (ST_DTD_NOTATION_PUBLIC_2) + !write(*,*)'ST_DTD_NOTATION_PUBLIC_2' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "NOTATION not balanced in parameter entity") + return + endif + if (notation_exists(fx%nlist, str_varstr(fx%name))) then + call add_error(fx%error_stack, "Duplicate notation declaration") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + call add_notation(fx%nlist, str_varstr(fx%name), publicId=str_varstr(fx%publicId)) + if (present(notationDecl_handler)) then + call notationDecl_handler(str_varstr(fx%name), publicId=str_varstr(fx%publicId), systemId="") + if (fx%state==ST_STOP) return + endif + endif + call set_varstr_null(fx%name) + call set_varstr_null(fx%publicId) + nextDTDState = ST_DTD_SUBSET + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%systemId) + nextDTDState = ST_DTD_NOTATION_END + end select + + case (ST_DTD_NOTATION_END) + !write(*,*)'ST_DTD_NOTATION_END' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "NOTATION not balanced in parameter entity") + return + endif + if (notation_exists(fx%nlist, str_varstr(fx%name))) then + call add_error(fx%error_stack, "Duplicate notation declaration") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + URIref => parseURI(str_varstr(fx%systemId)) + if (.not.associated(URIref)) then + call add_error(fx%error_stack, "Invalid SYSTEM literal") + return + endif + if (hasFragment(URIref)) then + call destroyURI(URIref) + call add_error(fx%error_stack, "SYSTEM literal may not contain fragment") + return + endif + ! We aren't ever going to do anything with this URI, + ! since we don't do NOTATIONs. + ! Throw it away again + call destroyURI(URIref) + if (.not.is_varstr_null(fx%publicId)) then + call add_notation(fx%nlist, str_varstr(fx%name), & + publicId=str_varstr(fx%publicId), systemId=str_varstr(fx%systemId)) + if (present(notationDecl_handler)) then + call notationDecl_handler(str_varstr(fx%name), & + publicId=str_varstr(fx%publicId), systemId=str_varstr(fx%systemId)) + if (fx%state==ST_STOP) return + endif + else + call add_notation(fx%nlist, str_varstr(fx%name), & + systemId=str_varstr(fx%systemId)) + if (present(notationDecl_handler)) then + call notationDecl_handler(str_varstr(fx%name), & + publicId="", systemId=str_varstr(fx%systemId)) + if (fx%state==ST_STOP) return + endif + endif + endif + call set_varstr_null(fx%publicId) + call set_varstr_null(fx%systemId) + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_SUBSET + case default + call add_error(fx%error_stack, "Unexpected token in NOTATION") + return + end select + + end select + + if (nextDTDState==ST_DTD_NULL) then + call add_error(fx%error_stack, & + "Bad token found in DTD parsing") + else + fx%state_dtd = nextDTDState + endif + if (nextState==ST_NULL) & + nextState = ST_IN_SUBSET + + end subroutine parseDTD + + subroutine open_tag + elem => get_element(fx%xds%element_list, str_varstr(fx%name)) + if (associated(elem)) then + if (validCheck) then + call checkAttributes(elem, fx%attributes) + if (.not.checkContentModel(fx%elstack, str_varstr(fx%name))) then + call add_error(fx%error_stack, & + "Element '"//str_varstr(fx%name)//"' not permitted in this context") + return + endif + else + call getDefaultAttributes(elem, fx%attributes) + endif + else + if (validCheck) then + call add_error(fx%error_stack, & + "Trying to use an unrecognised element '"//str_varstr(fx%name)//"'") + return + endif + endif + ! Check for namespace changes + if (namespaces_) then + call checkNamespaces(fx%attributes, fx%nsDict, & + len(fx%elstack), fx%xds, namespace_prefixes_, xmlns_uris_, & + fx%error_stack, startInCharData_, & + startPrefixMapping_handler, endPrefixMapping_handler) + if (fx%state==ST_STOP) return + endif + if (in_error(fx%error_stack)) return + call checkXmlAttributes + if (in_error(fx%error_stack)) return + if (size(extEntStack)>0) then + if (len(fx%elstack)==extEntStack(1)) & + ! This is a top-level element in the current entity + call setBase(fx%attributes, expressURI(fb%f(1)%baseURI)) + endif + if (namespaces_.and.getURIofQName(fx,str_varstr(fx%name))==invalidNS) then + ! no namespace was found for the current element + if (.not.startInCharData_) then + ! but we ignore this if we are parsing an entity through DOM + call add_error(fx%error_stack, "No namespace found for current element '"//str_varstr(fx%name)//"'") + return + elseif (present(startElement_handler)) then + ! Record it as having an empty URI + call startElement_handler("", & + getlocalNameofQName(str_varstr(fx%name)), & + str_varstr(fx%name), fx%attributes) + if (fx%state==ST_STOP) return + endif + elseif (namespaces_) then + ! Normal state of affairs + if (present(startElement_handler)) then + call startElement_handler(getURIofQName(fx, str_varstr(fx%name)), & + getlocalNameofQName(str_varstr(fx%name)), & + str_varstr(fx%name), fx%attributes) + if (fx%state==ST_STOP) return + endif + else + ! Non-namespace aware processing + if (present(startElement_handler)) then + call startElement_handler("", "", & + str_varstr(fx%name), fx%attributes) + if (fx%state==ST_STOP) return + endif + endif + if (validCheck) then + call push_elstack(fx%elstack, str_varstr(fx%name), elem%cp) + else + call push_elstack(fx%elstack, str_varstr(fx%name)) + endif + call reset_dict(fx%attributes) + end subroutine open_tag + + subroutine close_tag + character :: dummy + wf_stack(1) = wf_stack(1) - 1 + if (wf_stack(1)<0) then + call add_error(fx%error_stack, & + 'Ill-formed entity') + return + endif + if (str_varstr(fx%name)/=get_top_elstack(fx%elstack)) then + call add_error(fx%error_stack, & + "Mismatching close tag: trying to close entity '"//get_top_elstack(fx%elstack) & + //"' with '"//str_varstr(fx%name)//"'") + return + endif + if (validCheck) then + if (.not.checkContentModelToEnd(fx%elstack)) then + call add_error(fx%error_stack, & + "Failed to fulfil content model for "//str_varstr(fx%name)) + return + endif + endif + dummy = pop_elstack(fx%elstack) + if (present(endElement_handler)) then + if (namespaces_.and.getURIofQName(fx,str_varstr(fx%name))==invalidNS) then + ! no namespace was found for the current element, we must be + ! closing inside a DOM entity. + ! Record it as having an empty URI + call endElement_handler("", & + getlocalNameofQName(str_varstr(fx%name)), & + str_varstr(fx%name)) + elseif (namespaces_) then + ! Normal state of affairs + call endElement_handler(getURIofQName(fx, str_varstr(fx%name)), & + getlocalnameofQName(str_varstr(fx%name)), & + str_varstr(fx%name)) + else + ! Non-namespace-aware processing: + call endElement_handler("", "", & + str_varstr(fx%name)) + endif + if (fx%state==ST_STOP) return + endif + if (namespaces_) then + call checkEndNamespaces(fx%nsDict, len(fx%elstack), & + endPrefixMapping_handler) + if (fx%state==ST_STOP) return + endif + end subroutine close_tag + + subroutine add_entity + !Parameter or General Entity? + logical :: wfc + wfc = fb%f(1)%pe.or.inExtSubset + if (pe) then + !Does entity with this name exist? + if (.not.existing_entity(fx%xds%PEList, str_varstr(fx%name))) then + ! Internal or external? + if (.not.is_varstr_null(fx%attname)) then ! it's internal + call register_internal_PE(fx%xds, & + name=str_varstr(fx%name), text=str_varstr(fx%attname), & + wfc=wfc, baseURI=copyURI(fb%f(1)%baseURI)) + ! FIXME need to expand value here before reporting ... + if (present(internalEntityDecl_handler)) then + call internalEntityDecl_handler('%'//str_varstr(fx%name), str_varstr(fx%attname)) + if (fx%state==ST_STOP) return + endif + else ! PE can't have Ndata declaration + URIref => parseURI(str_varstr(fx%systemId)) + if (.not.associated(URIref)) then + call add_error(fx%error_stack, "Invalid URI specified for SYSTEM") + elseif (hasFragment(URIref)) then + call add_error(fx%error_stack, "Fragment not permitted on SYSTEM URI") + call destroyURI(URIref) + else + newURI => rebaseURI(fb%f(1)%baseURI, URIref) + call destroyURI(URIref) + if (.not.is_varstr_null(fx%publicId)) then + call register_external_PE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId), & + wfc=wfc, baseURI=newURI) + if (present(externalEntityDecl_handler)) & + call externalEntityDecl_handler('%'//str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId)) + else + call register_external_PE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), & + wfc=wfc, baseURI=newURI) + if (present(externalEntityDecl_handler)) & + call externalEntityDecl_handler('%'//str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId="") + endif + endif + endif + ! else we ignore it + endif + else !It's a general entity + if (.not.existing_entity(fx%xds%entityList, str_varstr(fx%name))) then + ! Internal or external? + if (.not.is_varstr_null(fx%attname)) then ! it's internal + call register_internal_GE(fx%xds, name=str_varstr(fx%name), & + text=str_varstr(fx%attname), & + wfc=wfc, baseURI=copyURI(fb%f(1)%baseURI)) + if (present(internalEntityDecl_handler)) then + call internalEntityDecl_handler(str_varstr(fx%name),& + str_varstr(fx%attname)) + if (fx%state==ST_STOP) return + endif + else + URIref => parseURI(str_varstr(fx%systemId)) + if (.not.associated(URIref)) then + call add_error(fx%error_stack, "Invalid URI specified for SYSTEM") + elseif (hasFragment(URIref)) then + call add_error(fx%error_stack, "Fragment not permitted on SYSTEM URI") + call destroyURI(URIref) + else + newURI => rebaseURI(fb%f(1)%baseURI, URIref) + call destroyURI(URIref) + if ((.not.is_varstr_null(fx%publicId)).and.(.not.is_varstr_null(fx%Ndata))) then + call register_external_GE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId), & + notation=str_varstr(fx%Ndata), & + wfc=wfc, baseURI=newURI) + if (present(unparsedEntityDecl_handler)) & + call unparsedEntityDecl_handler(str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId), & + notation=str_varstr(fx%Ndata)) + elseif (.not.is_varstr_null(fx%Ndata)) then + call register_external_GE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), notation=str_varstr(fx%Ndata), & + wfc=wfc, baseURI=newURI) + if (present(unparsedEntityDecl_handler)) & + call unparsedEntityDecl_handler(str_varstr(fx%name), publicId="", & + systemId=str_varstr(fx%systemId), notation=str_varstr(fx%Ndata)) + elseif (.not.is_varstr_null(fx%publicId)) then + call register_external_GE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId), & + wfc=wfc, baseURI=newURI) + if (present(externalEntityDecl_handler)) & + call externalEntityDecl_handler(str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId)) + else + call register_external_GE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), wfc=wfc, baseURI=newURI) + if (present(externalEntityDecl_handler)) & + call externalEntityDecl_handler(str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId="") + endif + endif + endif + endif + endif + end subroutine add_entity + + subroutine getDefaultAttributes(el, dict) + type(element_t), pointer :: el + type(dictionary_t), intent(inout) :: dict + + type(attribute_t), pointer :: att + integer :: i, ind + character, pointer :: attValue(:) + + do i = 1, size(el%attlist%list) + att => el%attlist%list(i) + call get_att_index_pointer(dict, str_vs(att%name), ind, attValue) + if (.not.associated(attValue)) then + if (att%attDefault==ATT_DEFAULT & + .or.att%attDefault==ATT_FIXED) then + call add_item_to_dict(dict, & + str_vs(att%name), str_vs(att%default), & + specified=.false., declared=.true.) + endif + endif + end do + end subroutine getDefaultAttributes + + subroutine checkAttributes(el, dict) + type(element_t), pointer :: el + type(dictionary_t), intent(inout) :: dict + + integer :: i, j + + type(attribute_t), pointer :: att + type(string_list) :: s_list + character, pointer :: attValue(:), s(:) + + integer :: ind + logical, allocatable :: attributesLeft(:) + allocate(attributesLeft(getLength(dict))) + attributesLeft = .true. + + do i = 1, size(el%attlist%list) + att => el%attlist%list(i) + call get_att_index_pointer(dict, str_vs(att%name), ind, attValue) + if (associated(attValue)) attributesLeft(ind) = .false. + select case(att%attDefault) + case (ATT_REQUIRED, ATT_IMPLIED, ATT_DEFAULT) + if (.not.associated(attValue)) then + if (att%attDefault==ATT_REQUIRED) then + ! Validity Constraint: Required Attribute + call add_error(fx%error_stack, & + "REQUIRED attribute "//str_vs(att%name)//" not present") + return + elseif (att%attDefault==ATT_DEFAULT) then + if (fx%xds%standalone.and..not.att%internal) then + ! VC: Standalone document declaration" + call add_error(fx%error_stack, & + "Externally-specifid default attribute used in non-standalone document") + return + else + call add_item_to_dict(dict, & + str_vs(att%name), str_vs(att%default), & + specified=.false., declared=.true.) + endif + endif + else + select case(att%attType) + case (ATT_ID) + ! VC: ID + if (namespaces_) then + nameOk = checkNCName(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkName(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type ID must have a value which is an XML Name") + return + endif + if (registered_string(id_list, str_vs(attValue))) then + call add_error(fx%error_stack, & + "Cannot declare the same ID twice") + return + endif + call add_string(id_list, str_vs(attValue)) + call setIsId(dict, ind, .true.) + ! We don't need to check for duplicate ID & xml:ids on the same + ! element - if we are validating we'd already have noticed, + ! if we're not, it's not possible + case (ATT_IDREF) + ! VC: IDREF + if (namespaces_) then + nameOk = checkNCName(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkName(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type IDREF must have a value which is an XML Name") + return + endif + ! FIXME in a namespaced document they must match QName + if (.not.registered_string(idref_list, str_vs(attValue))) & + call add_string(idref_list, str_vs(attValue)) + case (ATT_IDREFS) + ! VC: IDREF + if (namespaces_) then + nameOk = checkNCNames(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkNames(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type IDREFS must have a value which contains only XML Names") + return + endif + call tokenize_and_add_strings(idref_list, str_vs(attValue), .true.) + case (ATT_ENTITY) + ! VC: Entity Name + if (namespaces_) then + nameOk = checkNCName(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkName(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type ENTITY must have a value which is an XML Name") + return + endif + ent => getEntityByName(fx%xds%entityList, str_vs(attValue)) + if (associated(ent)) then + if (.not.is_unparsed_entity(ent)) then + ! Validity Constraint: Entity Name + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENTITY refers to parsed entity") + return + endif + else + ! Validity Constraint: Entity Name + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENTITY refers to non-existent entity") + return + endif + case (ATT_ENTITIES) + ! VC: Entity Name + if (namespaces_) then + nameOk = checkNCNames(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkNames(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type ENTITIES must have a value which contains only XML Names") + return + endif + s_list = tokenize_to_string_list(str_vs(attValue)) + do j = 1, size(s_list%list) + s => s_list%list(j)%s + ent => getEntityByName(fx%xds%entityList, str_vs(s)) + if (associated(ent)) then + if (.not.is_unparsed_entity(ent)) then + ! Validity Constraint: Entity Name + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENTITIES refers to parsed entity "& + //str_vs(s)) + call destroy_string_list(s_list) + return + endif + else + ! Validity Constraint: Entity Name + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENTITIES refers to non-existent entity "& + //str_vs(s)) + call destroy_string_list(s_list) + return + endif + enddo + call destroy_string_list(s_list) + case (ATT_NMTOKEN) + ! VC Name Token + if (.not.checkNmtoken(str_vs(attValue), fx%xds%xml_version)) then + call add_error(fx%error_stack, & + "Attributes of type NMTOKEN must have a value which is a NMTOKEN") + return + endif + case (ATT_NMTOKENS) + ! VC: Name Token + if (.not.checkNmtokens(str_vs(attValue), fx%xds%xml_version)) then + call add_error(fx%error_stack, & + "Attributes of type NMTOKENS must have a value which contain only NMTOKENs") + return + endif + case (ATT_NOTATION) + ! VC: Notation Attributes + if (namespaces_) then + nameOk = checkNCName(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkName(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type NOTATION must have a value which is an XML Name") + return + endif + if (.not.notation_exists(fx%nlist, str_vs(attValue))) then + ! Validity Constraint: Notation Attributes + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" declared as NOTATION refers to non-existent notation "& + //str_vs(attValue)) + return + endif + if (att%attDefault==ATT_REQUIRED) then + if (.not.registered_string(att%enumerations, str_vs(attValue))) & + call add_error(fx%error_stack, & + "NOTATION attribute is not among declared values.") + endif + case (ATT_ENUM) + ! VC: Notation Attributes + if (.not.checkNmtoken(str_vs(attValue), fx%xds%xml_version)) then + call add_error(fx%error_stack, & + "Attributes of type ENUM must have a value which is an NMTOKEN") + return + endif + if (.not.registered_string(att%enumerations, str_vs(attValue))) then + ! Validity Constraint: Enumeration + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENUM refers to undeclared enumeration "& + //str_vs(attValue)) + return + endif + end select + endif + case (ATT_FIXED) + if (associated(attValue)) then + if (str_vs(att%default)//"x"/=str_vs(attValue)//"x") then + ! Validity Constraint: Fixed Attribute Default + call add_error(fx%error_stack, & + "FIXED attribute has unexpected value." & + //" At Element='"//str_vs(el%name)//"' Attribute='"//str_vs(att%name)//"'" & + //" Expecting '"//str_vs(att%default)//"' Found '"//str_vs(attValue)//"'") + return + endif + else + if (fx%xds%standalone.and..not.att%internal) then + ! VC: Standalone document declaration" + call add_error(fx%error_stack, & + "Externally-specified default attribute used in non-standalone document") + return + else + call add_item_to_dict(dict, & + str_vs(att%name), str_vs(att%default), & + specified=.false., declared=.true.) + endif + endif + end select + enddo + + if (any(attributesLeft)) call add_error(fx%error_stack, "Undeclared attributes forbidden. Element '"//str_vs(el%name)//"'") + + end subroutine checkAttributes + + subroutine checkXMLAttributes + integer :: ind + character, pointer :: attValue(:) + ! These must all be done with the name of the attribute, + ! not the nsURI/localname pair, in case we are + ! processing for a non-namespace aware application + if (has_key(fx%attributes, 'xml:space')) then + if (get_value(fx%attributes, 'xml:space')/='default' & + .and. get_value(fx%attributes, 'xml:space')/='preserve') then + call add_error(fx%error_stack, 'Illegal value of xml:space attribute') + return + endif + endif + call get_att_index_pointer(fx%attributes, "xml:id", ind, attValue) + if (associated(attValue)) then + ! Per xml:id spec, NCName even in non-namespace aware document + if (.not.checkNCName(str_vs(attValue), fx%xds%xml_version)) then + call add_error(fx%error_stack, & + "xml:id attributes must have values which are NCNames") + return + elseif (registered_string(id_list, str_vs(attValue))) then + call add_error(fx%error_stack, & + "xml:id attributes must be unique within a document") + return + endif + call add_string(id_list, str_vs(attValue)) + call setIsId(fx%attributes, ind, .true.) + endif + if (has_key(fx%attributes, "xml:base")) then + URIref => parseURI(get_value(fx%attributes,"xml:base")) + if (.not.associated(URIref)) then + call add_error(fx%error_stack, & + "Invalid URI reference specified for xml:base attribute") + else + call destroyURI(URIref) + endif + endif + !if (has_key(fx%attributes, 'xml:lang')) then + ! We never care about this at the SAX level. + !endif + end subroutine checkXMLAttributes + + subroutine endDTDchecks + type(element_t), pointer :: el + type(attribute_t), pointer :: att + type(entity_t), pointer :: ent + type(string_list) :: s_list + character, pointer :: s(:) + integer :: i, j, k + + if (present(FoX_endDTD_handler)) then + fx%xds_used = .true. + call FoX_endDTD_handler(fx%xds) + endif + if (present(endDTD_handler)) then + call endDTD_handler() + if (fx%state==ST_STOP) return + endif + ! Check that all notations used have been declared: + if (validCheck) then + do i = 1, size(fx%xds%entityList) + ent => getEntityByIndex(fx%xds%entityList, i) + if (str_vs(ent%notation)/="" & + .and..not.notation_exists(fx%nlist, str_vs(ent%notation))) then + ! Validity Constraint: Notation Declared + call add_error(fx%error_stack, "Attempt to use undeclared notation") + exit + endif + enddo + validLoop: do i = 1, size(fx%xds%element_list%list) + el => fx%xds%element_list%list(i) + do j = 1, size(el%attlist%list) + att => el%attlist%list(j) + ! For NOTATION, need to check enumerated as well as default ... + if (att%attType==ATT_NOTATION) then + do k = 1, size(att%enumerations%list) + s => att%enumerations%list(k)%s + if (.not.notation_exists(fx%nlist, str_vs(s))) then + ! Validity Constraint: Notation Attributes + call add_error(fx%error_stack, & + "Enumerated NOTATION in "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" refers to non-existent notation") + call destroy(s_list) + exit validLoop + endif + enddo + if (associated(att%default)) then + s_list = tokenize_to_string_list(str_vs(att%default)) + do k = 1, size(s_list%list) + s => s_list%list(k)%s + if (.not.notation_exists(fx%nlist, str_vs(s))) then + ! Validity Constraint: Notation Attributes + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as NOTATION refers to non-existent notation") + call destroy(s_list) + exit validLoop + endif + enddo + call destroy(s_list) + endif + endif + enddo + enddo validLoop + endif + end subroutine endDTDchecks + + subroutine checkIdRefs + integer :: i + character, pointer :: s(:) + do i = 1, size(idRef_list%list) + s => idRef_list%list(i)%s + if (.not.registered_string(id_list, str_vs(s))) then + call add_error(fx%error_stack, & + "Reference to undeclared ID "//str_vs(s)) + return + endif + enddo + end subroutine checkIdRefs + end subroutine sax_parse + + + subroutine sax_error(fx, error_handler) + type(sax_parser_t), intent(inout) :: fx + optional :: error_handler + interface + subroutine error_handler(msg) + character(len=*), intent(in) :: msg + end subroutine error_handler + end interface + + character, dimension(:), pointer :: errmsg + + integer :: i, m, n, n_err + n = size(fx%error_stack%stack) + n_err = n + + do i = 1, n + n_err = n_err + size(fx%error_stack%stack(i)%msg) ! + spaces + size of entityref + enddo + allocate(errmsg(n_err)) + errmsg = '' + n = 1 + do i = 1, size(fx%error_stack%stack) + m = size(fx%error_stack%stack(i)%msg) + errmsg(n:n+m-1) = fx%error_stack%stack(i)%msg + errmsg(n+m:n+m) = " " + n = n + m + 1 + enddo + ! FIXME put location information in here + if (present(error_handler)) then + call error_handler(str_vs(errmsg)) + deallocate(errmsg) + if (fx%state==ST_STOP) return + else + call FoX_error(str_vs(errmsg)) + endif + + end subroutine sax_error + + pure function URIlength(fx, qname) result(l_u) + type(sax_parser_t), intent(in) :: fx + character(len=*), intent(in) :: qName + integer :: l_u + integer :: n + n = index(QName, ':') + if (n > 0) then + l_u = len(getnamespaceURI(fx%nsDict, QName(1:n-1))) + else + l_u = len(getnamespaceURI(fx%nsDict)) + endif + end function URIlength + + pure function getURIofQName(fx, qname) result(URI) + type(sax_parser_t), intent(in) :: fx + character(len=*), intent(in) :: qName + character(len=URIlength(fx, qname)) :: URI + + integer :: n + n = index(QName, ':') + if (n > 0) then + URI = getnamespaceURI(fx%nsDict, QName(1:n-1)) + else + URI = getnamespaceURI(fx%nsDict) + endif + + end function getURIofQName + + pure function getLocalNameofQName(qname) result(localName) + character(len=*), intent(in) :: qName + character(len=len(QName)-index(QName,':')) :: localName + + localName = QName(index(QName,':')+1:) + end function getLocalNameofQName +#endif + +end module m_sax_parser diff --git a/src/xml/sax/m_sax_reader.F90 b/src/xml/sax/m_sax_reader.F90 new file mode 100644 index 000000000..72fa6584e --- /dev/null +++ b/src/xml/sax/m_sax_reader.F90 @@ -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 diff --git a/src/xml/sax/m_sax_tokenizer.F90 b/src/xml/sax/m_sax_tokenizer.F90 new file mode 100644 index 000000000..59ea631d3 --- /dev/null +++ b/src/xml/sax/m_sax_tokenizer.F90 @@ -0,0 +1,1139 @@ +module m_sax_tokenizer + +#ifndef DUMMYLIB + use fox_m_fsys_array_str, only: vs_str, str_vs, vs_str_alloc + use fox_m_fsys_varstr + + use m_common_charset, only: XML_WHITESPACE, & + upperCase, isInitialNameChar + use m_common_error, only: add_error, in_error + use m_common_entities, only: entity_t, existing_entity, & + expand_entity_text, expand_char_entity, & + add_internal_entity, pop_entity_list, getEntityByName + use m_common_namecheck, only: checkName, checkCharacterEntityReference + + use m_sax_reader, only: file_buffer_t, open_new_file, pop_buffer_stack, & + push_chars, get_character, get_all_characters, & + parse_text_declaration, add_error_position + use m_sax_types ! everything, really +#ifdef PGF90 + use fox_m_utils_uri, only: URI +#endif + + implicit none + private + + public :: sax_tokenize + public :: normalize_attribute_text + public :: expand_pe_text + +contains + + subroutine sax_tokenize(fx, fb, eof) + type(sax_parser_t), intent(inout) :: fx + type(file_buffer_t), intent(inout) :: fb + logical, intent(out) :: eof + + character :: c, q + integer :: xv, phrase + logical :: firstChar, ws_discard + character, pointer :: tempString(:) + + xv = fx%xds%xml_version + + call set_varstr_empty(fx%token) + if (fx%nextTokenType/=TOK_NULL) then + eof = .false. + fx%tokenType = fx%nextTokenType + fx%nextTokenType = TOK_NULL + return + endif + fx%tokentype = TOK_NULL + + q = " " + phrase = 0 + firstChar = .true. + ws_discard = .false. + do + c = get_character(fb, eof, fx%error_stack) + if (eof) then + if (fx%state==ST_CHAR_IN_CONTENT) then + if (phrase==1) then + call append_varstr(fx%token,']') + elseif (phrase==2) then + call append_varstr(fx%token,']]') + endif + fx%tokenType = TOK_CHAR + endif + if (fx%tokenType/=TOK_NULL) then + ! make sure we pass back this token before eof'ing + eof = .false. + return + endif + endif + if (eof.or.in_error(fx%error_stack)) return + if (fx%inIntSubset) then + tempString => fx%xds%intSubset + fx%xds%intSubset => vs_str_alloc(str_vs(tempString)//c) + deallocate(tempString) + endif + + select case (fx%state) + case (ST_MISC) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c, XML_WHITESPACE)>0) then + if (c=="<") then + ws_discard = .false. + else + call add_error(fx%error_stack, "Unexpected character found outside content") + call add_error_position(fx%error_stack,fb) + endif + endif + else + if (c=="?") then + fx%tokenType = TOK_PI_TAG + elseif (c=="!") then + fx%tokenType = TOK_BANG_TAG + elseif (isInitialNameChar(c, xv)) then + call push_chars(fb, c) + fx%tokenType = TOK_OPEN_TAG + else + call add_error(fx%error_stack, "Unexpected character after <") + call add_error_position(fx%error_stack,fb) + endif + endif + + case (ST_BANG_TAG) + if (firstChar) then + if (c=="-") then + phrase = 1 + elseif (c=="[") then + fx%tokenType = TOK_OPEN_SB + elseif (verify(c,upperCase)==0) then + call varstr_str(fx%token,c) + else + call add_error(fx%error_stack, "Unexpected character after 0) then + call append_varstr(fx%token,c) + else + call push_chars(fb, c) + fx%tokenType = TOK_NAME + endif + + case (ST_START_PI) + ! grab until whitespace or ? + if (verify(c, XML_WHITESPACE//"?")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c=="?") call push_chars(fb, c) + endif + + case (ST_PI_CONTENTS) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c, XML_WHITESPACE)/=0) then + ws_discard = .false. + else + cycle + endif + endif + if (phrase==1) then + if (c==">") then + fx%tokenType = TOK_CHAR + fx%nextTokenType = TOK_PI_END + elseif (c=="?") then + ! The last ? didn't mean anything, but this one might. + call append_varstr( fx%token, '?' ) + else + phrase = 0 + call append_varstr( fx%token, '?' ) + call append_varstr( fx%token, c ) + endif + elseif (c=="?") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + + case (ST_START_COMMENT) + select case(phrase) + case (0) + if (c=="-") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + case (1) + if (c=="-") then + phrase = 2 + else + call append_varstr( fx%token, '-' ) + call append_varstr( fx%token, c ) + phrase = 0 + endif + case (2) + if (c==">") then + fx%tokenType = TOK_CHAR + fx%nextTokenType = TOK_COMMENT_END + exit + else + call add_error(fx%error_stack, & + "Expecting > after -- inside a comment.") + call add_error_position(fx%error_stack,fb) + endif + end select + + case (ST_START_TAG) + ! grab until whitespace or /, > + if (verify(c, XML_WHITESPACE//"/>")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c==">") then + fx%nextTokenType = TOK_END_TAG + else + call push_chars(fb, c) + endif + endif + + case (ST_START_CDATA_DECLARATION) + if (firstChar) then + if (verify(c, XML_WHITESPACE)==0) then + call add_error(fx%error_stack, & + "Whitespace not allowed around CDATA in section declaration") + call add_error_position(fx%error_stack,fb) + else + call varstr_str(fx%token, c) + ws_discard = .false. + endif + else + if (verify(c, XML_WHITESPACE)==0) then + call add_error(fx%error_stack, & + "Whitespace not allowed around CDATA in section declaration") + call add_error_position(fx%error_stack,fb) + elseif (c=="[") then + fx%tokenType = TOK_NAME + if (c=="[") fx%nextTokenType = TOK_OPEN_SB + else + call append_varstr( fx%token, c ) + endif + endif + + + case (ST_CDATA_CONTENTS) + select case(phrase) + case (0) + if (c=="]") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + case (1) + if (c=="]") then + phrase = 2 + else + call append_varstr( fx%token, ']' ) + call append_varstr( fx%token, c ) + phrase = 0 + endif + case (2) + if (c==">") then + fx%tokenType = TOK_CHAR + fx%nextTokenType = TOK_SECTION_END + elseif (c=="]") then + call append_varstr( fx%token, ']' ) + else + call append_varstr( fx%token, ']]' ) + call append_varstr( fx%token, c ) + phrase = 0 + endif + end select + + case (ST_IN_TAG) + if (firstChar) then + if (verify(c,XML_WHITESPACE//"/>")>0) then + call add_error(fx%error_stack, & + "Whitespace required inside tag") + call add_error_position(fx%error_stack,fb) + exit + endif + ws_discard = .true. + endif + if (ws_discard) then + if (verify(c,XML_WHITESPACE)>0) then + if (c==">") then + fx%tokenType = TOK_END_TAG + elseif (c=="/") then + phrase = 1 + ws_discard = .false. + else + call varstr_str(fx%token,c) + ws_discard = .false. + endif + endif + else + if (phrase==1) then + if (c==">") then + fx%tokenType = TOK_END_TAG_CLOSE + else + call add_error(fx%error_stack, & + "Unexpected character after '/' ("//c//") in tag for element '"//str_varstr(fx%name)//"'") + call add_error_position(fx%error_stack,fb) + exit + endif + else + if (verify(c,XML_WHITESPACE//"=/>")==0) then + fx%tokenType = TOK_NAME + if (c=="=") then + fx%nextTokenType = TOK_EQUALS + elseif (c==">") then + fx%nextTokenType = TOK_END_TAG + else + call push_chars(fb, c) + endif + else + call append_varstr( fx%token, c ) + endif + endif + endif + + case (ST_ATT_NAME) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c,XML_WHITESPACE)>0) then + if (c=="=") then + fx%tokenType = TOK_EQUALS + else + call add_error(fx%error_stack, & + "Unexpected character in element tag, expected =") + call add_error_position(fx%error_stack,fb) + endif + endif + endif + + case (ST_ATT_EQUALS) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c,XML_WHITESPACE)>0) then + if (verify(c,"'""")==0) then + q = c + ws_discard = .false. + else + call add_error(fx%error_stack, "Expecting "" or '") + call add_error_position(fx%error_stack,fb) + endif + endif + else + if (c==q) then + fx%tokenType = TOK_CHAR + else + call append_varstr( fx%token, c ) + endif + endif + + case (ST_CHAR_IN_CONTENT) + if (c=="<".or.c=="&") then + if (phrase==1) then + call append_varstr( fx%token, ']' ) + elseif (phrase==2) then + call append_varstr( fx%token, ']]' ) + endif + fx%tokenType = TOK_CHAR + if (c=="<") then + call push_chars(fb, c) + elseif (c=="&") then + fx%nextTokenType = TOK_ENTITY + endif + elseif (c=="]") then + if (phrase==0) then + phrase = 1 + elseif (phrase==1) then + phrase = 2 + else + call append_varstr( fx%token, ']' ) + endif + elseif (c==">") then + if (phrase==1) then + phrase = 0 + call append_varstr( fx%token, ']>' ) + elseif (phrase==2) then + call add_error(fx%error_stack, "]]> forbidden in character context") + call add_error_position(fx%error_stack,fb) + else + call append_varstr( fx%token, '>' ) + endif + elseif (phrase==1) then + call append_varstr( fx%token, ']' ) + call append_varstr( fx%token, c ) + phrase = 0 + elseif (phrase==2) then + call append_varstr( fx%token, ']]' ) + call append_varstr( fx%token, c ) + phrase = 0 + else + call append_varstr( fx%token, c ) + endif + + case (ST_TAG_IN_CONTENT) + if (phrase==0) then + if (c=="<") then + phrase = 1 + ws_discard = .false. + elseif (c=="&") then + fx%tokenType = TOK_ENTITY + else + call add_error(fx%error_stack, "Unexpected character found in content") + call add_error_position(fx%error_stack,fb) + endif + elseif (phrase==1) then + if (c=="?") then + fx%tokenType = TOK_PI_TAG + elseif (c=="!") then + fx%tokenType = TOK_BANG_TAG + elseif (c=="/") then + fx%tokenType = TOK_CLOSE_TAG + elseif (isInitialNameChar(c, xv)) then + call push_chars(fb, c) + fx%tokenType = TOK_OPEN_TAG + else + call add_error(fx%error_stack, "Unexpected character after <") + call add_error_position(fx%error_stack,fb) + endif + endif + + case (ST_START_ENTITY) + if (verify(c,XML_WHITESPACE//";")>0) then + call append_varstr( fx%token, c ) + elseif (c==";") then + fx%tokenType = TOK_NAME + else + call add_error(fx%error_stack, "Entity reference must be terminated with a ;") + call add_error_position(fx%error_stack,fb) + endif + + case (ST_CLOSING_TAG) + if (verify(c,XML_WHITESPACE//">")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c==">") fx%nextTokenType = TOK_END_TAG + endif + + case (ST_IN_CLOSING_TAG) + if (verify(c, XML_WHITESPACE)>0) then + if (c==">") then + fx%tokenType = TOK_END_TAG + else + call add_error(fx%error_stack, "Unexpected character - expecting >") + call add_error_position(fx%error_stack,fb) + endif + endif + + case (ST_IN_DOCTYPE, ST_DOC_NAME, ST_DOC_SYSTEM, ST_DOC_PUBLIC, & + ST_DOC_DECL, ST_CLOSE_DOCTYPE) + if (firstChar) then + if (verify(c, XML_WHITESPACE)>0) then + if (c==">") then + fx%tokenType = TOK_END_TAG + elseif (c=="[") then + fx%tokenType = TOK_OPEN_SB + else + call add_error(fx%error_stack, & + "Missing whitespace in doctype delcaration.") + call add_error_position(fx%error_stack,fb) + endif + else + ws_discard = .true. + endif + endif + if (ws_discard) then + if (verify(c, XML_WHITESPACE)>0) then + if (verify(c, "'""")==0) then + q = c + call set_varstr_empty(fx%token) + ws_discard = .false. + elseif (c=="[") then + fx%tokenType = TOK_OPEN_SB + elseif (c==">") then + fx%tokenType = TOK_END_TAG + else + call varstr_str(fx%token, c) + ws_discard = .false. + endif + endif + else + if (q/=" ".and.c==q) then + fx%tokenType = TOK_CHAR + elseif (q==" ".and.verify(c, ">")==0.and.(fx%state==ST_IN_DOCTYPE)) then + fx%nextTokenType = TOK_END_TAG + fx%tokenType = TOK_NAME + elseif (q==" ".and.verify(c, XML_WHITESPACE)==0) then + call push_chars(fb, c) + fx%tokenType = TOK_NAME + else + call append_varstr( fx%token, c ) + endif + endif + + case (ST_IN_SUBSET) + call tokenizeDTD + + case (ST_START_PE) + if (verify(c,XML_WHITESPACE//";")>0) then + call append_varstr( fx%token, c ) + elseif (c==";") then + fx%tokenType = TOK_NAME + else + call add_error(fx%error_stack, "Entity reference must be terminated with a ;") + call add_error_position(fx%error_stack,fb) + endif + + end select + + firstChar = .false. + if (fx%tokenType/=TOK_NULL) exit + enddo + + contains + + subroutine tokenizeDTD + + if (c=="%") then + if (fx%state_dtd==ST_DTD_START_COMMENT & + .or.fx%state_dtd==ST_DTD_START_PI & + .or.fx%state_dtd==ST_DTD_PI_CONTENTS & + .or.fx%state_dtd==ST_DTD_ENTITY & + .or.fx%state_dtd==ST_DTD_NOTATION_SYSTEM & + .or.fx%state_dtd==ST_DTD_NOTATION_PUBLIC & + .or.fx%state_dtd==ST_DTD_NOTATION_PUBLIC_2 & + .or.fx%state_dtd==ST_DTD_ENTITY_PUBLIC & + .or.fx%state_dtd==ST_DTD_ENTITY_SYSTEM) then + ! % is perfectly legitimate + continue + elseif (fx%state_dtd==ST_DTD_SUBSET) then + if (.not.fx%spaceBeforeEntity) then + fx%spaceBeforeEntity = .true. + call push_chars(fb, c) + c = " " + else + fx%spaceBeforeEntity = .false. + fx%tokenType = TOK_ENTITY + return + endif + elseif (fx%state_dtd==ST_DTD_ATTLIST_CONTENTS & + .and. q/="") then + ! We are inside a ATTLIST attvalue, so apparent PErefs arent. + continue + elseif (fx%inIntSubset) then + call add_error(fx%error_stack, & + "Parameter entity reference not permitted inside markup for internal subset") + call add_error_position(fx%error_stack,fb) + return + elseif (fx%state_dtd==ST_DTD_ATTLIST_CONTENTS & + .or.fx%state_dtd==ST_DTD_ELEMENT_CONTENTS) then + if (is_varstr_null(fx%content)) then + ! content will not always be empty here; + ! if we have two PErefs bang next to each other. + call move_varstr_varstr(fx%token,fx%content) + endif + fx%tokenType = TOK_ENTITY + return + elseif (fx%state_dtd==ST_DTD_ENTITY_ID) then + ! % is ok if we are in the external subset + continue + else + if (.not.fx%spaceBeforeEntity) then + fx%spaceBeforeEntity = .true. + call push_chars(fb, c) + c = " " + else + fx%spaceBeforeEntity = .false. + fx%tokenType = TOK_ENTITY + return + endif + endif + endif + + select case(fx%state_dtd) + + case (ST_DTD_SUBSET) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c, XML_WHITESPACE)>0) then + if (c=="]") then + phrase = 1 + q = c + ws_discard = .false. + elseif (c=="<") then + phrase = 1 + q = c + ws_discard = .false. + else + call add_error(fx%error_stack, "Unexpected character found in document subset") + call add_error_position(fx%error_stack,fb) + endif + endif + elseif (phrase==1) then + if (q=="<") then + if (c=="?") then + fx%tokenType = TOK_PI_TAG + elseif (c=="!") then + fx%tokenType = TOK_BANG_TAG + else + call add_error(fx%error_stack, "Unexpected character, expecting ! or ?") + call add_error_position(fx%error_stack,fb) + endif + elseif (q=="]") then + if (c=="]") then + phrase = 2 + else + fx%tokenType = TOK_CLOSE_SB + call push_chars(fb, c) + if (fx%inIntSubset) then + tempString => fx%xds%intSubset + allocate(fx%xds%intSubset(size(tempString)-2)) + fx%xds%intSubset = tempString(:size(tempString)-2) + deallocate(tempString) + endif + endif + endif + elseif (phrase==2) then + if (c==">") then + fx%tokenType = TOK_SECTION_END + else + call add_error(fx%error_stack, "Unexpected character, expecting >") + call add_error_position(fx%error_stack,fb) + endif + endif + + + case (ST_DTD_BANG_TAG) + if (firstChar) then + if (c=="-") then + phrase = 1 + elseif (c=="[") then + fx%tokenType = TOK_OPEN_SB + elseif (verify(c,upperCase)==0) then + call varstr_str(fx%token,c) + else + call add_error(fx%error_stack, "Unexpected character after 0) then + call append_varstr( fx%token, c ) + else + call push_chars(fb, c) + fx%tokenType = TOK_NAME + endif + + + case (ST_DTD_START_SECTION_DECL) + if (firstChar) then + ws_discard = .true. + endif + if (ws_discard) then + if (verify(c, XML_WHITESPACE)/=0) then + call varstr_str(fx%token, c) + ws_discard = .false. + endif + else + if (verify(c, XML_WHITESPACE//"[")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c=="[") fx%nextTokenType = TOK_OPEN_SB + endif + endif + + case (ST_DTD_FINISH_SECTION_DECL) + if (verify(c, XML_WHITESPACE)>0) then + if (c/="[") then + call add_error(fx%error_stack, & + "Unexpected token found, expecting [") + call add_error_position(fx%error_stack,fb) + else + fx%tokenType = TOK_OPEN_SB + endif + endif + + case (ST_DTD_IN_IGNORE_SECTION) + select case(phrase) + case (0) + if (c=="<".or.c=="]") then + phrase = 1 + q = c + endif + case (1) + if ((q=="<".and.c=="!").or.(q=="]".and.c=="]")) then + phrase = 2 + else + phrase = 0 + endif + case (2) + if (q=="<".and.c=="[") then + fx%tokenType = TOK_SECTION_START + elseif (q=="]".and.c==">") then + fx%tokenType = TOK_SECTION_END + else + phrase = 0 + endif + end select + + + case (ST_DTD_START_PI) + ! grab until whitespace or ? + if (verify(c, XML_WHITESPACE//"?")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c=="?") call push_chars(fb, c) + endif + + case (ST_DTD_PI_CONTENTS) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c, XML_WHITESPACE)/=0) then + ws_discard = .false. + else + return + endif + endif + if (phrase==1) then + if (c==">") then + fx%tokenType = TOK_CHAR + fx%nextTokenType = TOK_PI_END + elseif (c=="?") then + ! The last ? didn't mean anything, but this one might. + call append_varstr( fx%token, '?' ) + else + phrase = 0 + call append_varstr( fx%token, '?' ) + call append_varstr( fx%token, c ) + endif + elseif (c=="?") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + + case (ST_DTD_START_COMMENT) + select case(phrase) + case (0) + if (c=="-") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + case (1) + if (c=="-") then + phrase = 2 + else + call append_varstr( fx%token, '-' ) + call append_varstr( fx%token, c ) + phrase = 0 + endif + case (2) + if (c==">") then + fx%tokenType = TOK_CHAR + call append_varstr( fx%token, c ) + fx%nextTokenType = TOK_COMMENT_END + else + call add_error(fx%error_stack, & + "Expecting > after -- inside a comment.") + call add_error_position(fx%error_stack,fb) + endif + end select + + case (ST_DTD_ATTLIST, ST_DTD_ELEMENT, ST_DTD_ENTITY, & + ST_DTD_ENTITY_PE, ST_DTD_NOTATION) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c,XML_WHITESPACE)>0) then + call varstr_str(fx%token, c) + ws_discard = .false. + endif + elseif (verify(c,XML_WHITESPACE//">")>0) then + call append_varstr( fx%token, c ) + else + if (c==">") then + fx%nextTokenType = TOK_END_TAG + else + call push_chars(fb, c) + endif + fx%tokenType = TOK_NAME + endif + + case (ST_DTD_ELEMENT_CONTENTS) + if (c==">") then + if (.not.is_varstr_null(fx%content)) then + call move_varstr_varstr(fx%content,fx%token) + endif + fx%tokenType = TOK_DTD_CONTENTS + fx%nextTokenType = TOK_END_TAG + else + if (.not.is_varstr_null(fx%content)) then + call move_varstr_varstr(fx%content,fx%token) + call append_varstr(fx%token, c) + else + call append_varstr(fx%token, c) + endif + if (c=="(") then + fx%tokenType = TOK_OPEN_PAR + call move_varstr_varstr(fx%token,fx%content) + elseif (c==")") then + fx%tokenType = TOK_CLOSE_PAR + call move_varstr_varstr(fx%token,fx%content) + endif + endif + + case (ST_DTD_ATTLIST_CONTENTS) + if (c==">") then + fx%tokenType = TOK_DTD_CONTENTS + fx%nextTokenType = TOK_END_TAG + elseif (.not.is_varstr_null(fx%content)) then + call move_varstr_varstr(fx%content,fx%token) + call append_varstr(fx%token, c) + else + call append_varstr( fx%token, c ) + endif + if (c=="'".or.c=="""") then + if (q==c) then + q = "" + else + q = c + endif + endif + + case (ST_DTD_ENTITY_ID, ST_DTD_ENTITY_PUBLIC, ST_DTD_ENTITY_SYSTEM, & + ST_DTD_ENTITY_NDATA, ST_DTD_ENTITY_END, ST_DTD_ENTITY_NDATA_VALUE, & + ST_DTD_NOTATION_ID, ST_DTD_NOTATION_SYSTEM, ST_DTD_NOTATION_PUBLIC, & + ST_DTD_NOTATION_PUBLIC_2, ST_DTD_NOTATION_END) + if (firstChar) then + if (verify(c, XML_WHITESPACE)>0) then + if (c==">") then + fx%tokenType = TOK_END_TAG + else + call add_error(fx%error_stack, "Missing whitespace in DTD.") + call add_error_position(fx%error_stack,fb) + endif + else + ws_discard = .true. + endif + elseif (ws_discard) then + if (verify(c, XML_WHITESPACE)>0) then + if (verify(c, "'""")==0) then + q = c + call set_varstr_empty(fx%token) + ws_discard = .false. + elseif (c==">") then + fx%tokenType = TOK_END_TAG + else + call varstr_str( fx%token, c ) + ws_discard = .false. + endif + endif + else + if (q/=" ".and.c==q) then + fx%tokenType = TOK_CHAR + elseif (q==" ".and.verify(c, XML_WHITESPACE//">")==0) then + fx%tokenType = TOK_NAME + if (c==">") then + fx%nextTokenType = TOK_END_TAG + else + call push_chars(fb, c) + endif + else + call append_varstr( fx%token, c ) + endif + endif + + end select + end subroutine tokenizeDTD + + end subroutine sax_tokenize + + + recursive function normalize_attribute_text(fx, s_in, fb) result(s_out) + type(sax_parser_t), intent(inout) :: fx + character, dimension(:), intent(in) :: s_in + type(file_buffer_t), intent(in) :: fb + character, dimension(:), pointer :: s_out + + character, dimension(:), pointer :: s_temp, s_temp2, s_ent, tempString + character :: dummy + integer :: i, i2, j + type(entity_t), pointer :: ent +#ifdef PGF90 + type(URI), pointer :: nullURI + nullURI => null() +#endif + + ! Condense all whitespace, only if we are validating, + ! Expand all & + ! Complain about < and & + + allocate(s_temp(size(s_in))) ! in the first instance + allocate(s_out(0)) ! in case we return early ... + s_ent => null() + tempString => null() + + i2 = 1 + i = 1 + do + if (i > size(s_in)) exit + ! Firstly, all whitespace must become 0x20 + if (verify(s_in(i),XML_WHITESPACE)==0) then + s_temp(i2) = " " + ! Then, < is always illegal + i = i + 1 + i2 = i2 + 1 + elseif (s_in(i)=='<') then + call add_error(fx%error_stack, "Illegal '<' found in attribute.") + call add_error_position(fx%error_stack,fb) + goto 100 + ! Then, expand < + elseif (s_in(i)=='&') then + j = index(str_vs(s_in(i+1:)), ';') + if (j==0) then + call add_error(fx%error_stack, "Illegal '&' found in attribute") + call add_error_position(fx%error_stack,fb) + goto 100 + elseif (j==1) then + call add_error(fx%error_stack, "No entity reference found") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + allocate(tempString(j-1)) + tempString = s_in(i+1:i+j-1) + if (existing_entity(fx%predefined_e_list, str_vs(tempString))) then + ! Expand immediately + s_temp(i2) = expand_entity_text(fx%predefined_e_list, str_vs(tempString)) + i = i + j + 1 + i2 = i2 + 1 + elseif (checkCharacterEntityReference(str_vs(tempString), fx%xds%xml_version)) then + ! Expand all character entities + s_temp(i2) = expand_char_entity(str_vs(tempString)) + i = i + j + 1 + i2 = i2 + 1 ! fixme + elseif (checkName(str_vs(tempString), fx%xds%xml_version)) then + ent => getEntityByName(fx%forbidden_ge_list, str_vs(tempString)) + if (associated(ent)) then + call add_error(fx%error_stack, 'Recursive entity expansion') + call add_error_position(fx%error_stack,fb) + goto 100 + else + ent => getEntityByName(fx%xds%entityList, str_vs(tempString)) + endif + if (associated(ent)) then + if (ent%wfc.and.fx%xds%standalone) then + call add_error(fx%error_stack, 'Externally declared entity referenced in standalone document') + call add_error_position(fx%error_stack,fb) + goto 100 + endif + !is it the right sort of entity? + if (ent%external) then + call add_error(fx%error_stack, "External entity forbidden in attribute") + call add_error_position(fx%error_stack,fb) + goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_ge_list, str_vs(tempString), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_ge_list, str_vs(tempString), "", null(), .false.) +#endif + ! Recursively expand entity, checking for errors. + s_ent => normalize_attribute_text(fx, & + vs_str(expand_entity_text(fx%xds%entityList, str_vs(tempString))),fb) + dummy = pop_entity_list(fx%forbidden_ge_list) + if (in_error(fx%error_stack)) then + goto 100 + endif + allocate(s_temp2(size(s_temp)+size(s_ent)-j)) + s_temp2(:i2-1) = s_temp(:i2-1) + s_temp2(i2:i2+size(s_ent)-1) = s_ent + deallocate(s_temp) + s_temp => s_temp2 + nullify(s_temp2) + i = i + j + 1 + i2 = i2 + size(s_ent) + deallocate(s_ent) + else + s_temp(i2:i2+j) = s_in(i:i+j) + i = i + j + 1 + i2 = i2 + j + 1 + if (.not.fx%skippedExternal.or.fx%xds%standalone) then + call add_error(fx%error_stack, "Undeclared entity encountered in standalone document.") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + endif + else + call add_error(fx%error_stack, "Illegal entity reference") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + deallocate(tempString) + else + s_temp(i2) = s_in(i) + i = i + 1 + i2 = i2 + 1 + endif + enddo + + deallocate(s_out) + allocate(s_out(i2-1)) + s_out = s_temp(:i2-1) +100 deallocate(s_temp) + if (associated(s_ent)) deallocate(s_ent) + if (associated(tempString)) deallocate(tempString) + + end function normalize_attribute_text + + recursive function expand_pe_text(fx, s_in, fb) result(s_out) + type(sax_parser_t), intent(inout) :: fx + character, dimension(:), intent(in) :: s_in + type(file_buffer_t), intent(inout) :: fb + character, dimension(:), pointer :: s_out + + character, dimension(:), pointer :: s_temp, s_temp2, s_ent, tempString + character :: dummy + integer :: i, i2, j, iostat + type(entity_t), pointer :: ent +#ifdef PGF90 + type(URI), pointer :: nullURI + nullURI => null() +#endif + + ! Expand all %PE; + + allocate(s_temp(size(s_in))) ! in the first instance + allocate(s_out(0)) ! in case we return early ... + s_ent => null() + tempString => null() + s_temp2 => null() + + i2 = 1 + i = 1 + do while (i <= size(s_in)) + if (s_in(i)=='%') then + j = index(str_vs(s_in(i+1:)), ';') + if (j==0) then + call add_error(fx%error_stack, "Illegal '%' found in attribute") + call add_error_position(fx%error_stack,fb) + goto 100 + elseif (j==1) then + call add_error(fx%error_stack, "No entity reference found") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + allocate(tempString(j-1)) + tempString = s_in(i+1:i+j-1) + if (checkName(str_vs(tempString), fx%xds%xml_version)) then + ent => getEntityByName(fx%forbidden_pe_list, str_vs(tempString)) + if (associated(ent)) then + call add_error(fx%error_stack, 'Recursive entity expansion') + call add_error_position(fx%error_stack,fb) + goto 100 + endif + ent => getEntityByName(fx%xds%peList, str_vs(tempString)) + if (associated(ent)) then + if (ent%wfc.and.fx%xds%standalone) then + call add_error(fx%error_stack, & + "Externally declared entity used in standalone document") + call add_error_position(fx%error_stack,fb) + goto 100 + elseif (str_vs(ent%notation)/="") then + call add_error(fx%error_stack, "Unparsed entity reference forbidden in entity value") + call add_error_position(fx%error_stack,fb) + goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_pe_list, str_vs(tempString), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_pe_list, str_vs(tempString), "", null(), .false.) +#endif + ! Recursively expand entity, checking for errors. + if (ent%external) then + call open_new_file(fb, ent%baseURI, iostat) + if (iostat/=0) then + call add_error(fx%error_stack, "Unable to access external parameter entity") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + s_temp2 => get_all_characters(fb, fx%error_stack) + call pop_buffer_stack(fb) + if (in_error(fx%error_stack)) goto 100 + s_ent => expand_pe_text(fx, s_temp2, fb) + deallocate(s_temp2) + else + s_ent => expand_pe_text(fx, & + vs_str(expand_entity_text(fx%xds%peList, str_vs(tempString))), fb) + endif + dummy = pop_entity_list(fx%forbidden_pe_list) + if (in_error(fx%error_stack)) then + goto 100 + endif + allocate(s_temp2(size(s_temp)+size(s_ent)-j)) + s_temp2(:i2-1) = s_temp(:i2-1) + s_temp2(i2:i2+size(s_ent)-1) = s_ent + deallocate(s_temp) + s_temp => s_temp2 + s_temp2 => null() + i = i + j + 1 + i2 = i2 + size(s_ent) + deallocate(s_ent) + else + s_temp(i2:i2+j) = s_in(i:i+j) + i = i + j + 1 + i2 = i2 + j + 1 + if (.not.fx%skippedExternal.or.fx%xds%standalone) then + call add_error(fx%error_stack, "Reference to undeclared parameter entity encountered in standalone document.") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + endif + else + call add_error(fx%error_stack, "Illegal parameter entity reference") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + deallocate(tempString) + else + s_temp(i2) = s_in(i) + i = i + 1 + i2 = i2 + 1 + endif + enddo + + deallocate(s_out) + allocate(s_out(i2-1)) + s_out = s_temp(:i2-1) +100 deallocate(s_temp) + if (associated(s_temp2)) deallocate(s_temp2) + if (associated(s_ent)) deallocate(s_ent) + if (associated(tempString)) deallocate(tempString) + + end function expand_pe_text +#endif + +end module m_sax_tokenizer diff --git a/src/xml/sax/m_sax_types.F90 b/src/xml/sax/m_sax_types.F90 new file mode 100644 index 000000000..eb123c781 --- /dev/null +++ b/src/xml/sax/m_sax_types.F90 @@ -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_COMMENT_END = 10 ! --> + integer, parameter :: TOK_SECTION_START = 11 ! + integer, parameter :: TOK_END_TAG = 13 ! > + integer, parameter :: TOK_END_TAG_CLOSE = 14 ! /> + integer, parameter :: TOK_CLOSE_TAG = 15 ! 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 diff --git a/src/xml/utils/FoX_utils.F90 b/src/xml/utils/FoX_utils.F90 new file mode 100644 index 000000000..560f91e59 --- /dev/null +++ b/src/xml/utils/FoX_utils.F90 @@ -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 diff --git a/src/xml-fortran/Makefile b/src/xml/utils/Makefile similarity index 69% rename from src/xml-fortran/Makefile rename to src/xml/utils/Makefile index 6bba7a148..449bd4d91 100644 --- a/src/xml-fortran/Makefile +++ b/src/xml/utils/Makefile @@ -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 diff --git a/src/xml/utils/fox_m_utils_mtprng.F90 b/src/xml/utils/fox_m_utils_mtprng.F90 new file mode 100644 index 000000000..90a766d2b --- /dev/null +++ b/src/xml/utils/fox_m_utils_mtprng.F90 @@ -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 +! Very small cosmetic changes to fit FoX naming scheme and +! avoid additional dependencies. +! Toby White , 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 diff --git a/src/xml/utils/fox_m_utils_uri.F90 b/src/xml/utils/fox_m_utils_uri.F90 new file mode 100644 index 000000000..a3f1d70ff --- /dev/null +++ b/src/xml/utils/fox_m_utils_uri.F90 @@ -0,0 +1,1033 @@ +module fox_m_utils_uri +#ifndef DUMMYLIB + + ! Manipulate URIs and URI references a la RFC 2396 + ! NB: ... + ! Forbidden (ASCII control) characters are not handled correctly + ! checking of reg names (not hosts) is done wrongly + ! checking of ipv6/X is untested + + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc + use fox_m_fsys_format, only: str_to_int_10, str_to_int_16, str + use fox_m_fsys_string, only: toLower + + implicit none + private + + type path_segment + character, pointer :: s(:) => null() + end type path_segment +#endif + + type URI + private +#ifndef DUMMYLIB + character, pointer :: scheme(:) => null() + character, pointer :: authority(:) => null() + character, pointer :: userinfo(:) => null() + character, pointer :: host(:) => null() + integer :: port = -1 + character, pointer :: path(:) => null() + type(path_segment), pointer :: segments(:) => null() + character, pointer :: query(:) => null() + character, pointer :: fragment(:) => null() +#else + integer :: i +#endif + end type URI + +#ifndef DUMMYLIB + character(len=*), parameter :: lowalpha = "abcdefghijklmnopqrstuvwxyz" + character(len=*), parameter :: upalpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + character(len=*), parameter :: alpha = lowalpha//upalpha + character(len=*), parameter :: digit = "0123456789" + character(len=*), parameter :: hexdigit = "0123456789abcdefABCDEF" + character(len=*), parameter :: alphanum = alpha//digit + character(len=*), parameter :: unreserved = alphanum//"-._~" + character(len=*), parameter :: gen_delims = ":/?#[]@" + character(len=*), parameter :: sub_delims = "!$&'()*+,;=" + character(len=*), parameter :: reserved = gen_delims//sub_delims + character(len=*), parameter :: pchar = unreserved//":@&=+$," + character(len=*), parameter :: uric_no_slash = unreserved//";?:@&=+$," + character(len=*), parameter :: uric = unreserved//reserved + character(len=*), parameter :: unwise = "{}|\^[]`" +#endif + + public :: URI + public :: parseURI + public :: expressURI + public :: isAbsoluteURI + public :: rebaseURI + public :: copyURI + public :: destroyURI + + public :: hasScheme + public :: getScheme + public :: hasAuthority + public :: getAuthority + public :: hasUserinfo + public :: getUserinfo + public :: hasHost + public :: getHost + public :: hasPort + public :: getPort + public :: getPath + public :: hasQuery + public :: getQuery + public :: hasFragment + public :: getFragment + +#ifndef DUMMYLIB + public :: dumpURI +#endif + +contains + +#ifndef DUMMYLIB + function unEscape_alloc(s) result(c) + character(len=*), intent(in) :: s + character, pointer :: c(:) + + integer :: i, j, n + character(len(s)) :: t + + c => null() + + i = 1 + j = 0 + do while (i<=len(s)) + j = j + 1 + if (s(i:i)=="%") then + if (i+2>len(s)) return + if (verify(s(i+1:i+2), hexdigit)/=0) return + n = str_to_int_16(s(i+1:i+2)) + t(j:j) = achar(n) + i = i + 3 + else + t(j:j) = s(i:i) + i = i + 1 + endif + enddo + + c => vs_str_alloc(t(:j)) + end function unEscape_alloc + + function verifyWithPctEncoding(s, chars) result(p) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: chars + logical :: p + + integer :: i + + p = .false. + i = 1 + do while (i<=len(s)) + if (s(i:i)=="%") then + if (i+2>len(s)) return + if (verify(s(i+1:i+2), hexdigit)>0) return + i = i + 3 + else + if (verify(s(i:i),chars)>0) return + i = i + 1 + endif + enddo + p = .true. + end function verifyWithPctEncoding + + pure function pctEncode_len(s, chars) result(n) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: chars + integer :: n + + integer :: i + n = 0 + do i = 1, len(s) + n = n + 1 + if (verify(s(i:i), unwise)==0.or.verify(s(i:i), chars)>0) n = n + 2 + enddo + + end function pctEncode_len + + function pctEncode(s, chars) result(ps) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: chars + character(len=pctEncode_len(s, chars)) :: ps + + integer :: i, n + + n = 1 + do i = 1, len(s) + if (verify(s(i:i), unwise)==0.or.verify(s(i:i), chars)>0) then + ps(n:n+2) = "%"//str(iachar(s(i:i)), "x2") + n = n + 3 + else + ps(n:n) = s(i:i) + n = n + 1 + endif + enddo + + end function pctEncode + + function checkOpaquePart(part) result(p) + character(len=*), intent(in) :: part + logical :: p + + if (len(part)>0) then + p = verify(part(1:1), uric_no_slash)==0 + if (p.and.len(part)>1) & + p = verify(part(1:1), uric)==0 + endif + end function checkOpaquePart + + + function checkScheme(scheme) result(p) + character(len=*), intent(in) :: scheme + logical :: p + + p = len(scheme)>0 + if (p) then + p = verify(scheme(1:1), lowalpha//upalpha)==0 + if (p.and.len(scheme)>1) then + p = verify(scheme(2:), alphanum//"+-.")==0 + endif + endif + end function checkScheme + + function checkIpvX(host) result(p) + character(len=*), intent(in) :: host + logical :: p + + integer :: i, n1, n2 + + p = (len(host)>5).and.(host(1:1)=="[".and.host(len(host):len(host))=="]") + + if (p) then + + ! Try IPvFuture: + p = (verify(host(2:2),"Vv")==0 & + .and.verify(host(3:3),hexdigit)==0 & + .and.host(4:4)=="." & + .and.verify(host(3:3),unreserved//sub_delims//":")==0) + + if (.not.p) then ! is it IPv6? + n1 = 0 + do i = 1, 4 + n2 = index(host(n1+1:), ":") + if (n2==0.or.n2>6) return + n2 = n2 + n1 + if (verify(host(n1+1:n2-1),hexdigit)>0) return + n1 = n2 + enddo + n2 = index(host(n1+1:), ":") + if (n2==0) then + ! this must be ipv4 format + do i = 1, 3 + n2 = index(host(n1+1:), ".") + if (n2==0) return + n2 = n2 + n1 + if (verify(host(n1+1:n2-1),digit)>0) return + if (str_to_int_10(host(n1+1:n2-1))>255) return + n1 = n2 + enddo + ! Now there must be 3 or less digits followed by ] + n2 = len(host)-1 + if (verify(host(n1+1:n2-1),digit)>0) return + if (str_to_int_10(host(n1+1:n2-1))>255) return + elseif (n2<6) then + n2 = n2 + n1 + if (verify(host(n1+1:n2-1),hexdigit)>0) return + ! Now there must be 4 or less digits followed by ] + n1 = n2 + n2 = len(host) + if (n2-n1>4) return + if (verify(host(n1+1:n2-1),hexdigit)>0) return + endif + p = .true. + endif + endif + end function checkIpvX + + function checkHost(host) result(p) + character(len=*), intent(in) :: host + logical :: p + + p = checkIpvX(host) + if (.not.p) & + p = verifyWithPctEncoding(host, unreserved//sub_delims) + + end function checkHost + + function checkAuthority(authority, userinfo, host, port) result(p) + character(len=*), intent(in) :: authority + character, pointer :: userinfo(:), host(:) + integer :: port + logical :: p + + integer :: i1, i2 + + p = .true. + if (len(authority)==0) return + + i1 = index(authority, "@") + if (i1>0) then + i2 = index(authority(i1+1:), ":") + else + i2 = index(authority, ":") + endif + if (i1==0) then + userinfo => null() + else + p = verifyWithPctEncoding(authority(:i1-1), unreserved//sub_delims//":") + if (p) userinfo => unEscape_alloc(authority(:i1-1)) + endif + if (i2==0) then + i2 = len(authority)+1 + else + i2 = i1 + i2 + p = p.and.verify(authority(i2+1:), digit)==0 + if (p) port = str_to_int_10(authority(i2+1:)) + endif + p = p.and.checkHost(authority(i1+1:i2-1)) + if (p) then + host => vs_str_alloc(authority(i1+1:i2-1)) + else + if (associated(userinfo)) deallocate(userinfo) + end if + + end function checkAuthority + + function checkPathSegment(segment) result(p) + character(len=*), intent(in) :: segment + logical :: p + + integer :: i1 + + i1 = index(segment, ";") + if (i1>0) then + p = verifyWithPctEncoding(segment(:i1-1), pchar) & + .and.verifyWithPctEncoding(segment(i1+1:), pchar) + else + p = verifyWithPctEncoding(segment, unreserved//pchar) + endif + end function checkPathSegment + + function checkNonOpaquePath(path, segments) result(p) + character(len=*), intent(in) :: path + type(path_segment), pointer :: segments(:) + logical :: p + + integer :: i, i1, i2 + type(path_segment), pointer :: temp(:) + + p = .true. + i1 = index(path, "/") + if (i1==1) then ! absolute path + allocate(segments(1)) + segments(1)%s => vs_str_alloc("/") + else + allocate(segments(0)) + i1 = 0 + endif + + do + i2 = index(path(i1+1:), "/") + if (i2==0) then + i2 = len(path) + else + i2 = i1 + i2 + endif + if (checkPathSegment(path(i1+1:i2-1))) then + allocate(temp(size(segments)+1)) + do i = 1, size(segments) + temp(i)%s => segments(i)%s + enddo + temp(i)%s => unEscape_alloc(path(i1+1:i2)) + deallocate(segments) + segments => temp + else + do i = 1, size(segments) + deallocate(segments(i)%s) + enddo + deallocate(segments) + p = .false. + return + endif + if (i2==len(path)) exit + i1 = i2 + end do + end function checkNonOpaquePath + + function checkPath(path, segments) result(p) + character(len=*), intent(in) :: path + type(path_segment), pointer :: segments(:) + logical :: p + + p = checkNonOpaquePath(path, segments) + if (.not.p) then + p = checkOpaquePart(path) + if (p) allocate(segments(0)) + endif + + end function checkPath + + function checkQuery(query) result(p) + character(len=*), intent(in) :: query + logical :: p + + p = verifyWithPctEncoding(query, uric) + end function checkQuery + + function checkFragment(fragment) result(p) + character(len=*), intent(in) :: fragment + logical :: p + + p = verifyWithPctEncoding(fragment, uric) + end function checkFragment +#endif + + function parseURI(inURIstring) result(u) + character(len=*), intent(in) :: inURIstring + type(URI), pointer :: u + character(len=len_trim(inURIstring)) :: URIstring +#ifndef DUMMYLIB + character, pointer, dimension(:) :: scheme, authority, & + userinfo, host, path, query, fragment + integer :: port + type(path_segment), pointer :: segments(:) + integer :: i1, i2, i3, i4 + logical :: p + +#endif + u => null() + URIstring = trim(inURIString) +#ifndef DUMMYLIB + + scheme => null() + authority => null() + userinfo => null() + host => null() + port = -1 + path => null() + segments => null() + query => null() + fragment => null() + + if (len(URIstring)>3) then + ! is this a M$ windoze absolute path ? eg of the form "C:/path_segments" + if ((scan(URIstring(1:1),alpha)>0).and.(URIstring(2:3)==':/') ) then + ! no point in attempting to decode as a uri, it contains only a windows path + scheme => vs_str_alloc("file") + path => unEscape_alloc(URIstring) + allocate(segments(1)) + segments(1)%s => vs_str_alloc("") + call produceResult + return + end if + end if + i1 = index(URIstring, ":") + if (i1>0) then + p = checkScheme(URIstring(:i1-1)) + if (p) then + scheme => vs_str_alloc(toLower(URIstring(:i1-1))) + else + i1 = 0 + endif + endif + ! if either i1==0 or the scheme doesn't validate, there is no scheme.. + if (len(URIstring)>=i1+3) then + if (URIstring(i1+1:i1+2)=="//") then + i2 = scan(URIstring(i1+3:), "/#?") + if (i2==0) then + i2 = len(URIstring) + 1 + else + i2 = i1 + i2 + 2 + endif + p = checkAuthority(URIstring(i1+3:i2-1), userinfo, host, port) + if (.not.p) then + call cleanUp + return + endif + authority => vs_str_alloc(URIstring(i1+3:i2-1)) + else + i2 = i1 + 1 + endif + else + i2 = i1 + 1 + endif + + if (i2>len(URIstring)) then + path => vs_str_alloc("") + allocate(segments(1)) + segments(1)%s => vs_str_alloc("") + call produceResult + return + endif + + i3 = scan(URIstring(i2:),"#?") + if (i3==0) then + i3 = len(URIstring) + 1 + else + i3 = i2 + i3 - 1 + endif + p = checkPath(URIstring(i2:i3-1), segments) + if (.not.p) then + call cleanUp + return + endif + if (len(URIstring(i2:i3-1))>3) then + ! is this a M$ windoze absolute path with a unix root ? eg of the form "/C:/path_segments" + if ( (URIstring(i2:i2)=='/').and.(scan(URIstring(i2+1:i2+1),alpha)>0).and.(URIstring(i2+2:i2+3)==':/') ) then + ! ignore the root slash (which would otherwise make sense on most systems) to yield a representation in windows canonical form + i2 = i2+1 + end if + end if + path => unEscape_alloc(URIstring(i2:i3-1)) + + if (i3>len(URIstring)) then + call produceResult + return + endif + + if (URIstring(i3:i3)=="?") then + i4 = index(URIstring(i3+1:), "#") + if (i4==0) then + i4 = len(URIstring) + 1 + else + i4 = i3 + i4 + endif + p = checkQuery(URIstring(i3+1:i4-1)) + if (.not.p) then + call cleanUp + return + endif + query => vs_str_alloc(URIstring(i3+1:i4-1)) + else + i4 = i3 + endif + + if (i4>len(URIstring)) then + call produceResult + return + endif + + p = checkFragment(URIstring(i4+1:)) + if (.not.p) then + call cleanUp + return + endif + fragment => vs_str_alloc(URIstring(i4+1:)) + call produceResult + + contains + subroutine cleanUp + integer :: i + if (associated(scheme)) deallocate(scheme) + if (associated(authority)) deallocate(authority) + if (associated(userinfo)) deallocate(userinfo) + if (associated(host)) deallocate(host) + if (associated(path)) deallocate(path) + if (associated(query)) deallocate(query) + if (associated(fragment)) deallocate(fragment) + if (associated(segments)) then + do i = 1, size(segments) + deallocate(segments(i)%s) + enddo + deallocate(segments) + endif + end subroutine cleanUp + subroutine produceResult + allocate(u) + u%scheme => scheme + u%authority => authority + u%userinfo => userinfo + u%host => host + u%port = port + u%path => path + u%query => query + u%fragment => fragment + u%segments => segments + end subroutine produceResult +#endif + end function parseURI + + function isAbsoluteURI(u) result(p) + type(URI), intent(in) :: u + logical :: p + +#ifdef DUMMYLIB + p = .false. +#else + p = associated(u%scheme).or.associated(u%authority) + if (.not.p.and.size(u%segments(1)%s)>0) then + p = u%segments(1)%s(1)=="/" + endif +#endif + end function isAbsoluteURI + + function rebaseURI(u1, u2) result(u3) + type(URI), pointer :: u1, u2 + type(URI), pointer :: u3 + + u3 => null() +#ifndef DUMMYLIB + + if (associated(u2%scheme).or.associated(u2%authority)) then + u3 => copyURI(u2) + return + endif + + allocate(u3) + if (associated(u1%scheme)) u3%scheme => vs_vs_alloc(u1%scheme) + if (associated(u1%authority)) u3%authority => vs_vs_alloc(u1%authority) + + u3%segments => appendPaths(u1%segments, u2%segments) + u3%path => expressSegments(u3%segments) + + if (associated(u2%query)) u3%query => vs_vs_alloc(u2%query) + if (associated(u2%fragment)) u3%fragment => vs_vs_alloc(u2%fragment) +#endif + end function rebaseURI + +#ifndef DUMMYLIB + function appendPaths(seg1, seg2) result(seg3) + type(path_segment), pointer :: seg1(:), seg2(:) + type(path_segment), pointer :: seg3(:) + + type(path_segment), pointer :: temp(:) + + integer :: i, n, n2 + + if (size(seg2(1)%s)==0) then + seg3 => normalizePath(seg1) + return + elseif (seg2(1)%s(1)=="/") then + seg3 => normalizePath(seg2) + return + endif + + n = size(seg1) + size(seg2) + i = size(seg1) + if (seg1(i)%s(size(seg1(i)%s))/="/") & + n = n - 1 + + allocate(temp(n)) + n2 = 1 + do i = 1, size(seg1) + if (i==size(seg1).and.seg1(i)%s(size(seg1(i)%s))/="/") exit ! it's a file + temp(n2)%s => vs_vs_alloc(seg1(i)%s) + n2 = n2 + 1 + enddo + + do i = 1, size(seg2) + temp(n2)%s => vs_vs_alloc(seg2(i)%s) + n2 = n2 + 1 + enddo + + seg3 => normalizePath(temp) + do i = 1, size(temp) + deallocate(temp(i)%s) + enddo + deallocate(temp) + + end function appendPaths + + function normalizepath(seg1) result(seg2) + type(path_segment), pointer :: seg1(:) + type(path_segment), pointer :: seg2(:) + + integer :: i, n, n2, parents + character, pointer :: tmp(:) + + + ! If the last of the input segments are + ! equal to '.' or '..', append a slash + ! so the rest of the subroutine works. + + if ((str_vs(seg1(size(seg1))%s) == '.').or. & + (str_vs(seg1(size(seg1))%s) == '..')) then + tmp => vs_vs_alloc(seg1(size(seg1))%s) + deallocate(seg1(size(seg1))%s) + seg1(size(seg1))%s => vs_str_alloc(str_vs(tmp)//"/") + deallocate(tmp) + endif + + n = 0 + parents = 0 + do i = 1, size(seg1) + if (str_vs(seg1(i)%s)//"x"=="./x") then + continue + elseif (str_vs(seg1(i)%s)//"x"=="../x") then + if (n>0) then + n = n - 1 + else + parents = parents + 1 + endif + else + n = n + 1 + endif + enddo + + n = n + parents + allocate(seg2(n)) + + n2 = parents + do i = 1, parents + seg2(i)%s => vs_str_alloc("../") + enddo + do i = 1, size(seg1) + if (str_vs(seg1(i)%s)//"x"=="./x") then + continue + elseif (str_vs(seg1(i)%s)//"x"=="../x") then + if (n2>parents) then + if (n2<=n) deallocate(seg2(n2)%s) + n2 = n2 - 1 + endif + else + n2 = n2 + 1 + if (n2>0.and.n2<=n) & + seg2(n2)%s => vs_vs_alloc(seg1(i)%s) + endif + enddo + + end function normalizepath + + function expressSegments(seg1) result(s) + type(path_segment), pointer :: seg1(:) + character, pointer :: s(:) + + integer :: i, n + + n = 0 + + do i = 1, size(seg1) + n = n + size(seg1(i)%s) + enddo + allocate(s(n)) + n = 1 + do i = 1, size(seg1) + s(n:n+size(seg1(i)%s)-1) = seg1(i)%s + n = n + size(seg1(i)%s) + enddo + end function expressSegments + + pure function expressURI_len(u) result(n) + type(URI), intent(in) :: u + integer :: n + + n = 0 + if (associated(u%scheme)) & + n = size(u%scheme) + 1 + if (associated(u%authority)) & + n = n + pctEncode_len(str_vs(u%authority), unreserved//sub_delims//"@:") + 2 + !FIXME - I suspect that ';' as the first character of a segment should be escaped + n = n + pctEncode_len(str_vs(u%path), pchar//";"//"/") + if (associated(u%query)) & + n = n + pctEncode_len(str_vs(u%query), uric) + 1 + if (associated(u%fragment)) & + n = n + pctEncode_len(str_vs(u%fragment), uric) + 1 + + end function expressURI_len + + function expressURI(u) result(URIstring) + type(URI), intent(in) :: u + character(len=expressURI_len(u)) :: URIstring + + integer :: i, j + URIstring="" + i = 1 + if (associated(u%scheme)) then + URIstring(:size(u%scheme)+1) = str_vs(u%scheme)//":" + i = i + size(u%scheme) + 1 + endif + if (associated(u%authority)) then + j = pctEncode_len(str_vs(u%authority), unreserved//sub_delims//"@:") + URIstring(i:i+j+1) = & + "//"//pctEncode(str_vs(u%authority), unreserved//sub_delims//"@:") + i = i + j + 2 + endif + if (size(u%path)>0) then + !FIXME - I suspect that ';' as the first character of a segment should be escaped + j = pctEncode_len(str_vs(u%path), pchar//";"//"/") + URIstring(i:i+j-1) = pctEncode(str_vs(u%path), pchar//";"//"/") + i = i + j + endif + if (associated(u%query)) then + j = pctEncode_len(str_vs(u%query), uric) + URIstring(i:i+j) = "?"//pctEncode(str_vs(u%query), uric) + i = i + j + 1 + endif + if (associated(u%fragment)) then + j = pctEncode_len(str_vs(u%fragment), uric) + URIstring(i:i+j) = "#"//pctEncode(str_vs(u%fragment), uric) + endif + + end function expressURI + + subroutine dumpURI(u) + type(URI), intent(in) :: u + integer :: i + if (associated(u%scheme)) then + write(*,*) "scheme: ", str_vs(u%scheme) + else + write(*,*) "scheme UNDEFINED" + endif + if (associated(u%authority)) then + write(*,*) "authority: ", str_vs(u%authority) + else + write(*,*) "authority UNDEFINED" + endif + if (associated(u%userinfo)) then + write(*,*) "userinfo: ", str_vs(u%userinfo) + else + write(*,*) "userinfo UNDEFINED" + endif + if (associated(u%host)) then + write(*,*) "host: ", str_vs(u%host) + else + write(*,*) "host UNDEFINED" + endif + if (u%port>0) then + write(*,*) "port: ", str(u%port) + else + write(*,*) "port UNDEFINED" + endif + if (associated(u%path)) then + write(*,*) "path: ", str_vs(u%path) + else + write(*,*) "path UNDEFINED" + endif + if (associated(u%segments)) then + do i = 1, size(u%segments) + write(*,*) " segment: ", str_vs(u%segments(i)%s) + enddo + endif + if (associated(u%query)) then + write(*,*) "query: ", str_vs(u%query) + else + write(*,*) "query UNDEFINED" + endif + if (associated(u%fragment)) then + write(*,*) "fragment: ", str_vs(u%fragment) + else + write(*,*) "fragment UNDEFINED" + endif + end subroutine dumpURI +#endif + + function copyURI(u1) result(u2) + type(URI), pointer :: u1 + type(URI), pointer :: u2 +#ifndef DUMMYLIB + integer :: i + + if (.not.associated(u1)) then +#endif + u2 => null() +#ifndef DUMMYLIB + return + endif + allocate(u2) + u2%scheme => vs_vs_alloc(u1%scheme) + u2%authority => vs_vs_alloc(u1%authority) + u2%userinfo => vs_vs_alloc(u1%userinfo) + u2%host => vs_vs_alloc(u1%host) + u2%port = u1%port + u2%path => vs_vs_alloc(u1%path) + allocate(u2%segments(size(u1%segments))) + do i = 1, size(u1%segments) + u2%segments(i)%s => vs_vs_alloc(u1%segments(i)%s) + enddo + u2%query => vs_vs_alloc(u1%query) + u2%fragment => vs_vs_alloc(u1%fragment) +#endif + end function copyURI + + + subroutine destroyURI(u) + type(URI), pointer :: u +#ifndef DUMMYLIB + integer :: i + if (associated(u%scheme)) deallocate(u%scheme) + if (associated(u%authority)) deallocate(u%authority) + if (associated(u%userinfo)) deallocate(u%userinfo) + if (associated(u%host)) deallocate(u%host) + if (associated(u%path)) deallocate(u%path) + if (associated(u%segments)) then + do i = 1, size(u%segments) + deallocate(u%segments(i)%s) + enddo + deallocate(u%segments) + endif + if (associated(u%query)) deallocate(u%query) + if (associated(u%fragment)) deallocate(u%fragment) + + deallocate(u) +#endif + end subroutine destroyURI + + function hasScheme(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%scheme) +#endif + end function hasScheme + + function getScheme(u) result(s) + type(URI), pointer :: u + +#ifndef DUMMYLIB + character(len=size(u%scheme)) :: s + s = str_vs(u%scheme) +#else + character(len=1) :: s + s = "" +#endif + end function getScheme + + function hasAuthority(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%authority) +#endif + end function hasAuthority + + function getAuthority(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%authority)) :: s + s = str_vs(u%authority) +#else + character(len=1) :: s + s = "" +#endif + end function getAuthority + + function hasUserinfo(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%userinfo) +#endif + end function hasUserinfo + + function getUserinfo(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%userinfo)) :: s + s = str_vs(u%userinfo) +#else + character(len=1) :: s + s = "" +#endif + end function getUserinfo + + function hasHost(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%host) +#endif + end function hasHost + + function getHost(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%host)) :: s + s = str_vs(u%host) +#else + character(len=1) :: s + s = "" +#endif + end function getHost + + function hasPort(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = u%port > 0 +#endif + end function hasPort + + function getPort(u) result(n) + type(URI), pointer :: u + integer :: n +#ifndef DUMMYLIB + n = u%port +#else + n = 0 +#endif + end function getPort + + function getPath(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%path)) :: s + s = str_vs(u%path) +#else + character(len=1) :: s + s = "" +#endif + end function getPath + + function hasQuery(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%query) +#endif + end function hasQuery + + function getQuery(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%query)) :: s + s = str_vs(u%query) +#else + character(len=1) :: s + s = "" +#endif + end function getQuery + + function hasFragment(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%fragment) +#endif + end function hasFragment + + function getFragment(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%fragment)) :: s + s = str_vs(u%fragment) +#else + character(len=1) :: s + s = "" +#endif + end function getFragment + +end module fox_m_utils_uri diff --git a/src/xml/utils/fox_m_utils_uuid.F90 b/src/xml/utils/fox_m_utils_uuid.F90 new file mode 100644 index 000000000..fd9c272d9 --- /dev/null +++ b/src/xml/utils/fox_m_utils_uuid.F90 @@ -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 diff --git a/src/xml/wxml/FoX_wxml.F90 b/src/xml/wxml/FoX_wxml.F90 new file mode 100644 index 000000000..cf4def0a7 --- /dev/null +++ b/src/xml/wxml/FoX_wxml.F90 @@ -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 diff --git a/src/templates/Makefile b/src/xml/wxml/Makefile similarity index 51% rename from src/templates/Makefile rename to src/xml/wxml/Makefile index 232ae9609..55dcc3d9c 100644 --- a/src/templates/Makefile +++ b/src/xml/wxml/Makefile @@ -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 diff --git a/src/xml/wxml/m_wxml_core.F90 b/src/xml/wxml/m_wxml_core.F90 new file mode 100644 index 000000000..7e905c2ab --- /dev/null +++ b/src/xml/wxml/m_wxml_core.F90 @@ -0,0 +1,1877 @@ +module m_wxml_core + +#ifndef DUMMYLIB + use fox_m_fsys_abort_flush, only: pxfabort + use fox_m_fsys_array_str, only: vs_str, str_vs, vs_str_alloc + use fox_m_fsys_string, only: toLower + use fox_m_utils_uri, only: URI, parseURI, destroyURI + use m_common_attrs, only: dictionary_t, getLength, get_key, get_value, & + hasKey, add_item_to_dict, init_dict, reset_dict, destroy_dict, & + getWhitespaceHandling, sortAttrs + use m_common_buffer, only: buffer_t, len, add_to_buffer, reset_buffer, & + dump_buffer + use m_common_charset, only: XML1_0, XML1_1, checkChars + use m_common_element, only: parse_dtd_element, parse_dtd_attlist + use m_common_elstack, only: elstack_t, len, get_top_elstack, pop_elstack, & + is_empty, init_elstack, push_elstack, destroy_elstack + use m_common_entities, only: existing_entity, is_unparsed_entity + use m_common_error, only: FoX_warning_base, FoX_error_base, FoX_fatal_base, & + error_stack, in_error, FoX_get_fatal_errors, FoX_get_fatal_warnings + use m_common_io, only: get_unit + use m_common_namecheck, only: checkEncName, checkName, checkQName, & + checkCharacterEntityReference, checkPublicId, prefixOfQName, & + localpartofQName, checkPEDef, checkPseudoAttValue, checkAttValue, checkNCName, & + likeCharacterEntityReference, checkCharacterEntityReference + use m_common_namespaces, only: namespaceDictionary, getnamespaceURI, & + initnamespaceDictionary, addDefaultNS, destroyNamespaceDictionary, & + addPrefixedNS, isPrefixInForce, checkNamespacesWriting, checkEndNamespaces + use m_common_notations, only: add_notation, notation_exists + use m_common_struct, only: xml_doc_state, init_xml_doc_state, destroy_xml_doc_state, & + register_internal_PE, register_external_PE, register_internal_GE, register_external_GE + use m_wxml_escape, only: escape_string +#ifdef PGF90 + use m_common_element, only : element_t +#endif +#endif + + implicit none + private + +#ifndef DUMMYLIB + integer, parameter :: indent_inc = 2 + ! TOHW should we let this be set? + + !Output State Machines + ! status wrt root element: + integer, parameter :: WXML_STATE_1_JUST_OPENED = 0 + !File is just opened, nothing written to it yet. + integer, parameter :: WXML_STATE_1_BEFORE_ROOT = 1 + !File has been opened, something has been written, but no root element yet. + integer, parameter :: WXML_STATE_1_DURING_ROOT = 2 + !The root element has been opened but not closed + integer, parameter :: WXML_STATE_1_AFTER_ROOT = 3 + !The root element has been opened but not closed + + ! status wrt tags: + integer, parameter :: WXML_STATE_2_OUTSIDE_TAG = 0 + !We are not within a tag. + integer, parameter :: WXML_STATE_2_INSIDE_PI = 1 + !We are inside a Processing Instruction tag + integer, parameter :: WXML_STATE_2_INSIDE_ELEMENT = 2 + !We are inside an element tag. + integer, parameter :: WXML_STATE_2_IN_CHARDATA = 3 + !We are inside deliberately-constructed text. (this is only necessary for preserve_whitespace) + + ! status wrt DTD + integer, parameter :: WXML_STATE_3_BEFORE_DTD = 0 + ! No DTD has been encountered yet. + integer, parameter :: WXML_STATE_3_DURING_DTD = 1 + ! Halfway throught outputting a DTD + integer, parameter :: WXML_STATE_3_INSIDE_INTSUBSET = 2 + !We are inside the internal subset definition + integer, parameter :: WXML_STATE_3_AFTER_DTD = 3 + ! Finished outputting a DTD +#endif + + + type xmlf_t + private +#ifdef DUMMYLIB + integer :: i = 0 +#else + type(xml_doc_state) :: xds + integer :: lun = -1 + type(buffer_t) :: buffer + type(elstack_t) :: stack + type(dictionary_t) :: dict + integer :: state_1 = -1 + integer :: state_2 = -1 + integer :: state_3 = -1 + ! Holder for extra information for other writers. See + ! table with getter and setter below: + integer :: extended_data = 0 + logical :: minimize_overrun = .true. + logical :: pretty_print = .false. + logical :: canonical = .false. + integer :: indent = 0 + character, pointer :: name(:) + logical :: namespace = .true. + type(namespaceDictionary) :: nsDict +#endif + end type xmlf_t + + public :: xmlf_t + + public :: xml_OpenFile + public :: xml_NewElement + public :: xml_EndElement + public :: xml_Close + public :: xml_AddXMLDeclaration + public :: xml_AddXMLStylesheet + public :: xml_AddXMLPI + public :: xml_AddComment + public :: xml_AddCharacters + public :: xml_AddNewline + public :: xml_AddEntityReference + 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_Name + public :: xmlf_OpenTag + + public :: xmlf_SetPretty_print + public :: xmlf_GetPretty_print + public :: xmlf_SetExtendedData + public :: xmlf_GetExtendedData + + interface xml_AddCharacters + module procedure xml_AddCharacters_Ch + end interface + interface xml_AddAttribute + module procedure xml_AddAttribute_Ch + end interface + interface xml_AddPseudoAttribute + module procedure xml_AddPseudoAttribute_Ch + end interface + +#ifndef DUMMYLIB + !overload error handlers to allow file info + interface wxml_warning + module procedure wxml_warning_xf, FoX_warning_base + end interface + interface wxml_error + module procedure wxml_error_xf, FoX_error_base + end interface + interface wxml_fatal + module procedure wxml_fatal_xf, FoX_fatal_base + end interface + + ! Heuristic (approximate) target for justification of output + ! only gets used for outputting attributes + integer, parameter :: COLUMNS = 80 + + ! TOHW - This is the longest string that may be output without + ! a newline. The buffer must not be larger than this, but its size + ! can be tuned for performance. + !lowest value found so far is 4096, for NAG. We use 1024 just in case. + integer, parameter :: xml_recl = 1024 +#endif + +contains + + subroutine xml_OpenFile(filename, xf, unit, iostat, preserve_whitespace, & + pretty_print, minimize_overrun, canonical, replace, addDecl, warning, & + validate, namespace) + character(len=*), intent(in) :: filename + type(xmlf_t), intent(inout) :: xf + integer, intent(in), optional :: unit + integer, intent(out), optional :: iostat + logical, intent(in), optional :: preserve_whitespace + logical, intent(in), optional :: pretty_print + logical, intent(in), optional :: minimize_overrun + logical, intent(in), optional :: canonical + logical, intent(in), optional :: replace + logical, intent(in), optional :: addDecl + logical, intent(in), optional :: warning + logical, intent(in), optional :: validate + logical, intent(in), optional :: namespace + +#ifdef DUMMYLIB + if (present(iostat)) iostat = 0 +#else + logical :: repl, decl + integer :: iostat_ + + if (xf%lun /= -1) & + call wxml_fatal("Trying to reopen an already-open XML file") + + if (present(replace)) then + repl = replace + else + repl = .true. + endif + if (present(addDecl)) then + decl = addDecl + else + decl = .true. + endif + if (present(iostat)) iostat = 0 + + allocate(xf%name(0)) + + if (present(unit)) then + if (unit==-1) then + call get_unit(xf%lun,iostat_) + if (iostat_ /= 0) then + if (present(iostat)) iostat = iostat_ + return + endif + else + xf%lun = unit + endif + else + call get_unit(xf%lun,iostat_) + if (iostat_ /= 0) then + if (present(iostat)) iostat = iostat_ + return + endif + endif + + ! Use large I/O buffer in case the O.S./Compiler combination + ! has hard-limits by default (i.e., NAGWare f95's 1024 byte limit) + ! This is related to the maximum size of the buffer. + ! TOHW - This is the longest string that may be output without + ! a newline. The buffer must not be larger than this, but its size + ! can be tuned for performance. + + if (repl) then + ! NAG insists on unnecessary duplication of iostat etc here + if (present(iostat)) then + open(unit=xf%lun, file=filename, form="formatted", status="replace", & + action="write", recl=xml_recl, iostat=iostat) + else + open(unit=xf%lun, file=filename, form="formatted", status="replace", & + action="write", recl=xml_recl) + endif + else + if (present(iostat)) then + open(unit=xf%lun, file=filename, form="formatted", status="new", & + action="write", recl=xml_recl, iostat=iostat) + else + open(unit=xf%lun, file=filename, form="formatted", status="new", & + action="write", recl=xml_recl) + endif + endif + + call init_elstack(xf%stack) + + call init_dict(xf%dict) + !NB it can make no difference which XML version we are using + !until after we output the XML declaration. So we set it to + !1.0 for the moment & reset below. + ! Actually, this is done automatically in initializing xf%xds + call init_xml_doc_state(xf%xds) + xf%xds%documentURI => vs_str_alloc(filename) + + if (present(warning)) then + xf%xds%warning = warning + else + xf%xds%warning = .false. + endif + if (present(validate)) then + xf%xds%valid = validate + else + xf%xds%valid = .false. + endif + xf%state_1 = WXML_STATE_1_JUST_OPENED + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + xf%state_3 = WXML_STATE_3_BEFORE_DTD + + if (present(pretty_print)) then + xf%pretty_print = pretty_print + else + xf%pretty_print = .true. + endif + if (present(minimize_overrun)) then + xf%minimize_overrun = minimize_overrun + else + xf%minimize_overrun = .false. + endif + if (present(preserve_whitespace)) then + xf%pretty_print = .not.preserve_whitespace + xf%minimize_overrun = preserve_whitespace + endif + if (present(canonical)) then + xf%canonical = canonical + else + xf%canonical = .false. + endif +! FIXME interplay of above options + + xf%indent = 0 + + if (decl) then + call xml_AddXMLDeclaration(xf,encoding='UTF-8') + ! which will reset the buffer itself + else + call reset_buffer(xf%buffer, xf%lun, xf%xds%xml_version) + endif + + if (present(namespace)) then + xf%namespace = namespace + else + xf%namespace = .true. + endif + if (xf%namespace) & + call initNamespaceDictionary(xf%nsDict) +#endif + end subroutine xml_OpenFile + + + subroutine xml_AddXMLDeclaration(xf, version, encoding, standalone) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in), optional :: version + character(len=*), intent(in), optional :: encoding + logical, intent(in), optional :: standalone + +#ifndef DUMMYLIB + call check_xf(xf) + ! Don't need to call checkChars on args, everything is checked + ! fully below anyway. + + if (xf%state_1 /= WXML_STATE_1_JUST_OPENED) & + call wxml_error("Tried to put XML declaration in wrong place") + + call reset_buffer(xf%buffer, xf%lun, xf%xds%xml_version) + + call xml_AddXMLPI(xf, "xml", xml=.true.) + if (present(version)) then + if (version =="1.0") then + xf%xds%xml_version = XML1_0 + call xml_AddPseudoAttribute(xf, "version", version) + elseif (version=="1.1") then + xf%xds%xml_version = XML1_1 + call xml_AddPseudoAttribute(xf, "version", version) + else + call wxml_error("Invalid XML version.") + endif + else + call xml_AddPseudoAttribute(xf, "version", "1.0") + xf%xds%xml_version = XML1_0 + endif + if (present(encoding)) then + if (.not.checkEncName(encoding)) & + call wxml_error("Invalid encoding name: "//encoding) + if (encoding /= 'UTF-8' .and. encoding /= 'utf-8') & + call wxml_warning(xf, "Non-default encoding specified: "//encoding) + call xml_AddPseudoAttribute(xf, "encoding", encoding) + endif + if (present(standalone)) then + xf%xds%standalone_declared = .true. + xf%xds%standalone = standalone + if (standalone) then + call xml_AddPseudoAttribute(xf, "standalone", "yes") + else + call xml_AddPseudoAttribute(xf, "standalone", "no") + endif + endif + call close_start_tag(xf) + ! We have to close explicitly here to ensure nothing gets tied + ! up in the XML declaration + xf%state_1 = WXML_STATE_1_BEFORE_ROOT +#endif + end subroutine xml_AddXMLDeclaration + + + subroutine xml_AddDOCTYPE(xf, name, system, public) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in), optional :: system, public + +#ifndef DUMMYLIB + type(URI), pointer :: URIref + + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + + if (present(system)) then + URIref => parseURI(system) + if (.not.associated(URIref)) call wxml_error("xml_AddDOCTYPE: Invalid SYSTEM URI") + call destroyURI(URIref) + endif + if (present(public)) then + if (.not.checkPublicId(public)) call wxml_error("xml_AddDOCTYPE: Invalid PUBLIC ID") + endif + + if (present(public).and..not.present(system)) & + call wxml_error('xml_AddDOCTYPE: PUBLIC supplied without SYSTEM for: '//name) + + ! By having an external ID we probably render this non-standalone (unless we've said that it is in the declaration) + if (present(system).and..not.xf%xds%standalone_declared) & + xf%xds%standalone=.false. + + call close_start_tag(xf) + + if (xf%state_1 /= WXML_STATE_1_BEFORE_ROOT) & + call wxml_error("Tried to put XML DOCTYPE in wrong place: "//name) + + if (xf%state_3 /= WXML_STATE_3_BEFORE_DTD) then + call wxml_error("Tried to output more than one DOCTYPE declaration: "//name) + else + xf%state_3 = WXML_STATE_3_DURING_DTD + endif + + call add_eol(xf) + call add_to_buffer(" null() +#endif + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + + if (present(PEDef)) then + if (.not.checkChars(PEDef,xf%xds%xml_version)) call wxml_error("xml_AddParameterEntity: Invalid character in PEDef") + endif + + if (present(system)) then + URIref => parseURI(system) + if (.not.associated(URIref)) call wxml_error("xml_AddParameterEntity: Invalid SYSTEM URI") + call destroyURI(URIref) + endif + if (present(public)) then + if (.not.checkPublicId(public)) call wxml_error("xml_AddParameterEntity: Invalid PUBLIC ID") + endif + + ! By adding a parameter entity (internal or external) we make this + ! a non-standalone document. + if (.not.xf%xds%standalone_declared) & + xf%xds%standalone = .false. + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot define Parameter Entity here: "//name) + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + if (present(PEdef)) then + if (present(system) .or. present(public)) & + call wxml_fatal("Parameter entity "//name//" cannot have both a PEdef and an External ID") + else + if (.not.present(system)) & + call wxml_fatal("Parameter entity "//name//" must have either a PEdef or an External ID") + endif + if (present(PEdef)) then + if (.not.checkPEDef(PEDef, xf%xds%xml_version)) & + call wxml_fatal("Parameter entity definition is invalid: "//PEDef) + if (xf%xds%standalone) then + if (.not.checkExistingRefs()) & + call wxml_error("Tried to reference unregistered parameter entity") + else + if (.not.checkExistingRefs()) & + call wxml_warning(xf, "Reference to unknown parameter entity") + endif +#ifdef PGF90 + call register_internal_PE(xf%xds, name=name, text=PEdef, baseURI=nullURIref, wfc=.false.) +#else + call register_internal_PE(xf%xds, name=name, text=PEdef, baseURI=null(), wfc=.false.) +#endif + + else +#ifdef PGF90 + call register_external_PE(xf%xds, name=name, systemId=system, & + publicId=public, baseURI=nullURIref, wfc=.false.) +#else + call register_external_PE(xf%xds, name=name, systemId=system, & + publicId=public, baseURI=null(), wfc=.false.) +#endif + endif + + call add_eol(xf) + + call add_to_buffer(" 0) then ! FIXME what if PEdef has both " and ' in it + call add_to_buffer(" '"//PEdef//"'", xf%buffer, .true.) + else + call add_to_buffer(" """//PEdef//"""", xf%buffer, .true.) + endif + call add_to_buffer(">", xf%buffer, .false.) + else + if (present(public)) then + call add_to_buffer(" PUBLIC", xf%buffer, .false.) + call add_to_buffer(" """//public//"""", xf%buffer, .true.) + else + call add_to_buffer(" SYSTEM", xf%buffer, .false.) + endif + if (scan(system, """")/=0) then + call add_to_buffer(" '"//system//"'", xf%buffer, .true.) + else + call add_to_buffer(" """//system//"""", xf%buffer, .true.) + endif + call add_to_buffer(">", xf%buffer) + endif + + contains + function checkExistingRefs() result(p) + logical :: p + + integer :: i1, i2 + + ! Here we assume we have syntactic well-formedness as + ! checked by checkPEDef. + + p = .false. + i1 = index(PEDef, '%') + i2 = 0 + do while (i1 > 0) + i1 = i2 + i1 + i2 = index(PEDef(i1+1:),';') + if (i2 == 0) return + i2 = i1 + i2 + if (.not.existing_entity(xf%xds%PEList, PEDef(i1+1:i2-1))) & + return + i1 = index(PEDef(i2+1:), '%') + enddo + p = .true. + + end function checkExistingRefs +#endif + end subroutine xml_AddParameterEntity + + + subroutine xml_AddInternalEntity(xf, name, value) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + +#ifndef DUMMYLIB +#ifdef PGF90 + type(URI), pointer :: nullURI + nullURI => null() +#endif + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + + if (.not.checkChars(value, xf%xds%xml_version)) call wxml_error("xml_AddInternalEntity: Invalid character in value") + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot define Entity here: "//name) + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("xml_AddInternalEntity: Invalid Name: "//name) +#ifdef PGF90 + call register_internal_GE(xf%xds, name=name, text=value, baseURI=nullURI, wfc=.false.) +#else + call register_internal_GE(xf%xds, name=name, text=value, baseURI=null(), wfc=.false.) +#endif + + call add_eol(xf) + + !FIXME - valid entity values? + call add_to_buffer(" 0) then + call add_to_buffer("'"//value//"'>", xf%buffer, .true.) + else + call add_to_buffer(""""//value//""">", xf%buffer, .true.) + endif +#endif + end subroutine xml_AddInternalEntity + + + subroutine xml_AddExternalEntity(xf, name, system, public, notation) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: system + character(len=*), intent(in), optional :: public + character(len=*), intent(in), optional :: notation + +#ifndef DUMMYLIB + type(URI), pointer :: URIref +#ifdef PGF90 + type(URI), pointer :: nullURI + nullURI => null() +#endif + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + URIref => parseURI(system) + if (.not.associated(URIref)) call wxml_error("xml_AddExternalEntity: Invalid SYSTEM URI") + call destroyURI(URIref) + if (present(public)) then + if (.not.checkPublicId(public)) call wxml_error("xml_AddExternalEntity: Invalid PUBLIC ID") + endif + if (present(notation)) then + if (xf%namespace) then + if (.not.checkNCName(notation, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(notation, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + endif + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot define Entity here: "//name) + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + ! Notation only needs checked if not already registered - done above. +#ifdef PGF90 + call register_external_GE(xf%xds, name=name, & + systemID=system, publicId=public, notation=notation, & + baseURI=nullURI, wfc=.false.) +#else + call register_external_GE(xf%xds, name=name, & + systemID=system, publicId=public, notation=notation, & + baseURI=null(), wfc=.false.) +#endif + + call add_eol(xf) + + call add_to_buffer("", xf%buffer, .false.) +#endif + end subroutine xml_AddExternalEntity + + + subroutine xml_AddNotation(xf, name, system, public) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in), optional :: system + character(len=*), intent(in), optional :: public + +#ifndef DUMMYLIB + type(URI), pointer :: URIref + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + if (present(system)) then + URIref => parseURI(system) + if (.not.associated(URIref)) call wxml_error("xml_AddNotation: Invalid SYSTEM URI") + call destroyURI(URIref) + endif + if (present(public)) then + if (.not.checkPublicId(public)) call wxml_error("xml_AddNotation: Invalid PUBLIC ID") + endif + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot define Notation here: "//name) + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + if (notation_exists(xf%xds%nList, name)) & + call wxml_error("Tried to create duplicate notation: "//name) + + call add_eol(xf) + + call add_notation(xf%xds%nList, name, system, public) + call add_to_buffer(" 0) then + call add_to_buffer(" '"//system//"'", xf%buffer, .true.) + else + call add_to_buffer(" """//system//"""", xf%buffer, .true.) + endif + endif + call add_to_buffer(">", xf%buffer, .false.) +#endif + end subroutine xml_AddNotation + + + subroutine xml_AddElementToDTD(xf, name, declaration) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: declaration + +#ifndef DUMMYLIB + type(error_stack) :: stack +#ifdef PGF90 + type (element_t), pointer :: nullElement + + nullElement => null() +#endif + call check_xf(xf) + + if (.not.checkChars(declaration,xf%xds%xml_version)) call wxml_error("xml_AddElementToDTD: Invalid character in declaration") + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Element Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Element Name in DTD "//name) + endif +#ifdef PGF90 + call parse_dtd_element(declaration, xf%xds%xml_version, stack, nullElement, .true.) +#else + call parse_dtd_element(declaration, xf%xds%xml_version, stack, null(), .true.) +#endif + if (in_error(stack)) call wxml_error(xf, "Invalid ELEMENT declaration") + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot write to DTD here: xml_AddElementToDTD") + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + call add_eol(xf) + call add_to_buffer("", xf%buffer, .false.) +#endif + end subroutine xml_AddElementToDTD + + + subroutine xml_AddAttlistToDTD(xf, name, declaration) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: declaration + +#ifndef DUMMYLIB + type(error_stack) :: stack +#ifdef PGF90 + type (element_t), pointer :: nullElement + + nullElement => null() +#endif + call check_xf(xf) + + if (.not.checkChars(declaration,xf%xds%xml_version)) call wxml_error("xml_AddAttListToDTD: Invalid character in declaration") + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Attribute Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Attribute Name in DTD "//name) + endif + +#ifdef PGF90 + call parse_dtd_attlist(declaration, xf%xds%xml_version, & + validCheck=.false., namespaces=xf%namespace, stack=stack, & + elem=nullElement, internal=.true.) +#else + call parse_dtd_attlist(declaration, xf%xds%xml_version, & + validCheck=.false., namespaces=xf%namespace, stack=stack, & + elem=null(), internal=.true.) +#endif + + if (in_error(stack)) call wxml_error(xf, "Invalid ATTLIST declaration") + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot write to DTD here: xml_AddAttlistToDTD") + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + call add_eol(xf) + call add_to_buffer("", xf%buffer, .false.) +#endif + end subroutine xml_AddAttlistToDTD + + + subroutine xml_AddPEReferenceToDTD(xf, name) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + +#ifndef DUMMYLIB + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid PE Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid PE Name in DTD "//name) + endif + + call wxml_warning(xf, "Adding PEReference to DTD. Cannot guarantee well-formedness") + if (.not.existing_entity(xf%xds%PEList, name)) then + if (.not.xf%xds%standalone) then + call wxml_warning(xf, "Tried to reference possibly unregistered parameter entity in DTD: "//name) + else + call wxml_error("Tried to reference unregistered parameter entity in DTD "//name) + endif + else + if (is_unparsed_entity(xf%xds%PEList, name)) & + call wxml_error("Tried to reference unparsed parameter entity in DTD "//name) + endif + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot write to DTD here: xml_AddPEReferenceToDTD") + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + call add_eol(xf) + call add_to_buffer("%"//name//";", xf%buffer, .false.) + +#endif + end subroutine xml_AddPEReferenceToDTD + + + subroutine xml_AddXMLStylesheet(xf, href, type, title, media, charset, alternate) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: href + character(len=*), intent(in) :: type + character(len=*), intent(in), optional :: title + character(len=*), intent(in), optional :: media + character(len=*), intent(in), optional :: charset + logical, intent(in), optional :: alternate + +#ifndef DUMMYLIB + call check_xf(xf) + ! Don't bother checking name - all pseudoatts get checked anyway. + + if (xf%state_1 /= WXML_STATE_1_JUST_OPENED & + .and. xf%state_1 /= WXML_STATE_1_BEFORE_ROOT) & + call wxml_error("Cannot add stylesheet here: "//href) + + call close_start_tag(xf) + + call xml_AddXMLPI(xf, 'xml-stylesheet', xml=.true.) + call xml_AddPseudoAttribute(xf, 'href', href) + call xml_AddPseudoAttribute(xf, 'type', type) + + if (present(title)) call xml_AddPseudoAttribute(xf, 'title', title) + if (present(media)) call xml_AddPseudoAttribute(xf, 'media', media) + if (present(charset)) call xml_AddPseudoAttribute(xf, 'charset', charset) + if (present(alternate)) then + if (alternate) then + call xml_AddPseudoAttribute(xf, 'alternate', 'yes') + else + call xml_AddPseudoAttribute(xf, 'alternate', 'no') + endif + endif + if (xf%state_1 == WXML_STATE_1_JUST_OPENED) & + xf%state_1 = WXML_STATE_1_BEFORE_ROOT + xf%state_2 = WXML_STATE_2_INSIDE_PI +#endif + end subroutine xml_AddXMLStylesheet + + + subroutine xml_AddXMLPI(xf, name, data, xml, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in), optional :: data + logical, intent(in), optional :: xml + logical, intent(in), optional :: ws_significant + + logical :: xml_ +#ifndef DUMMYLIB + call check_xf(xf) + + if (present(xml)) then + xml_ = xml + else + xml_ = .false. + endif + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid PI target "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid PI target "//name) + endif + if (.not.xml_) then + if (len(name)==3.and.(toLower(name)=="xml")) & + call wxml_error("Invalid PI target "//name) + endif + + if (present(data)) then + if (.not.checkChars(data,xf%xds%xml_version)) & + call wxml_error("xml_AddXMLPI: Invalid character in data") + endif + + select case (xf%state_1) + case (WXML_STATE_1_JUST_OPENED) + xf%state_1 = WXML_STATE_1_BEFORE_ROOT + case (WXML_STATE_1_DURING_ROOT) + call close_start_tag(xf) + if (xf%pretty_print) call add_eol(xf) + case default + call close_start_tag(xf) + call add_eol(xf) + end select + call add_to_buffer("0) then + if (index(data, '?>') > 0) & + call wxml_error(xf, "Tried to output invalid PI data "//data) + call add_to_buffer(' ', xf%buffer, .false.) + call add_to_buffer(data//'?>', xf%buffer, ws_significant) + ! state_2 is now OUTSIDE_TAG from close_start_tag + else + xf%state_2 = WXML_STATE_2_INSIDE_PI + call reset_dict(xf%dict) + endif + else + xf%state_2 = WXML_STATE_2_INSIDE_PI + call reset_dict(xf%dict) + endif +#endif + end subroutine xml_AddXMLPI + + + subroutine xml_AddComment(xf, comment, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: comment + logical, intent(in), optional :: ws_significant + +#ifndef DUMMYLIB + call check_xf(xf) + if (.not.checkChars(comment,xf%xds%xml_version)) call wxml_error("xml_AddComment: Invalid character in comment") + + select case (xf%state_1) + case (WXML_STATE_1_JUST_OPENED) + xf%state_1 = WXML_STATE_1_BEFORE_ROOT + case (WXML_STATE_1_DURING_ROOT) + call close_start_tag(xf) + if (xf%pretty_print.and.xf%state_2 == WXML_STATE_2_OUTSIDE_TAG) call add_eol(xf) + case default + call close_start_tag(xf) + call add_eol(xf) + end select + + if (index(comment,'--') > 0 .or. comment(len(comment):) == '-') & + call wxml_error("Tried to output invalid comment "//comment) + + call add_to_buffer("", xf%buffer, .false.) +#endif + end subroutine xml_AddComment + + + subroutine xml_NewElement(xf, name) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + +#ifndef DUMMYLIB + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Element Name "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Element Name "//name) + endif + + select case (xf%state_1) + case (WXML_STATE_1_JUST_OPENED, WXML_STATE_1_BEFORE_ROOT) + if (xf%xds%valid) then + if (size(xf%name)==0) then + call wxml_error(xf, "No DTD specified for document") + elseif (str_vs(xf%name) /= name) then + call wxml_error(xf, "Root element name does not match DTD") + endif + endif + call close_start_tag(xf) + if (xf%state_3 /= WXML_STATE_3_BEFORE_DTD) then + select case (xf%state_3) + case (WXML_STATE_3_DURING_DTD) + call add_to_buffer('>', xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_AFTER_DTD + case (WXML_STATE_3_INSIDE_INTSUBSET) + xf%state_3 = WXML_STATE_3_AFTER_DTD + call add_eol(xf) + call add_to_buffer(']>', xf%buffer, .false.) + end select + endif + call add_eol(xf) + case (WXML_STATE_1_DURING_ROOT) + call close_start_tag(xf) + if (xf%pretty_print) call add_eol(xf) + case (WXML_STATE_1_AFTER_ROOT) + call wxml_error(xf, "Two root elements: "//name) + end select + + if (xf%namespace) then + if (len(prefixOfQName(name)) > 0) then + if (.not.isPrefixInForce(xf%nsDict, prefixOfQName(name))) & + call wxml_error(xf, "Namespace prefix not registered: "//prefixOfQName(name)) + endif + endif + + call push_elstack(xf%stack, name) + call add_to_buffer("<"//name, xf%buffer, .false.) + xf%state_2 = WXML_STATE_2_INSIDE_ELEMENT + call reset_dict(xf%dict) + xf%indent = xf%indent + indent_inc + xf%state_1 = WXML_STATE_1_DURING_ROOT +#endif + end subroutine xml_NewElement + + + subroutine xml_AddCharacters_ch(xf, chars, parsed, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: chars + logical, intent(in), optional :: parsed + logical, intent(in), optional :: ws_significant + +#ifndef DUMMYLIB + logical :: pc + + call check_xf(xf) + if (.not.checkChars(chars, xf%xds%xml_version)) call wxml_error("xml_AddCharacters: Invalid character in chars") + + if (xf%state_1 /= WXML_STATE_1_DURING_ROOT) & + call wxml_fatal("Tried to add text section in wrong place: "//chars) + + if (present(parsed)) then + pc = parsed + else + pc = .true. + endif + + call close_start_tag(xf) + + if (pc) then + call add_to_buffer(escape_string(chars, xf%xds%xml_version), xf%buffer, ws_significant) + else + ! FIXME what if we try and output two separate character events? + ! need to keep track of this ... + if (index(chars,']]>') > 0) & + call wxml_fatal("Tried to output invalid CDATA: "//chars) + call add_to_buffer("", xf%buffer, ws_significant) + endif + + xf%state_2 = WXML_STATE_2_IN_CHARDATA +#endif + end subroutine xml_AddCharacters_Ch + + + subroutine xml_AddNewline(xf) + type(xmlf_t), intent(inout) :: xf + +#ifndef DUMMYLIB + call xml_AddCharacters(xf, "") ! To ensure we are in a text section + call add_eol(xf) +#endif + end subroutine xml_AddNewline + + + subroutine xml_AddEntityReference(xf, name) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + +#ifndef DUMMYLIB + call check_xf(xf) + + if (likeCharacterEntityReference(name)) then + if (.not.checkCharacterEntityReference(name, xf%xds%xml_version)) & + call wxml_error("Invalid Character Entity Reference "//name) + elseif (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Entity Name "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Entity Name "//name) + endif + + call close_start_tag(xf) + + if (xf%state_2 /= WXML_STATE_2_OUTSIDE_TAG .and. & + xf%state_2 /= WXML_STATE_2_IN_CHARDATA) & + call wxml_fatal("Tried to add entity reference in wrong place: "//name) + + if (.not.checkCharacterEntityReference(name, xf%xds%xml_version)) then + !it's not just a unicode entity + call wxml_warning(xf, "Entity reference added - document may not be well-formed") + if (.not.existing_entity(xf%xds%entityList, name)) then + if (xf%xds%standalone) then + call wxml_error("Tried to reference unregistered entity") + else + call wxml_warning(xf, "Tried to reference unregistered entity") + endif + else + if (is_unparsed_entity(xf%xds%entityList, name)) & + call wxml_error("Tried to reference unparsed entity") + endif + endif + + call add_to_buffer('&'//name//';', xf%buffer, .false.) + xf%state_2 = WXML_STATE_2_IN_CHARDATA +#endif + end subroutine xml_AddEntityReference + + + subroutine xml_AddAttribute_Ch(xf, name, value, escape, type, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + logical, intent(in), optional :: escape + character(len=*), intent(in), optional :: type + logical, intent(in), optional :: ws_significant + +#ifndef DUMMYLIB + logical :: esc + character, pointer :: type_(:) + + if (present(type)) then + if (type/='CDATA'.and.type/='ID'.and.type/='IDREF'.and.type/='IDREFS'.and.type/='NMTOKEN'.and.type/='NMTOKENS' & + .and.type/='ENTITY'.and.type/='ENTITIES'.and.type/='NOTATION') then + call wxml_fatal("Invalid type in xml_AddAttribute: "//type) + endif + type_ => vs_str_alloc(type) + else + ! We assume CDATA, but need to worry about whether the caller cares about whitespace ... + if (present(ws_significant)) then + if (ws_significant) then + type_ => vs_str_alloc('CDATA') + else + type_ => vs_str_alloc('CDANO') ! CDAta, whitespace Not significant + endif + else + type_ => vs_str_alloc('CDAMB') ! CDAta, whitespace MayBe significant + endif + endif + + call check_xf(xf) + + if (.not.checkChars(value, xf%xds%xml_version)) call wxml_error("xml_AddAttribute: Invalid character in value") + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Attribute Name "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Attribute Name "//name) + endif + + if (present(escape)) then + esc = escape + else + esc = .true. + endif + + if (name=="xml:space") then + ! The value can only be "default" or "preserve", by 2.10 + if (.not.esc) then + if (value/="default".and.value/="preserve") & + call wxml_fatal("Invalid value for xml:space attrbute") + endif + endif + + ! FIXME when escape is false we should still do full verification + ! where possible. + ! Currently - minimal check: only extra allowed is character entity references. + ! We check they exist, and are not unparsed. + ! Ideally we would fully expand all entity references (at least for + ! a standalone document where we can) and then + ! match the resultant production against [XML]-3.3.1. This is + ! initially too much work though, so we just check simple + ! syntactic constraint. + + if (.not.esc) then + if (.not.checkAttValue(value, xf%xds%xml_version)) & + call wxml_error(xf, "Invalid attribute value: "//value) + if (index(value, '&') > 0) then + ! There are entity references + ! They should exist (unless we are not standalone) and they must not be unparsed. + if (.not.checkExistingRefsInAttValue()) then + if (xf%xds%standalone) then + call wxml_error(xf, "outputting unknown entity. Cannot guarantee validity.") + else + call wxml_warning(xf, "Warning: outputting unknown entity. Cannot guarantee validity.") + endif + endif + if (.not.checkParsedRefsInAttValue()) & + call wxml_error(xf, "Warning: outputting unknown entity. Cannot guarantee validity.") + endif + endif + + if (xf%state_2 /= WXML_STATE_2_INSIDE_ELEMENT) & + call wxml_error(xf, "attributes outside element content: "//name) + + if (hasKey(xf%dict,name)) then + call wxml_error(xf, "duplicate att name: "//name) + elseif (xf%namespace) then + if (hasKey(xf%dict, & + getnamespaceURI(xf%nsDict,prefixOfQname(name)), localpartofQname(name))) then + call wxml_error(xf, "duplicate att after namespace processing: "//name) + endif + endif + + if (xf%namespace) then + if (len(prefixOfQName(name))>0) then + if (prefixOfQName(name)/="xml".and.prefixOfQName(name)/="xmlns") then + if (.not.isPrefixInForce(xf%nsDict, prefixOfQName(name))) & + call wxml_error(xf, "namespace prefix not registered: "//prefixOfQName(name)) + endif + if (esc) then + call add_item_to_dict(xf%dict, localpartofQname(name), escape_string(value, xf%xds%xml_version), prefixOfQName(name), & + getnamespaceURI(xf%nsDict,prefixOfQname(name)), type=str_vs(type_)) + else + call add_item_to_dict(xf%dict, localpartofQname(name), value, prefixOfQName(name), & + getnamespaceURI(xf%nsDict,prefixOfQName(name)), type=str_vs(type_)) + endif + else + if (esc) then + call add_item_to_dict(xf%dict, name, escape_string(value, xf%xds%xml_version), type=str_vs(type_)) + else + call add_item_to_dict(xf%dict, name, value, type=str_vs(type_)) + endif + endif + else + if (esc) then + call add_item_to_dict(xf%dict, name, escape_string(value, xf%xds%xml_version), type=str_vs(type_)) + else + call add_item_to_dict(xf%dict, name, value, type=str_vs(type_)) + endif + endif + + !FIXME need to deallocate this when we move to better error handling + deallocate(type_) + + contains + function checkExistingRefsInAttValue() result(p) + logical :: p + + integer :: i1, i2 + + ! Here we assume we have syntactic well-formedness as + ! checked by checkAttValue. + ! We also assume we do not have simply one entity as + ! the contents - that is checked by checkAttValueEntity + + p = .false. + 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 (.not.existing_entity(xf%xds%entityList, value(i1+1:i2-1)) .and. & + .not.checkCharacterEntityReference(value(i1+1:i2-1), xf%xds%xml_version)) & + return + i1 = index(value(i2+1:), '&') + enddo + p = .true. + + end function checkExistingRefsInAttValue + + function checkParsedRefsInAttValue() result(p) + logical :: p + + integer :: i1, i2 + + ! Here we assume we have syntactic well-formedness as + ! checked by checkAttValue. + + p = .false. + i1 = index(value, '&') + i2 = 0 + do while (i1 > 0) + i1 = i1 + i2 + i2 = index(value(i1+1:),';') + if (i2 == 0) return + i2 = i1 + i2 + if (is_unparsed_entity(xf%xds%entityList, value(i1+1:i2-1))) & + return + i1 = index(value(i2+1:), '&') + enddo + p = .true. + + end function checkParsedRefsInAttValue +#endif + end subroutine xml_AddAttribute_Ch + + + subroutine xml_AddPseudoAttribute_Ch(xf, name, value, escape, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + logical, intent(in), optional :: escape + logical, intent(in), optional :: ws_significant + +#ifndef DUMMYLIB + logical :: esc + character(len=5) :: type + + call check_xf(xf) + if (.not.checkChars(name, xf%xds%xml_version)) call wxml_error("xml_AddPseudoAttribute: Invalid character in name") + if (.not.checkChars(value, xf%xds%xml_version)) call wxml_error("xml_AddPseudoAttribute: Invalid character in value") + + if (present(escape)) then + esc = escape + else + esc = .true. + endif + if (present(ws_significant)) then + if (ws_significant) then + type='CDATA' + else + type='CDANO' ! CDAta, whitespace Not significant + endif + else + type='CDAMB' ! CDAta, whitespace MayBe significant + endif + + if (index(value, '?>') > 0) & + call wxml_error(xf, "Invalid pseudo-attribute value: "//value) + if (.not.esc) then + if (.not.checkPseudoAttValue(value, xf%xds%xml_version)) & + call wxml_error(xf, "Invalid pseudo-attribute value: "//value) + endif + + if (xf%state_2 /= WXML_STATE_2_INSIDE_PI) & + call wxml_error("PI pseudo-attribute outside PI: "//name) + + ! This is mostly ad-hoc, pseudo-attribute names are not defined anywhere. + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid pseudo-attribute name: "//name) + + if (hasKey(xf%dict,name)) & + call wxml_error(xf, "duplicate pseudo-attribute name: "//name) + + if (index(value, '?>') > 0) & + call wxml_error(xf, "Invalid pseudo-attribute data: "//value) + + if (esc) then + call add_item_to_dict(xf%dict, name, escape_string(value, xf%xds%xml_version), type=type) + else + call add_item_to_dict(xf%dict, name, value, type=type) + endif +#endif + end subroutine xml_AddPseudoAttribute_Ch + + + subroutine xml_EndElement(xf, name) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + + character :: dummy +#ifndef DUMMYLIB + call check_xf(xf) + ! No point in doing checkChars, name is compared to stack anyway. + + if (len(xf%stack) == 0) & + call wxml_fatal(xf,'Trying to close '//name//' but no tags are open.') + + if (get_top_elstack(xf%stack) /= name) & + call wxml_fatal(xf, 'Trying to close '//name//' but '//get_top_elstack(xf%stack)// & + ' is open. Either you have failed to open '//name//& + ' or you have failed to close '//get_top_elstack(xf%stack)//'.') + xf%indent = xf%indent - indent_inc + + if (xf%state_2==WXML_STATE_2_INSIDE_ELEMENT) then + if (xf%namespace) call checkNamespacesWriting(xf%dict, xf%nsDict, len(xf%stack)) + if (getLength(xf%dict) > 0) call write_attributes(xf) + if (xf%minimize_overrun) call add_eol(xf) + endif + if (xf%state_2==WXML_STATE_2_INSIDE_ELEMENT.and..not.xf%canonical) then + call add_to_buffer("/>", xf%buffer, .false.) + else + if (xf%state_2==WXML_STATE_2_INSIDE_ELEMENT) & + call add_to_buffer('>', xf%buffer, .false.) + if (xf%state_2==WXML_STATE_2_INSIDE_PI) & + call close_start_tag(xf) + if (xf%state_2==WXML_STATE_2_OUTSIDE_TAG.and.xf%pretty_print) & + call add_eol(xf) +! XLF does a weird thing here, and if pop_elstack is called as an +! argument to the add_to_buffer, it gets called twice. So we have to separate +! out get_top_... from pop_... + call add_to_buffer("", xf%buffer, .false.) + endif + dummy = pop_elstack(xf%stack) + + if (xf%namespace) call checkEndNamespaces(xf%nsDict, len(xf%stack)+1) + if (is_empty(xf%stack)) then + xf%state_1 = WXML_STATE_1_AFTER_ROOT + endif + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG +#endif + end subroutine xml_EndElement + + + subroutine xml_DeclareNamespace(xf, nsURI, prefix, xml) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: nsURI + character(len=*), intent(in), optional :: prefix + logical, intent(in), optional :: xml + +#ifndef DUMMYLIB + call check_xf(xf) + if (.not.xf%namespace) call wxml_error("Cannot declare a namespace in a non-namespaced document") + + !if (.not.checkNCName(nsURI, xf%xds%xml_version)) call wxml_error("xml_DeclareNamespace: Invalid nsURI") + if (present(prefix)) then + if (.not.checkNCName(prefix, xf%xds%xml_version)) call wxml_error("xml_DeclareNamespace: Invalid prefix") + endif + + if (xf%state_1 == WXML_STATE_1_AFTER_ROOT) & + call wxml_error(xf, "adding namespace outside element content") + + if (len(nsURI) == 0) then + if (present(prefix).and.xf%xds%xml_version==XML1_0) & + call wxml_error(xf, "prefixed namespace with empty URI forbidden in XML 1.0") + endif + + if (present(prefix)) then + call addPrefixedNS(xf%nsDict, prefix, nsURI, len(xf%stack)+1, xf%xds, xml) + else + call addDefaultNS(xf%nsDict, nsURI, len(xf%stack)+1) + endif +#endif + end subroutine xml_DeclareNamespace + + + subroutine xml_UndeclareNamespace(xf, prefix) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in), optional :: prefix + +#ifndef DUMMYLIB + call check_xf(xf) + !No need to checkChars, prefix is checked against stack + if (.not.xf%namespace) call wxml_error("Cannot declare a namespace in a non-namespaced document") + + if (present(prefix).and.xf%xds%xml_version==XML1_0) & + call wxml_error("cannot undeclare prefixed namespaces in XML 1.0") + + if (xf%state_1 == WXML_STATE_1_AFTER_ROOT) & + call wxml_error(xf, "Undeclaring namespace outside element content") + + if (present(prefix)) then + call addPrefixedNS(xf%nsDict, prefix, "", len(xf%stack)+1, xf%xds) + else + call addDefaultNS(xf%nsDict, "", len(xf%stack)+1) + endif +#endif + end subroutine xml_UndeclareNamespace + + + subroutine xml_Close(xf, empty) + type(xmlf_t), intent(inout) :: xf + logical, optional :: empty + +#ifndef DUMMYLIB + logical :: empty_ + + if (present(empty)) then + empty_ = empty + else + empty_ = .false. + endif + + if (xf%lun == -1) & + call wxml_fatal('Tried to close XML file which is not open') + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) & + call close_start_tag(xf) + + if (xf%state_3 /= WXML_STATE_3_BEFORE_DTD & + .and. xf%state_3 /= WXML_STATE_3_AFTER_DTD) then + select case (xf%state_3) + case (WXML_STATE_3_DURING_DTD) + call add_to_buffer('>', xf%buffer, .false.) + case (WXML_STATE_3_INSIDE_INTSUBSET) + call add_eol(xf) + call add_to_buffer(']>', xf%buffer, .false.) + end select + xf%state_3 = WXML_STATE_3_AFTER_DTD + endif + + do while (xf%state_1 == WXML_STATE_1_DURING_ROOT) + call xml_EndElement(xf, get_top_elstack(xf%stack)) + enddo + + if (xf%state_1 /= WXML_STATE_1_AFTER_ROOT) then + if (empty_) then + call wxml_warning(xf, 'Invalid XML document produced: No root element') + else + call wxml_error(xf, 'Invalid XML document produced: No root element') + endif + endif + + call dump_buffer(xf%buffer) + close(unit=xf%lun) + xf%lun = -1 + + call destroy_dict(xf%dict) + call destroy_elstack(xf%stack) + + if (xf%namespace) & + call destroyNamespaceDictionary(xf%nsDict) + call destroy_xml_doc_state(xf%xds) + + deallocate(xf%name) +#endif + end subroutine xml_Close + + subroutine xmlf_SetPretty_print(xf, new_value) + type(xmlf_t), intent(inout) :: xf + logical, intent(in) :: new_value +#ifndef DUMMYLIB + xf%pretty_print = new_value +#endif + end subroutine xmlf_SetPretty_print + + pure function xmlf_GetPretty_print(xf) result(value) + logical :: value + type(xmlf_t), intent(in) :: xf +#ifdef DUMMYLIB + value = .false. +#else + value = xf%pretty_print +#endif + end function xmlf_GetPretty_print + +! xf%extended data is an integer so that writers +! can change there behaviour depending on some +! stored information. Currently only used for +! wcml 'validate' argument (which is intended to +! check some of the more troublesome aspects of +! the CML schema + subroutine xmlf_SetExtendedData(xf, new_value) + type(xmlf_t), intent(inout) :: xf + integer, intent(in) :: new_value +#ifndef DUMMYLIB + xf%extended_data = new_value +#endif + end subroutine xmlf_SetExtendedData + + pure function xmlf_GetExtendedData(xf) result(value) + integer :: value + type(xmlf_t), intent(in) :: xf +#ifdef DUMMYLIB + value = .false. +#else + value = xf%extended_data +#endif + end function xmlf_GetExtendedData + + pure function xmlf_name(xf) result(fn) + type (xmlf_t), intent(in) :: xf +#ifdef DUMMYLIB + character(len=1) :: fn + fn = " " +#else + character(len=size(xf%xds%documentURI)) :: fn + fn = str_vs(xf%xds%documentURI) +#endif + end function xmlf_name + +#ifndef DUMMYLIB + pure function xmlf_opentag_len(xf) result(n) + type (xmlf_t), intent(in) :: xf + integer :: n + + if (xf%lun == -1) then + n = 0 + elseif (is_empty(xf%stack)) then + n = 0 + else + n = len(get_top_elstack(xf%stack)) + endif + end function xmlf_opentag_len +#endif + + function xmlf_opentag(xf) result(fn) + type (xmlf_t), intent(in) :: xf +#ifdef DUMMYLIB + character(len=1) :: fn + fn = " " +#else + character(len=xmlf_opentag_len(xf)) :: fn + + if (xf%lun == -1) then + fn = '' + elseif (is_empty(xf%stack)) then + fn = '' + else + fn = get_top_elstack(xf%stack) + endif +#endif + end function xmlf_opentag + +#ifndef DUMMYLIB + + subroutine check_xf(xf) + type(xmlf_t), intent(inout) :: xf + if (xf%lun == -1) & + call wxml_fatal("Tried to manipulate an XML File which is not open") + + end subroutine check_xf + + + subroutine add_eol(xf) + type(xmlf_t), intent(inout) :: xf + + integer :: indent_level + + ! In case we still have a zero-length stack, we must make + ! sure indent_level is not less than zero. + if (xf%state_3 == WXML_STATE_3_INSIDE_INTSUBSET) then + indent_level = indent_inc + else + indent_level = xf%indent + endif + + !We must flush here (rather than just adding an eol character) + !since we don't know what the eol character is on this system. + !Flushing with a linefeed will get it automatically, though. + call dump_buffer(xf%buffer, lf=.true.) + call reset_buffer(xf%buffer, xf%lun, xf%xds%xml_version) + + if (xf%pretty_print) & + call add_to_buffer(repeat(' ',indent_level),xf%buffer, .false.) + + end subroutine add_eol + + + subroutine close_start_tag(xf) + type(xmlf_t), intent(inout) :: xf + + select case (xf%state_2) + case (WXML_STATE_2_INSIDE_ELEMENT) + if (xf%namespace) call checkNamespacesWriting(xf%dict, xf%nsDict, len(xf%stack)) + if (getLength(xf%dict) > 0) call write_attributes(xf) + if (xf%minimize_overrun) call add_eol(xf) + call add_to_buffer('>', xf%buffer, .false.) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + case (WXML_STATE_2_INSIDE_PI) + if (getLength(xf%dict) > 0) call write_attributes(xf) + call add_to_buffer('?>', xf%buffer, .false.) + if (xf%pretty_print.and.xf%state_3/=WXML_STATE_3_INSIDE_INTSUBSET) call add_eol(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + case (WXML_STATE_2_IN_CHARDATA) + continue + case (WXML_STATE_2_OUTSIDE_TAG) + continue + end select + + end subroutine close_start_tag + + + subroutine write_attributes(xf) + type(xmlf_t), intent(inout) :: xf + + integer :: i, j, size + + if (xf%state_2 /= WXML_STATE_2_INSIDE_PI .and. & + xf%state_2 /= WXML_STATE_2_INSIDE_ELEMENT) & + call wxml_fatal("Internal library error") + + if (xf%canonical) call sortAttrs(xf%dict) + + do i = 1, getLength(xf%dict) + size = len(get_key(xf%dict, i)) + len(get_value(xf%dict, i)) + 4 + if (xf%minimize_overrun.and.(len(xf%buffer) + size) > COLUMNS) then + call add_eol(xf) + else + call add_to_buffer(" ", xf%buffer, .false.) + endif + call add_to_buffer(get_key(xf%dict, i), xf%buffer, .false.) + call add_to_buffer("=", xf%buffer, .false.) + call add_to_buffer('"',xf%buffer, .false.) + j = getWhiteSpaceHandling(xf%dict, i) + if (j==0) then + call add_to_buffer(get_value(xf%dict, i), xf%buffer, .true.) + elseif (j==1) then + call add_to_buffer(get_value(xf%dict, i), xf%buffer) + else + call add_to_buffer(get_value(xf%dict, i), xf%buffer, .false.) + endif + call add_to_buffer('"', xf%buffer, .false.) + enddo + + end subroutine write_attributes + + subroutine wxml_warning_xf(xf, msg) + ! Emit warning, but carry on. + type(xmlf_t), intent(in) :: xf + character(len=*), intent(in) :: msg + + if (FoX_get_fatal_warnings()) then + write(6,'(a)') 'FoX warning made fatal' + call wxml_fatal_xf(xf, msg) + endif + + if (xf%xds%warning) then + write(6,'(a)') 'WARNING(wxml) in writing to file ', xmlf_name(xf) + write(6,'(a)') msg + endif + + end subroutine wxml_warning_xf + + + subroutine wxml_error_xf(xf, msg) + ! Emit error message, clean up file and stop. + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: msg + + if (FoX_get_fatal_errors()) then + write(6,'(a)') 'FoX error made fatal' + call wxml_fatal_xf(xf, msg) + endif + + write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf) + write(6,'(a)') msg + + !call xml_Close(xf) + stop + + end subroutine wxml_error_xf + + + subroutine wxml_fatal_xf(xf, msg) + !Emit error message and abort with coredump. Does not try to + !close file, so should be used from anything xml_Close might + !itself call (to avoid infinite recursion!) + + type(xmlf_t), intent(in) :: xf + character(len=*), intent(in) :: msg + + write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf) + write(6,'(a)') msg + + call pxfabort() + stop + + end subroutine wxml_fatal_xf + +#endif + +end module m_wxml_core diff --git a/src/xml/wxml/m_wxml_escape.F90 b/src/xml/wxml/m_wxml_escape.F90 new file mode 100644 index 000000000..99bfcdab0 --- /dev/null +++ b/src/xml/wxml/m_wxml_escape.F90 @@ -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) = "&" + c = c + 5 + case (LT) + s2(c:c+3) = "<" + c = c + 4 + case (GT) + s2(c:c+3) = ">" + c = c + 4 + case (QUOT) + s2(c:c+5) = """ + c = c + 6 + case (APOS) + s2(c:c+5) = "'" + c = c + 6 + case default + s2(c:c) = achar(ic) + c = c + 1 + end select + case (127) + s2(c:c+5) = "" + 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 diff --git a/src/xml/wxml/m_wxml_overloads.F90 b/src/xml/wxml/m_wxml_overloads.F90 new file mode 100644 index 000000000..5f6281dcb --- /dev/null +++ b/src/xml/wxml/m_wxml_overloads.F90 @@ -0,0 +1,1028 @@ +! This file is AUTOGENERATED!!!! +! Do not edit this file; edit m_wxml_overloads.m4 and regenerate. +! +! +module m_wxml_overloads + +#ifndef DUMMYLIB + use fox_m_fsys_format, only: str +#endif + use fox_m_fsys_realtypes, only: sp, dp + use m_wxml_core, only: xmlf_t + use m_wxml_core, only: xml_AddCharacters + use m_wxml_core, only: xml_AddAttribute + use m_wxml_core, only: xml_AddPseudoAttribute + + implicit none + private + + interface xml_AddCharacters + module procedure CharactersScalarCmplxDp + module procedure CharactersScalarCmplxSp + module procedure CharactersScalarRealDp + module procedure CharactersScalarRealSp + module procedure CharactersScalarInt + module procedure CharactersScalarLg + + module procedure CharactersArrayCmplxDp + module procedure CharactersArrayCmplxSp + module procedure CharactersArrayRealDp + module procedure CharactersArrayRealSp + module procedure CharactersArrayInt + module procedure CharactersArrayLg + module procedure CharactersArrayCh + module procedure CharactersMatrixCmplxDp + module procedure CharactersMatrixCmplxSp + module procedure CharactersMatrixRealDp + module procedure CharactersMatrixRealSp + module procedure CharactersMatrixInt + module procedure CharactersMatrixLg + module procedure CharactersMatrixCh + end interface + + interface xml_AddAttribute + module procedure AttributeScalarCmplxDp + module procedure AttributeScalarCmplxSp + module procedure AttributeScalarRealDp + module procedure AttributeScalarRealSp + module procedure AttributeScalarInt + module procedure AttributeScalarLg + + module procedure AttributeArrayCmplxDp + module procedure AttributeArrayCmplxSp + module procedure AttributeArrayRealDp + module procedure AttributeArrayRealSp + module procedure AttributeArrayInt + module procedure AttributeArrayLg + module procedure AttributeArrayCh + module procedure AttributeMatrixCmplxDp + module procedure AttributeMatrixCmplxSp + module procedure AttributeMatrixRealDp + module procedure AttributeMatrixRealSp + module procedure AttributeMatrixInt + module procedure AttributeMatrixLg + module procedure AttributeMatrixCh + end interface + + interface xml_AddPseudoAttribute + module procedure PseudoAttributeScalarCmplxDp + module procedure PseudoAttributeScalarCmplxSp + module procedure PseudoAttributeScalarRealDp + module procedure PseudoAttributeScalarRealSp + module procedure PseudoAttributeScalarInt + module procedure PseudoAttributeScalarLg + + module procedure PseudoAttributeArrayCmplxDp + module procedure PseudoAttributeArrayCmplxSp + module procedure PseudoAttributeArrayRealDp + module procedure PseudoAttributeArrayRealSp + module procedure PseudoAttributeArrayInt + module procedure PseudoAttributeArrayLg + module procedure PseudoAttributeArrayCh + module procedure PseudoAttributeMatrixCmplxDp + module procedure PseudoAttributeMatrixCmplxSp + module procedure PseudoAttributeMatrixRealDp + module procedure PseudoAttributeMatrixRealSp + module procedure PseudoAttributeMatrixInt + module procedure PseudoAttributeMatrixLg + module procedure PseudoAttributeMatrixCh + end interface + + public :: xml_AddCharacters + public :: xml_AddAttribute + public :: xml_AddPseudoAttribute + +contains + + subroutine CharactersScalarCmplxDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(dp), intent(in) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, "")) + endif +#endif + end subroutine CharactersScalarCmplxDp + + + subroutine CharactersScalarCmplxSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(sp), intent(in) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, "")) + endif +#endif + end subroutine CharactersScalarCmplxSp + + + subroutine CharactersScalarRealDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(dp), intent(in) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt)) + else + call xml_AddCharacters(xf=xf, chars=str(chars)) + endif +#endif + end subroutine CharactersScalarRealDp + + + subroutine CharactersScalarRealSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(sp), intent(in) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt)) + else + call xml_AddCharacters(xf=xf, chars=str(chars)) + endif +#endif + end subroutine CharactersScalarRealSp + + + subroutine CharactersScalarInt & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + integer, intent(in) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars)) +#endif + end subroutine CharactersScalarInt + + + subroutine CharactersScalarLg & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + logical, intent(in) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars)) +#endif + end subroutine CharactersScalarLg + + + + + subroutine CharactersArrayCmplxDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(dp), intent(in) , dimension(:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, ""), ws_significant=.false.) + endif +#endif + end subroutine CharactersArrayCmplxDp + + + subroutine CharactersArrayCmplxSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(sp), intent(in) , dimension(:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, ""), ws_significant=.false.) + endif +#endif + end subroutine CharactersArrayCmplxSp + + + subroutine CharactersArrayRealDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(dp), intent(in) , dimension(:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) + endif +#endif + end subroutine CharactersArrayRealDp + + + subroutine CharactersArrayRealSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(sp), intent(in) , dimension(:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) + endif +#endif + end subroutine CharactersArrayRealSp + + + subroutine CharactersArrayInt & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + integer, intent(in) , dimension(:) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) +#endif + end subroutine CharactersArrayInt + + + subroutine CharactersArrayLg & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + logical, intent(in) , dimension(:) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) +#endif + end subroutine CharactersArrayLg + + + subroutine CharactersArrayCh & + (xf, chars, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) , dimension(:) :: chars + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars, delimiter), ws_significant=.false.) +#endif + end subroutine CharactersArrayCh + + + subroutine CharactersMatrixCmplxDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(dp), intent(in) , dimension(:,:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, ""), ws_significant=.false.) + endif +#endif + end subroutine CharactersMatrixCmplxDp + + + subroutine CharactersMatrixCmplxSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(sp), intent(in) , dimension(:,:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, ""), ws_significant=.false.) + endif +#endif + end subroutine CharactersMatrixCmplxSp + + + subroutine CharactersMatrixRealDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(dp), intent(in) , dimension(:,:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) + endif +#endif + end subroutine CharactersMatrixRealDp + + + subroutine CharactersMatrixRealSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(sp), intent(in) , dimension(:,:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) + endif +#endif + end subroutine CharactersMatrixRealSp + + + subroutine CharactersMatrixInt & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + integer, intent(in) , dimension(:,:) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) +#endif + end subroutine CharactersMatrixInt + + + subroutine CharactersMatrixLg & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + logical, intent(in) , dimension(:,:) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) +#endif + end subroutine CharactersMatrixLg + + + subroutine CharactersMatrixCh & + (xf, chars, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) , dimension(:,:) :: chars + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars, delimiter), ws_significant=.false.) +#endif + end subroutine CharactersMatrixCh + + + + subroutine AttributeScalarCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, "")) + endif +#endif + end subroutine AttributeScalarCmplxDp + + subroutine AttributeScalarCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, "")) + endif +#endif + end subroutine AttributeScalarCmplxSp + + subroutine AttributeScalarRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt)) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value)) + endif +#endif + end subroutine AttributeScalarRealDp + + subroutine AttributeScalarRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt)) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value)) + endif +#endif + end subroutine AttributeScalarRealSp + + subroutine AttributeScalarInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value)) +#endif + end subroutine AttributeScalarInt + + subroutine AttributeScalarLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value)) +#endif + end subroutine AttributeScalarLg + + + subroutine AttributeArrayCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine AttributeArrayCmplxDp + + subroutine AttributeArrayCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine AttributeArrayCmplxSp + + subroutine AttributeArrayRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine AttributeArrayRealDp + + subroutine AttributeArrayRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine AttributeArrayRealSp + + subroutine AttributeArrayInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) , dimension(:) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine AttributeArrayInt + + subroutine AttributeArrayLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) , dimension(:) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine AttributeArrayLg + + subroutine AttributeArrayCh & + (xf, name, value, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) , dimension(:) :: value + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value, delimiter), ws_significant=.false.) +#endif + end subroutine AttributeArrayCh + + subroutine AttributeMatrixCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine AttributeMatrixCmplxDp + + subroutine AttributeMatrixCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine AttributeMatrixCmplxSp + + subroutine AttributeMatrixRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine AttributeMatrixRealDp + + subroutine AttributeMatrixRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine AttributeMatrixRealSp + + subroutine AttributeMatrixInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) , dimension(:,:) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine AttributeMatrixInt + + subroutine AttributeMatrixLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) , dimension(:,:) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine AttributeMatrixLg + + subroutine AttributeMatrixCh & + (xf, name, value, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) , dimension(:,:) :: value + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value, delimiter), ws_significant=.false.) +#endif + end subroutine AttributeMatrixCh + + + subroutine PseudoAttributeScalarCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, "")) + endif +#endif + end subroutine PseudoAttributeScalarCmplxDp + + subroutine PseudoAttributeScalarCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, "")) + endif +#endif + end subroutine PseudoAttributeScalarCmplxSp + + subroutine PseudoAttributeScalarRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt)) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value)) + endif +#endif + end subroutine PseudoAttributeScalarRealDp + + subroutine PseudoAttributeScalarRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt)) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value)) + endif +#endif + end subroutine PseudoAttributeScalarRealSp + + subroutine PseudoAttributeScalarInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value)) +#endif + end subroutine PseudoAttributeScalarInt + + subroutine PseudoAttributeScalarLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value)) +#endif + end subroutine PseudoAttributeScalarLg + + + subroutine PseudoAttributeArrayCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeArrayCmplxDp + + subroutine PseudoAttributeArrayCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeArrayCmplxSp + + subroutine PseudoAttributeArrayRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeArrayRealDp + + subroutine PseudoAttributeArrayRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeArrayRealSp + + subroutine PseudoAttributeArrayInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) , dimension(:) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine PseudoAttributeArrayInt + + subroutine PseudoAttributeArrayLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) , dimension(:) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine PseudoAttributeArrayLg + + subroutine PseudoAttributeArrayCh & + (xf, name, value, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) , dimension(:) :: value + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, delimiter), ws_significant=.false.) +#endif + end subroutine PseudoAttributeArrayCh + + subroutine PseudoAttributeMatrixCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeMatrixCmplxDp + + subroutine PseudoAttributeMatrixCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeMatrixCmplxSp + + subroutine PseudoAttributeMatrixRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeMatrixRealDp + + subroutine PseudoAttributeMatrixRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeMatrixRealSp + + subroutine PseudoAttributeMatrixInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) , dimension(:,:) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine PseudoAttributeMatrixInt + + subroutine PseudoAttributeMatrixLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) , dimension(:,:) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine PseudoAttributeMatrixLg + + subroutine PseudoAttributeMatrixCh & + (xf, name, value, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) , dimension(:,:) :: value + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, delimiter), ws_significant=.false.) +#endif + end subroutine PseudoAttributeMatrixCh + + +end module m_wxml_overloads diff --git a/src/xml_interface.F90 b/src/xml_interface.F90 new file mode 100644 index 000000000..4752c0873 --- /dev/null +++ b/src/xml_interface.F90 @@ -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 diff --git a/tests/test_output/settings.xml b/tests/test_output/settings.xml index 70116af72..fef5e2fcf 100644 --- a/tests/test_output/settings.xml +++ b/tests/test_output/settings.xml @@ -1,7 +1,7 @@ - summary cross_sections + 10