From de2e5433315df58171a60a1c58f1faafeaf5f772 Mon Sep 17 00:00:00 2001 From: Bryan Herman Date: Mon, 31 Mar 2014 15:23:59 -0400 Subject: [PATCH] removed all fox xml files --- src/xml/LICENSE | 71 - src/xml/Makefile | 32 - src/xml/README | 3 - src/xml/common/FoX_common.F90 | 55 - src/xml/common/Makefile | 59 - src/xml/common/m_common_attrs.F90 | 1081 -- src/xml/common/m_common_buffer.F90 | 261 - src/xml/common/m_common_charset.F90 | 447 - src/xml/common/m_common_content_model.F90 | 490 - src/xml/common/m_common_element.F90 | 1645 -- src/xml/common/m_common_elstack.F90 | 236 - src/xml/common/m_common_entities.F90 | 475 - src/xml/common/m_common_entity_expand.F90 | 86 - src/xml/common/m_common_error.F90 | 211 - src/xml/common/m_common_io.F90 | 102 - src/xml/common/m_common_namecheck.F90 | 501 - src/xml/common/m_common_namespaces.F90 | 830 - src/xml/common/m_common_notations.F90 | 120 - src/xml/common/m_common_struct.F90 | 121 - src/xml/dom/FoX_dom.F90 | 266 - src/xml/dom/Makefile | 49 - src/xml/dom/m_dom_dom.F90 | 12484 ---------------- src/xml/dom/m_dom_error.F90 | 211 - src/xml/dom/m_dom_extras.F90 | 2444 --- src/xml/dom/m_dom_parse.F90 | 577 - src/xml/dom/m_dom_utils.F90 | 437 - src/xml/fsys/Makefile | 48 - src/xml/fsys/fox_m_fsys_abort_flush.F90 | 124 - src/xml/fsys/fox_m_fsys_array_str.F90 | 94 - src/xml/fsys/fox_m_fsys_count_parse_input.F90 | 561 - src/xml/fsys/fox_m_fsys_format.F90 | 2250 --- src/xml/fsys/fox_m_fsys_parse_input.F90 | 2281 --- src/xml/fsys/fox_m_fsys_realtypes.F90 | 12 - src/xml/fsys/fox_m_fsys_string.F90 | 35 - src/xml/fsys/fox_m_fsys_string_list.F90 | 191 - src/xml/fsys/fox_m_fsys_varstr.F90 | 254 - src/xml/fsys/m_ieee.F90 | 17 - src/xml/sax/FoX_sax.F90 | 34 - src/xml/sax/Makefile | 50 - src/xml/sax/m_sax_operate.F90 | 313 - src/xml/sax/m_sax_parser.F90 | 3029 ---- src/xml/sax/m_sax_reader.F90 | 411 - src/xml/sax/m_sax_tokenizer.F90 | 1139 -- src/xml/sax/m_sax_types.F90 | 163 - src/xml/sax/m_sax_xml_source.F90 | 438 - src/xml/utils/FoX_utils.F90 | 22 - src/xml/utils/Makefile | 46 - src/xml/utils/fox_m_utils_mtprng.F90 | 360 - src/xml/utils/fox_m_utils_uri.F90 | 1033 -- src/xml/utils/fox_m_utils_uuid.F90 | 247 - src/xml/wxml/FoX_wxml.F90 | 45 - src/xml/wxml/Makefile | 47 - src/xml/wxml/m_wxml_core.F90 | 1877 --- src/xml/wxml/m_wxml_escape.F90 | 140 - src/xml/wxml/m_wxml_overloads.F90 | 1028 -- 55 files changed, 39583 deletions(-) delete mode 100644 src/xml/LICENSE delete mode 100644 src/xml/Makefile delete mode 100644 src/xml/README delete mode 100644 src/xml/common/FoX_common.F90 delete mode 100644 src/xml/common/Makefile delete mode 100644 src/xml/common/m_common_attrs.F90 delete mode 100644 src/xml/common/m_common_buffer.F90 delete mode 100644 src/xml/common/m_common_charset.F90 delete mode 100644 src/xml/common/m_common_content_model.F90 delete mode 100644 src/xml/common/m_common_element.F90 delete mode 100644 src/xml/common/m_common_elstack.F90 delete mode 100644 src/xml/common/m_common_entities.F90 delete mode 100644 src/xml/common/m_common_entity_expand.F90 delete mode 100644 src/xml/common/m_common_error.F90 delete mode 100644 src/xml/common/m_common_io.F90 delete mode 100644 src/xml/common/m_common_namecheck.F90 delete mode 100644 src/xml/common/m_common_namespaces.F90 delete mode 100644 src/xml/common/m_common_notations.F90 delete mode 100644 src/xml/common/m_common_struct.F90 delete mode 100644 src/xml/dom/FoX_dom.F90 delete mode 100644 src/xml/dom/Makefile delete mode 100644 src/xml/dom/m_dom_dom.F90 delete mode 100644 src/xml/dom/m_dom_error.F90 delete mode 100644 src/xml/dom/m_dom_extras.F90 delete mode 100644 src/xml/dom/m_dom_parse.F90 delete mode 100644 src/xml/dom/m_dom_utils.F90 delete mode 100644 src/xml/fsys/Makefile delete mode 100644 src/xml/fsys/fox_m_fsys_abort_flush.F90 delete mode 100644 src/xml/fsys/fox_m_fsys_array_str.F90 delete mode 100644 src/xml/fsys/fox_m_fsys_count_parse_input.F90 delete mode 100644 src/xml/fsys/fox_m_fsys_format.F90 delete mode 100644 src/xml/fsys/fox_m_fsys_parse_input.F90 delete mode 100644 src/xml/fsys/fox_m_fsys_realtypes.F90 delete mode 100644 src/xml/fsys/fox_m_fsys_string.F90 delete mode 100644 src/xml/fsys/fox_m_fsys_string_list.F90 delete mode 100644 src/xml/fsys/fox_m_fsys_varstr.F90 delete mode 100644 src/xml/fsys/m_ieee.F90 delete mode 100644 src/xml/sax/FoX_sax.F90 delete mode 100644 src/xml/sax/Makefile delete mode 100644 src/xml/sax/m_sax_operate.F90 delete mode 100644 src/xml/sax/m_sax_parser.F90 delete mode 100644 src/xml/sax/m_sax_reader.F90 delete mode 100644 src/xml/sax/m_sax_tokenizer.F90 delete mode 100644 src/xml/sax/m_sax_types.F90 delete mode 100644 src/xml/sax/m_sax_xml_source.F90 delete mode 100644 src/xml/utils/FoX_utils.F90 delete mode 100644 src/xml/utils/Makefile delete mode 100644 src/xml/utils/fox_m_utils_mtprng.F90 delete mode 100644 src/xml/utils/fox_m_utils_uri.F90 delete mode 100644 src/xml/utils/fox_m_utils_uuid.F90 delete mode 100644 src/xml/wxml/FoX_wxml.F90 delete mode 100644 src/xml/wxml/Makefile delete mode 100644 src/xml/wxml/m_wxml_core.F90 delete mode 100644 src/xml/wxml/m_wxml_escape.F90 delete mode 100644 src/xml/wxml/m_wxml_overloads.F90 diff --git a/src/xml/LICENSE b/src/xml/LICENSE deleted file mode 100644 index 53df0326a6..0000000000 --- a/src/xml/LICENSE +++ /dev/null @@ -1,71 +0,0 @@ -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 deleted file mode 100644 index f9151178c6..0000000000 --- a/src/xml/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -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 deleted file mode 100644 index 5707d45244..0000000000 --- a/src/xml/README +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 index eaa7e684f9..0000000000 --- a/src/xml/common/FoX_common.F90 +++ /dev/null @@ -1,55 +0,0 @@ -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 deleted file mode 100644 index a4874b3b59..0000000000 --- a/src/xml/common/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -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 deleted file mode 100644 index 33a2cdb482..0000000000 --- a/src/xml/common/m_common_attrs.F90 +++ /dev/null @@ -1,1081 +0,0 @@ -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 deleted file mode 100644 index 0bf518362c..0000000000 --- a/src/xml/common/m_common_buffer.F90 +++ /dev/null @@ -1,261 +0,0 @@ -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 deleted file mode 100644 index d46a95ec2c..0000000000 --- a/src/xml/common/m_common_charset.F90 +++ /dev/null @@ -1,447 +0,0 @@ -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 deleted file mode 100644 index 1b5df709e6..0000000000 --- a/src/xml/common/m_common_content_model.F90 +++ /dev/null @@ -1,490 +0,0 @@ -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 deleted file mode 100644 index 5eecbbfdc3..0000000000 --- a/src/xml/common/m_common_element.F90 +++ /dev/null @@ -1,1645 +0,0 @@ -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 deleted file mode 100644 index ccfca15dc5..0000000000 --- a/src/xml/common/m_common_elstack.F90 +++ /dev/null @@ -1,236 +0,0 @@ -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 deleted file mode 100644 index 071455b297..0000000000 --- a/src/xml/common/m_common_entities.F90 +++ /dev/null @@ -1,475 +0,0 @@ -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 deleted file mode 100644 index 5657007109..0000000000 --- a/src/xml/common/m_common_entity_expand.F90 +++ /dev/null @@ -1,86 +0,0 @@ -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 deleted file mode 100644 index 0a1f1c1a8d..0000000000 --- a/src/xml/common/m_common_error.F90 +++ /dev/null @@ -1,211 +0,0 @@ -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 deleted file mode 100644 index a15a25dbc6..0000000000 --- a/src/xml/common/m_common_io.F90 +++ /dev/null @@ -1,102 +0,0 @@ -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 deleted file mode 100644 index a796732e72..0000000000 --- a/src/xml/common/m_common_namecheck.F90 +++ /dev/null @@ -1,501 +0,0 @@ -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 deleted file mode 100644 index e3bdff60cf..0000000000 --- a/src/xml/common/m_common_namespaces.F90 +++ /dev/null @@ -1,830 +0,0 @@ -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 deleted file mode 100644 index ee404da352..0000000000 --- a/src/xml/common/m_common_notations.F90 +++ /dev/null @@ -1,120 +0,0 @@ -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 deleted file mode 100644 index ec92b5291c..0000000000 --- a/src/xml/common/m_common_struct.F90 +++ /dev/null @@ -1,121 +0,0 @@ -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 deleted file mode 100644 index 4e2fc1e9cc..0000000000 --- a/src/xml/dom/FoX_dom.F90 +++ /dev/null @@ -1,266 +0,0 @@ -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 :: getChildrenByTagName - 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 deleted file mode 100644 index 1f597ddbc5..0000000000 --- a/src/xml/dom/Makefile +++ /dev/null @@ -1,49 +0,0 @@ -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 deleted file mode 100644 index ec5b788d9b..0000000000 --- a/src/xml/dom/m_dom_dom.F90 +++ /dev/null @@ -1,12484 +0,0 @@ -! 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 :: getChildrenByTagName - 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 getChildrenByTagName(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) .and. .not. associated(getParentNode(this), treeroot)) 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 getChildrenByTagName - - 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 deleted file mode 100644 index c6fdae4187..0000000000 --- a/src/xml/dom/m_dom_error.F90 +++ /dev/null @@ -1,211 +0,0 @@ -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 deleted file mode 100644 index 790561746c..0000000000 --- a/src/xml/dom/m_dom_extras.F90 +++ /dev/null @@ -1,2444 +0,0 @@ -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 deleted file mode 100644 index 72e683732e..0000000000 --- a/src/xml/dom/m_dom_parse.F90 +++ /dev/null @@ -1,577 +0,0 @@ -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 deleted file mode 100644 index 1234c48ad6..0000000000 --- a/src/xml/dom/m_dom_utils.F90 +++ /dev/null @@ -1,437 +0,0 @@ -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 deleted file mode 100644 index 6e80265b0a..0000000000 --- a/src/xml/fsys/Makefile +++ /dev/null @@ -1,48 +0,0 @@ -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 deleted file mode 100644 index 29af292fc3..0000000000 --- a/src/xml/fsys/fox_m_fsys_abort_flush.F90 +++ /dev/null @@ -1,124 +0,0 @@ -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 deleted file mode 100644 index 88d5652568..0000000000 --- a/src/xml/fsys/fox_m_fsys_array_str.F90 +++ /dev/null @@ -1,94 +0,0 @@ -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 deleted file mode 100644 index b158d26fa7..0000000000 --- a/src/xml/fsys/fox_m_fsys_count_parse_input.F90 +++ /dev/null @@ -1,561 +0,0 @@ -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 deleted file mode 100644 index 448f44ebd4..0000000000 --- a/src/xml/fsys/fox_m_fsys_format.F90 +++ /dev/null @@ -1,2250 +0,0 @@ -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 deleted file mode 100644 index 45551c1d68..0000000000 --- a/src/xml/fsys/fox_m_fsys_parse_input.F90 +++ /dev/null @@ -1,2281 +0,0 @@ -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 deleted file mode 100644 index ecf407483c..0000000000 --- a/src/xml/fsys/fox_m_fsys_string_list.F90 +++ /dev/null @@ -1,191 +0,0 @@ -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 deleted file mode 100644 index 52efa5fde9..0000000000 --- a/src/xml/fsys/fox_m_fsys_varstr.F90 +++ /dev/null @@ -1,254 +0,0 @@ -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 deleted file mode 100644 index afec6f0807..0000000000 --- a/src/xml/fsys/m_ieee.F90 +++ /dev/null @@ -1,17 +0,0 @@ -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 deleted file mode 100644 index 17dc2280ed..0000000000 --- a/src/xml/sax/FoX_sax.F90 +++ /dev/null @@ -1,34 +0,0 @@ -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 deleted file mode 100644 index c0a134055e..0000000000 --- a/src/xml/sax/Makefile +++ /dev/null @@ -1,50 +0,0 @@ -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 deleted file mode 100644 index 531618ad28..0000000000 --- a/src/xml/sax/m_sax_operate.F90 +++ /dev/null @@ -1,313 +0,0 @@ -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 deleted file mode 100644 index c2f2283fb8..0000000000 --- a/src/xml/sax/m_sax_parser.F90 +++ /dev/null @@ -1,3029 +0,0 @@ -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 deleted file mode 100644 index 72fa6584ec..0000000000 --- a/src/xml/sax/m_sax_reader.F90 +++ /dev/null @@ -1,411 +0,0 @@ -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 deleted file mode 100644 index 59ea631d3f..0000000000 --- a/src/xml/sax/m_sax_tokenizer.F90 +++ /dev/null @@ -1,1139 +0,0 @@ -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 deleted file mode 100644 index eb123c781f..0000000000 --- a/src/xml/sax/m_sax_types.F90 +++ /dev/null @@ -1,163 +0,0 @@ -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 deleted file mode 100644 index 560f91e59e..0000000000 --- a/src/xml/utils/FoX_utils.F90 +++ /dev/null @@ -1,22 +0,0 @@ -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/utils/Makefile b/src/xml/utils/Makefile deleted file mode 100644 index 449bd4d91f..0000000000 --- a/src/xml/utils/Makefile +++ /dev/null @@ -1,46 +0,0 @@ -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_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 deleted file mode 100644 index 90a766d2b4..0000000000 --- a/src/xml/utils/fox_m_utils_mtprng.F90 +++ /dev/null @@ -1,360 +0,0 @@ -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 deleted file mode 100644 index a3f1d70ff6..0000000000 --- a/src/xml/utils/fox_m_utils_uri.F90 +++ /dev/null @@ -1,1033 +0,0 @@ -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 deleted file mode 100644 index fd9c272d9a..0000000000 --- a/src/xml/utils/fox_m_utils_uuid.F90 +++ /dev/null @@ -1,247 +0,0 @@ -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 deleted file mode 100644 index cf4def0a77..0000000000 --- a/src/xml/wxml/FoX_wxml.F90 +++ /dev/null @@ -1,45 +0,0 @@ -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/xml/wxml/Makefile b/src/xml/wxml/Makefile deleted file mode 100644 index 55dcc3d9cb..0000000000 --- a/src/xml/wxml/Makefile +++ /dev/null @@ -1,47 +0,0 @@ -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_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 deleted file mode 100644 index 7e905c2ab5..0000000000 --- a/src/xml/wxml/m_wxml_core.F90 +++ /dev/null @@ -1,1877 +0,0 @@ -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 deleted file mode 100644 index 99bfcdab00..0000000000 --- a/src/xml/wxml/m_wxml_escape.F90 +++ /dev/null @@ -1,140 +0,0 @@ -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 deleted file mode 100644 index 5f6281dcb5..0000000000 --- a/src/xml/wxml/m_wxml_overloads.F90 +++ /dev/null @@ -1,1028 +0,0 @@ -! 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