! ATTENTION ! THIS FILE IS AUTOGENERATED ! DO NOT EDIT DIRECTLY ! EDIT FILES dom/m_dom_***.m4 ! module m_dom_dom use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc use fox_m_fsys_format, only: operator(//) use fox_m_fsys_string, only: toLower use fox_m_utils_uri, only: URI, parseURI, destroyURI, isAbsoluteURI, & rebaseURI, expressURI use m_common_charset, only: checkChars, XML1_0, XML1_1 use m_common_element, only: element_t, get_element, attribute_t, & attribute_has_default, get_attribute_declaration, get_attlist_size use m_common_namecheck, only: checkQName, prefixOfQName, localPartOfQName, & checkName, checkPublicId, checkNCName use m_common_struct, only: xml_doc_state, init_xml_doc_state, destroy_xml_doc_state use m_dom_error, only: DOMException, throw_exception, inException, getExceptionCode, & NO_MODIFICATION_ALLOWED_ERR, NOT_FOUND_ERR, HIERARCHY_REQUEST_ERR, & WRONG_DOCUMENT_ERR, FoX_INTERNAL_ERROR, FoX_NODE_IS_NULL, FoX_LIST_IS_NULL, & INUSE_ATTRIBUTE_ERR, FoX_MAP_IS_NULL, INVALID_CHARACTER_ERR, NAMESPACE_ERR, & FoX_INVALID_PUBLIC_ID, FoX_INVALID_SYSTEM_ID, FoX_IMPL_IS_NULL, FoX_INVALID_NODE, & FoX_INVALID_CHARACTER, FoX_INVALID_COMMENT, FoX_INVALID_CDATA_SECTION, & FoX_INVALID_PI_DATA, NOT_SUPPORTED_ERR, FoX_INVALID_ENTITY, & INDEX_SIZE_ERR, FoX_NO_SUCH_ENTITY, FoX_HIERARCHY_REQUEST_ERR, & FoX_INVALID_URI implicit none private integer, parameter :: configParamLen = 42 character(len=configParamLen), parameter :: configParams(24) = (/ & ! DOM 3 Core: "canonical-form ", & "cdata-sections ", & "check-character-normalization ", & "comments ", & "datatype-normalization ", & "element-content-whitespace ", & "entities ", & "error-handler ", & ! "infoset ", & is not a real config option "namespaces ", & "namespace-declarations ", & "normalize-characters ", & ! "schema-location ", & we dont implement ! "schema-type ", & we dont implement "split-cdata-sections ", & "validate ", & "validate-if-schema ", & "well-formed ", & ! DOM 3 LS (Parser): "charset-overrides-xml-encoding ", & "disallow-doctype ", & "ignore-unknown-character-denormalizations", & "resource-resolver ", & "supported-media-types-only ", & ! DOM 3 LS (Serializer) "discard-default-content ", & "format-pretty-print ", & "xml-declaration ", & ! Extra (FoX) configuration options "invalid-pretty-print " /) integer, parameter :: paramSettable = 27293398 integer, parameter :: paramDefaults = 10786516 type DOMConfiguration private integer :: parameters = paramDefaults ! FIXME make sure this is 32 bit at least. end type DOMConfiguration interface canSetParameter module procedure canSetParameter_log module procedure canSetParameter_ch end interface canSetParameter public :: setParameter public :: getParameter public :: canSetParameter public :: getParameterNames public :: newDOMConfig public :: copyDOMConfig integer, parameter :: ELEMENT_NODE = 1 integer, parameter :: ATTRIBUTE_NODE = 2 integer, parameter :: TEXT_NODE = 3 integer, parameter :: CDATA_SECTION_NODE = 4 integer, parameter :: ENTITY_REFERENCE_NODE = 5 integer, parameter :: ENTITY_NODE = 6 integer, parameter :: PROCESSING_INSTRUCTION_NODE = 7 integer, parameter :: COMMENT_NODE = 8 integer, parameter :: DOCUMENT_NODE = 9 integer, parameter :: DOCUMENT_TYPE_NODE = 10 integer, parameter :: DOCUMENT_FRAGMENT_NODE = 11 integer, parameter :: NOTATION_NODE = 12 integer, parameter :: XPATH_NAMESPACE_NODE = 13 type DOMImplementation private character(len=7) :: id = "FoX_DOM" logical :: FoX_checks = .true. ! Do extra checks not mandated by DOM end type DOMImplementation type ListNode private type(Node), pointer :: this => null() end type ListNode type NodeList private character, pointer :: nodeName(:) => null() ! What was getByTagName run on? character, pointer :: localName(:) => null() ! What was getByTagNameNS run on? character, pointer :: namespaceURI(:) => null() ! What was getByTagNameNS run on? type(Node), pointer :: element => null() ! which element or document was the getByTagName run from? type(ListNode), pointer :: nodes(:) => null() integer :: length = 0 end type NodeList type NodeListptr private type(NodeList), pointer :: this end type NodeListptr type NamedNodeMap private logical :: readonly = .false. type(Node), pointer :: ownerElement => null() type(ListNode), pointer :: nodes(:) => null() integer :: length = 0 end type NamedNodeMap type documentExtras type(DOMImplementation), pointer :: implementation => null() ! only for doctype type(Node), pointer :: docType => null() type(Node), pointer :: documentElement => null() character, pointer :: inputEncoding(:) => null() character, pointer :: xmlEncoding(:) => null() type(NodeListPtr), pointer :: nodelists(:) => null() ! document ! In order to keep track of all nodes not connected to the document logical :: liveNodeLists ! For the document, are nodelists live? type(NodeList) :: hangingNodes ! For the document, list of nodes not associated with doc type(xml_doc_state), pointer :: xds => null() logical :: strictErrorChecking = .true. logical :: brokenNS = .false. ! FIXME consolidate these logical variables into bitmask type(DOMConfiguration), pointer :: domConfig => null() end type documentExtras type elementOrAttributeExtras ! Needed for all: character, pointer, dimension(:) :: namespaceURI => null() character, pointer, dimension(:) :: prefix => null() character, pointer, dimension(:) :: localName => null() ! Needed for elements: type(NamedNodeMap) :: attributes type(NodeList) :: namespaceNodes ! Needed for attributes: type(Node), pointer :: ownerElement => null() logical :: specified = .true. logical :: isId = .false. logical :: dom1 = .false. end type elementOrAttributeExtras type docTypeExtras character, pointer :: publicId(:) => null() ! doctype, entity, notation character, pointer :: systemId(:) => null() ! doctype, entity, notation character, pointer :: notationName(:) => null() ! entity logical :: illFormed = .false. ! entity type(namedNodeMap) :: entities ! doctype type(namedNodeMap) :: notations ! doctype end type docTypeExtras type Node private logical :: readonly = .false. character, pointer, dimension(:) :: nodeName => null() character, pointer, dimension(:) :: nodeValue => null() integer :: nodeType = 0 type(Node), pointer :: parentNode => null() type(Node), pointer :: firstChild => null() type(Node), pointer :: lastChild => null() type(Node), pointer :: previousSibling => null() type(Node), pointer :: nextSibling => null() type(Node), pointer :: ownerDocument => null() type(NodeList) :: childNodes ! not for text, cdata, PI, comment, notation, docType, XPath logical :: inDocument = .false.! For a node, is this node associated to the doc? logical :: ignorableWhitespace = .false. ! Text nodes only type(documentExtras), pointer :: docExtras => null() type(elementOrAttributeExtras), pointer :: elExtras => null() type(docTypeExtras), pointer :: dtdExtras => null() integer :: textContentLength = 0 end type Node type(DOMImplementation), save, target :: FoX_DOM interface destroy module procedure destroyNode module procedure destroyNodeList module procedure destroyNamedNodeMap module procedure destroyDOMConfig end interface destroy public :: ELEMENT_NODE public :: ATTRIBUTE_NODE public :: TEXT_NODE public :: CDATA_SECTION_NODE public :: ENTITY_REFERENCE_NODE public :: ENTITY_NODE public :: PROCESSING_INSTRUCTION_NODE public :: COMMENT_NODE public :: DOCUMENT_NODE public :: DOCUMENT_TYPE_NODE public :: DOCUMENT_FRAGMENT_NODE public :: NOTATION_NODE public :: DOMImplementation public :: DOMConfiguration public :: Node public :: ListNode public :: NodeList public :: NamedNodeMap public :: destroy public :: destroyAllNodesRecursively public :: getNodeName public :: getNodeValue public :: setNodeValue public :: getNodeType public :: getParentNode public :: getChildNodes public :: getFirstChild public :: getLastChild public :: getNextSibling public :: getPreviousSibling public :: getAttributes public :: getOwnerDocument public :: insertBefore public :: replaceChild public :: removeChild public :: appendChild public :: hasChildNodes public :: cloneNode public :: normalize public :: isSupported public :: getNamespaceURI public :: getPrefix public :: setPrefix public :: getLocalName public :: hasAttributes public :: isEqualNode public :: isSameNode public :: isDefaultNamespace public :: lookupNamespaceURI public :: lookupPrefix public :: getTextContent public :: setTextContent public :: getNodePath public :: setStringValue public :: getStringValue public :: setReadonlyNode public :: getReadOnly public :: getBaseURI public :: item public :: append public :: pop_nl public :: remove_nl public :: destroyNodeList interface append module procedure append_nl end interface interface item module procedure item_nl end interface interface getLength module procedure getLength_nl end interface getLength public :: getNamedItem public :: setNamedItem public :: removeNamedItem ! public :: item ! public :: getLength public :: getNamedItemNS public :: setNamedItemNS public :: removeNamedItemNS ! public :: append public :: setReadOnlyMap public :: destroyNamedNodeMap interface item module procedure item_nnm end interface interface getLength module procedure getLength_nnm end interface public :: hasFeature public :: createDocument public :: createDocumentType public :: destroyDocument public :: createEmptyDocument public :: getFoX_checks public :: setFoX_checks !FIXME lots of these should have a check if(namespaces) checkNCName public :: getDocType public :: getImplementation public :: getDocumentElement public :: setDocumentElement public :: createElement public :: createDocumentFragment public :: createTextNode public :: createComment public :: createCdataSection public :: createProcessingInstruction public :: createAttribute public :: createEntityReference public :: createEmptyEntityReference public :: getElementsByTagName public :: importNode public :: createElementNS public :: createAttributeNS public :: getElementsByTagNameNS public :: getElementById public :: getXmlStandalone public :: setXmlStandalone public :: getXmlVersion public :: setXmlVersion public :: getXmlEncoding public :: getInputEncoding public :: getDocumentURI public :: setDocumentURI public :: getStrictErrorChecking public :: setStrictErrorChecking public :: getDomConfig public :: renameNode public :: adoptNode public :: setDocType public :: setDomConfig public :: setXds public :: createNamespaceNode public :: createEntity public :: createNotation public :: setGCstate public :: getXds public :: getLiveNodeLists public :: setLiveNodeLists !public :: getName public :: getEntities public :: getNotations ! public :: getPublicId ! public :: getSystemId public :: getInternalSubset public :: getTagName public :: getAttribute public :: setAttribute public :: removeAttribute public :: getAttributeNode public :: setAttributeNode public :: removeAttributeNode public :: getAttributeNS public :: setAttributeNS public :: removeAttributeNS public :: getAttributeNodeNS public :: setAttributeNodeNS public :: removeAttributeNodeNS public :: hasAttribute public :: hasAttributeNS public :: setIdAttribute public :: setIdAttributeNS public :: setIdAttributeNode !public :: getName public :: getSpecified public :: setSpecified interface getValue module procedure getValue_DOM end interface public :: getValue public :: setValue public :: getOwnerElement public :: getIsId public :: setIsId interface getIsId module procedure getIsId_DOM end interface interface setIsId module procedure setIsId_DOM end interface public :: getLength ! public :: getData ! public :: setData public :: substringData public :: appendData public :: insertData public :: deleteData public :: replaceData interface getLength module procedure getLength_characterdata end interface public :: getNotationName public :: getIllFormed public :: setIllFormed public :: getTarget public :: splitText public :: getIsElementContentWhitespace public :: setIsElementContentWhitespace ! Assorted functions with identical signatures despite belonging to different types. public :: getData public :: setData public :: getName public :: getPublicId public :: getSystemId public :: normalizeDocument public :: getNamespaceNodes public :: namespaceFixup contains subroutine resetParameter(domConfig, name) type(DOMConfiguration), pointer :: domConfig character(len=*), intent(in) :: name integer :: i, n do i = 1, size(configParams) if (toLower(name)==trim(configParams(i))) then n = i exit endif enddo if (i>size(configParams)) return if (.not.btest(paramSettable, n)) return if (btest(paramDefaults, n)) then domConfig%parameters = ibset(domConfig%parameters, n) else domConfig%parameters = ibclr(domConfig%parameters, n) endif end subroutine resetParameter recursive subroutine setParameter(domConfig, name, value, ex) type(DOMException), intent(out), optional :: ex type(DOMConfiguration), pointer :: domConfig character(len=*), intent(in) :: name logical, intent(in) :: value integer :: i, n if (toLower(name)=="infoset") then if (value) then call setParameter(domConfig, "validate-if-schema", .false.) call setParameter(domConfig, "entities", .false.) ! cant do datatype-normalization call setParameter(domConfig, "cdata-sections", .false.) call setParameter(domConfig, "namespace-declarations", .true.) ! well-formed cannot be changed call setParameter(domConfig, "element-content-whitespace", .true.) call setParameter(domConfig, "comments", .true.) call setParameter(domConfig, "namespaces", .true.) endif return endif do i = 1, size(configParams) if (toLower(name)==trim(configParams(i))) then n = i exit endif enddo if (i > size(configParams)) then if (getFoX_checks().or.NOT_FOUND_ERR<200) then call throw_exception(NOT_FOUND_ERR, "setParameter", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (.not.canSetParameter(domConfig, name, value)) then if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "setParameter", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (value) then domConfig%parameters = ibset(domConfig%parameters, n) else domConfig%parameters = ibclr(domConfig%parameters, n) endif select case (toLower(name)) case ("canonical-form") if (value) then domConfig%parameters = ibclr(domConfig%parameters, 7) ! cant do normalize-characters domConfig%parameters = ibclr(domConfig%parameters, 2) domConfig%parameters = ibset(domConfig%parameters, 9) domConfig%parameters = ibset(domConfig%parameters, 10) ! well-formed cannot be changed domConfig%parameters = ibset(domConfig%parameters, 6) ! FIXME when we work out pretty-print/preserve-whitespace semantics ! call setParameter(domConfig, "format-pretty-print", .false.) domConfig%parameters = ibclr(domConfig%parameters, 21) domConfig%parameters = ibclr(domConfig%parameters, 23) domConfig%parameters = ibclr(domConfig%parameters, 24) else call resetParameter(domConfig, "entities") ! cant do normalize-characters call resetParameter(domConfig, "cdata-sections") call resetParameter(domConfig, "namespaces") call resetParameter(domConfig, "namespace-declarations") ! well-formed cannot be changed call resetParameter(domConfig, "element-content-whitespace") call resetParameter(domConfig, "format-pretty-print") call resetParameter(domConfig, "discard-default-content") call resetParameter(domConfig, "xml-declaration") call resetParameter(domConfig, "invalid-pretty-print") endif case ("cdata-sections") if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) case ("element-content-whitespace") if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) case ("entities") if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) case ("namespaces") if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) case ("namespaces-declarations") if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) case("validate") if (value) domConfig%parameters = ibclr(domConfig%parameters, 14) case ("validate-if-schema") if (value) domConfig%parameters = ibclr(domConfig%parameters, 13) case ("format-pretty-print") if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) case ("discard-default-content") if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) case ("xml-declaration") if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) case ("invalid-pretty-print") if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) end select end subroutine setParameter recursive function getParameter(domConfig, name, ex)result(value) type(DOMException), intent(out), optional :: ex type(DOMConfiguration), pointer :: domConfig character(len=*), intent(in) :: name logical :: value integer :: i, n if (toLower(name)=="infoset") then value = & .not.getParameter(domConfig, "validate-if-schema") & .and..not.getParameter(domConfig, "entities") & .and..not.getParameter(domConfig, "datatype-normalization") & .and..not.getParameter(domConfig, "cdata-sections") & .and.getParameter(domConfig, "namespace-declarations") & .and.getParameter(domConfig, "well-formed") & .and.getParameter(domConfig, "element-content-whitespace") & .and.getParameter(domConfig, "comments") & .and.getParameter(domConfig, "namespaces") return endif do i = 1, size(configParams) if (toLower(name)==trim(configParams(i))) then n = i exit endif enddo if (i > size(configParams)) then if (getFoX_checks().or.NOT_FOUND_ERR<200) then call throw_exception(NOT_FOUND_ERR, "getParameter", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif value = btest(domConfig%parameters, n) end function getParameter function canSetParameter_log(domConfig, name, value, ex)result(p) type(DOMException), intent(out), optional :: ex type(DOMConfiguration), pointer :: domConfig character(len=*), intent(in) :: name logical, intent(in) :: value logical :: p integer :: i, n if (toLower(name)=="infoset") then p = .true. return endif do i = 1, size(configParams) if (toLower(name)==trim(configParams(i))) then n = i exit endif enddo if (i > size(configParams)) then p = .false. return endif p = btest(paramSettable, n) end function canSetParameter_log function canSetParameter_ch(domConfig, name, value, ex)result(p) type(DOMException), intent(out), optional :: ex type(DOMConfiguration), pointer :: domConfig character(len=*), intent(in) :: name character(len=*), intent(in) :: value logical :: p ! DOM 3 allows some config options to be set to strings ! (eg schemaLocation) but we dont support any of these, ! so no parameter can be set to a string. p = .false. end function canSetParameter_ch function getParameterNames(domConfig, ex)result(s) type(DOMException), intent(out), optional :: ex type(DOMConfiguration), pointer :: domConfig character(len=configParamLen) :: s(size(configParams)) s = configParams end function getParameterNames function newDOMConfig() result(dc) type(DOMConfiguration), pointer :: dc allocate(dc) end function newDOMConfig subroutine copyDOMConfig(dc1, dc2) type(DOMConfiguration), pointer :: dc1, dc2 dc1%parameters = dc2%parameters end subroutine copyDOMConfig subroutine destroyDOMConfig(dc) type(DOMConfiguration), pointer :: dc deallocate(dc) end subroutine destroyDOMConfig function createNode(arg, nodeType, nodeName, nodeValue, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg integer, intent(in) :: nodeType character(len=*), intent(in) :: nodeName character(len=*), intent(in) :: nodeValue type(Node), pointer :: np allocate(np) np%ownerDocument => arg np%nodeType = nodeType np%nodeName => vs_str_alloc(nodeName) np%nodeValue => vs_str_alloc(nodeValue) allocate(np%childNodes%nodes(0)) end function createNode recursive subroutine destroyNode(np, ex) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np if (.not.associated(np)) return select case(np%nodeType) case (ELEMENT_NODE, ATTRIBUTE_NODE, XPATH_NAMESPACE_NODE) call destroyElementOrAttribute(np) case (DOCUMENT_TYPE_NODE) call destroyDocumentType(np) case (ENTITY_NODE, NOTATION_NODE) call destroyEntityOrNotation(np) case (DOCUMENT_NODE) call destroyDocument(np) 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.) 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) deallocate(arg%docExtras%xds) deallocate(arg%docExtras%domConfig) deallocate(arg%docExtras) call destroyAllNodesRecursively(arg, except=.true.) end subroutine destroyDocument function getFoX_checks() result(FoX_checks) logical :: FoX_checks FoX_checks = FoX_DOM%FoX_checks end function getFoX_checks subroutine setFoX_checks(FoX_checks) logical, intent(in) :: FoX_checks FoX_DOM%FoX_checks = FoX_checks end subroutine setFoX_checks function getdocType(np, ex)result(c) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np type(Node), pointer :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getdocType", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getdocType", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif c => np%docExtras%docType end function getdocType subroutine setDocType(arg, np, ex) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "setDocType", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setDocType", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif arg%docExtras%docType => np !NB special case in order to set ownerDocument np%ownerDocument => arg end subroutine setDocType function getdocumentElement(np, ex)result(c) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np type(Node), pointer :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getdocumentElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getdocumentElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif c => np%docExtras%documentElement end function getdocumentElement subroutine setXds(arg, xds, ex) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg type(xml_doc_state), pointer :: xds if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "setXds", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setXds", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif !NB special case in order to destroy_xml_doc_state etc call destroy_xml_doc_state(arg%docExtras%xds) deallocate(arg%docExtras%xds) arg%docExtras%xds => xds end subroutine setXds function getImplementation(arg, ex)result(imp) type(DOMException), intent(out), optional :: ex type(Node), pointer, optional :: arg type(DOMImplementation), pointer :: imp ! According to the testsuite, you get to call ! getImplementation with no args. Dont know ! where they get that from ... if (present(arg)) then if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getImplementation", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getImplementation", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif imp => arg%docExtras%implementation else imp => FoX_DOM endif end function getImplementation subroutine setDocumentElement(arg, np, ex) type(DOMException), intent(out), optional :: ex ! Only for use by FoX, not exported through FoX_DOM interface type(Node), pointer :: arg type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "setDocumentElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif !NB special case due to additional error conditions: if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setDocumentElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (np%nodeType/=ELEMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setDocumentElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.associated(np%ownerDocument, arg)) then if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then call throw_exception(WRONG_DOCUMENT_ERR, "setDocumentElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif arg%docExtras%documentElement => np end subroutine setDocumentElement ! Methods function createElement(arg, tagName, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: tagName type(Node), pointer :: np type(xml_doc_state), pointer :: xds type(element_t), pointer :: elem type(attribute_t), pointer :: att logical :: defaults_ integer :: i if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkName(tagName, getXmlVersionEnum(arg))) then if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then call throw_exception(INVALID_CHARACTER_ERR, "createElement", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, ELEMENT_NODE, tagName, "") allocate(np%elExtras) np%elExtras%dom1 = .true. np%elExtras%attributes%ownerElement => np allocate(np%elExtras%namespaceURI(0)) allocate(np%elExtras%prefix(0)) allocate(np%elExtras%localname(0)) allocate(np%elExtras%namespaceNodes%nodes(0)) np%elExtras%attributes%ownerElement => np if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) ! We only add default attributes if we are *not* building the doc xds => getXds(arg) elem => get_element(xds%element_list, tagName) if (associated(elem)) then do i = 1, get_attlist_size(elem) att => get_attribute_declaration(elem, i) if (attribute_has_default(att)) then ! Since this is a non-namespaced function, we create ! a non-namespaced attribute ... call setAttribute(np, str_vs(att%name), str_vs(att%default)) endif enddo endif else np%inDocument = .true. endif end function createElement function createEmptyElement(arg, tagName, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: tagName type(Node), pointer :: np ! NO CHECKS ! np => createNode(arg, ELEMENT_NODE, tagName, "") allocate(np%elExtras) np%elExtras%dom1 = .true. np%elExtras%attributes%ownerElement => np allocate(np%elExtras%namespaceURI(0)) allocate(np%elExtras%prefix(0)) allocate(np%elExtras%localname(0)) allocate(np%elExtras%namespaceNodes%nodes(0)) np%elExtras%attributes%ownerElement => np if (getGCstate(arg)) then call append(arg%docExtras%hangingnodes, np) np%inDocument = .false. else np%inDocument = .true. endif end function createEmptyElement function createDocumentFragment(arg, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createDocumentFragment", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createDocumentFragment", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, DOCUMENT_FRAGMENT_NODE, "#document-fragment", "") if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) else np%inDocument = .true. endif end function createDocumentFragment function createTextNode(arg, data, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: data type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createTextNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createTextNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then call throw_exception(FoX_INVALID_CHARACTER, "createTextNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, TEXT_NODE, "#text", data) np%textContentLength = len(data) if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) else np%inDocument = .true. endif end function createTextNode function createComment(arg, data, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: data type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createComment", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createComment", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then call throw_exception(FoX_INVALID_CHARACTER, "createComment", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (index(data,"--")>0) then if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then call throw_exception(FoX_INVALID_COMMENT, "createComment", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, COMMENT_NODE, "#comment", data) np%textContentLength = len(data) if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) else np%inDocument = .true. endif end function createComment function createCdataSection(arg, data, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: data type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createCdataSection", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createCdataSection", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then call throw_exception(FoX_INVALID_CHARACTER, "createCdataSection", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (index(data,"]]>")>0) then if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then call throw_exception(FoX_INVALID_CDATA_SECTION, "createCdataSection", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, CDATA_SECTION_NODE, "#cdata-section", data) np%textContentLength = len(data) if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) else np%inDocument = .true. endif end function createCdataSection function createProcessingInstruction(arg, target, data, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: target character(len=*), intent(in) :: data type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createProcessingInstruction", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createProcessingInstruction", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkName(target, getXmlVersionEnum(arg))) then if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then call throw_exception(INVALID_CHARACTER_ERR, "createProcessingInstruction", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then call throw_exception(FoX_INVALID_CHARACTER, "createProcessingInstruction", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (index(data,"?>")>0) then if (getFoX_checks().or.FoX_INVALID_PI_DATA<200) then call throw_exception(FoX_INVALID_PI_DATA, "createProcessingInstruction", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, PROCESSING_INSTRUCTION_NODE, target, data) np%textContentLength = len(data) if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) else np%inDocument = .true. endif end function createProcessingInstruction function createAttribute(arg, name, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: name type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createAttribute", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createAttribute", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkName(name, getXmlVersionEnum(arg))) then if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then call throw_exception(INVALID_CHARACTER_ERR, "createAttribute", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, ATTRIBUTE_NODE, name, "") allocate(np%elExtras) np%elExtras%dom1 = .true. allocate(np%elExtras%namespaceURI(0)) allocate(np%elExtras%prefix(0)) allocate(np%elExtras%localname(0)) if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) else np%inDocument = .true. endif end function createAttribute recursive function createEntityReference(arg, name, ex)result(np) type(DOMException), intent(out), optional :: ex ! Needs to be recursive in case of entity-references within each other. type(Node), pointer :: arg character(len=*), intent(in) :: name type(Node), pointer :: np type(Node), pointer :: ent, newNode integer :: i logical :: brokenNS if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createEntityReference", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createEntityReference", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkName(name, getXmlVersionEnum(arg))) then if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then call throw_exception(INVALID_CHARACTER_ERR, "createEntityReference", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getXmlStandalone(arg).and..not.associated(getDocType(arg))) then if (getFoX_checks().or.FoX_NO_SUCH_ENTITY<200) then call throw_exception(FoX_NO_SUCH_ENTITY, "createEntityReference", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, ENTITY_REFERENCE_NODE, name, "") if (getGCstate(arg)) then ! otherwise the parser will fill these nodes in itself if (associated(getDocType(arg))) then ent => getNamedItem(getEntities(getDocType(arg)), name) if (associated(ent)) then if (getIllFormed(ent)) then if (getFoX_checks().or.FoX_INVALID_ENTITY<200) then call throw_exception(FoX_INVALID_ENTITY, "createEntityReference", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif brokenNS = arg%docExtras%brokenNS arg%docExtras%brokenNS = .true. ! We need to not worry about NS errors for a bit do i = 0, getLength(getChildNodes(ent)) - 1 newNode => appendChild(np, cloneNode(item(getChildNodes(ent), i), .true., ex)) ! No namespace calcs here - wait for a namespace normalization call setReadOnlyNode(newNode, .true., .true.) enddo arg%docExtras%brokenNS = brokenNS ! FIXME also for all new default attributes elseif (getXmlStandalone(arg)) then if (getFoX_checks().or.FoX_NO_SUCH_ENTITY<200) then call throw_exception(FoX_NO_SUCH_ENTITY, "createEntityReference", ex) if (present(ex)) then if (inException(ex)) then if (associated(np)) deallocate(np) return endif endif endif endif endif endif call setReadOnlyNode(np, .true., .false.) if (getGCstate(arg)) then np%inDocument = .false. call append_nl(arg%docExtras%hangingNodes, np) ! All child nodes were created outside the document by cloneNode above else np%inDocument = .true. endif end function createEntityReference function createEmptyEntityReference(arg, name, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: name type(Node), pointer :: np if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createEmptyEntityReference", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createEmptyEntityReference", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkName(name, getXmlVersionEnum(arg))) then if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then call throw_exception(INVALID_CHARACTER_ERR, "createEmptyEntityReference", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => createNode(arg, ENTITY_REFERENCE_NODE, name, "") if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) else np%inDocument = .true. endif end function createEmptyEntityReference function getElementsByTagName(doc, tagName, name, ex)result(list) type(DOMException), intent(out), optional :: ex type(Node), pointer :: doc character(len=*), intent(in), optional :: tagName, name type(NodeList), pointer :: list type(NodeListPtr), pointer :: nll(:), temp_nll(:) type(Node), pointer :: arg, this, treeroot logical :: doneChildren, doneAttributes, allElements integer :: i, i_tree if (.not.associated(doc)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagName", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (doc%nodeType==DOCUMENT_NODE) then if (present(name).or..not.present(tagName)) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif elseif (doc%nodeType==ELEMENT_NODE) then if (present(name).or..not.present(tagName)) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif else if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (doc%nodeType==DOCUMENT_NODE) then arg => getDocumentElement(doc) else arg => doc endif allocate(list) allocate(list%nodes(0)) list%element => doc if (present(name)) list%nodeName => vs_str_alloc(name) if (present(tagName)) list%nodeName => vs_str_alloc(tagName) allElements = (str_vs(list%nodeName)=="*") if (doc%nodeType==DOCUMENT_NODE) then nll => doc%docExtras%nodelists elseif (doc%nodeType==ELEMENT_NODE) then nll => doc%ownerDocument%docExtras%nodelists endif allocate(temp_nll(size(nll)+1)) do i = 1, size(nll) temp_nll(i)%this => nll(i)%this enddo temp_nll(i)%this => list deallocate(nll) if (doc%nodeType==DOCUMENT_NODE) then doc%docExtras%nodelists => temp_nll elseif (doc%nodeType==ELEMENT_NODE) then doc%ownerDocument%docExtras%nodelists => temp_nll endif treeroot => arg i_tree = 0 doneChildren = .false. doneAttributes = .false. this => treeroot do if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then if (this%nodeType==ELEMENT_NODE) then if ((allElements .or. str_vs(this%nodeName)==tagName) & .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & call append(list, this) doneAttributes = .true. endif else if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then doneAttributes = .true. else endif endif if (.not.doneChildren) then if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then if (getLength(getAttributes(this))>0) then this => item(getAttributes(this), 0) else doneAttributes = .true. endif elseif (hasChildNodes(this)) then this => getFirstChild(this) doneChildren = .false. doneAttributes = .false. else doneChildren = .true. doneAttributes = .false. endif else ! if doneChildren if (associated(this, treeroot)) exit if (getNodeType(this)==ATTRIBUTE_NODE) then if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) doneChildren = .false. else i_tree= 0 this => getOwnerElement(this) doneAttributes = .true. doneChildren = .false. endif elseif (associated(getNextSibling(this))) then this => getNextSibling(this) doneChildren = .false. doneAttributes = .false. else this => getParentNode(this) endif endif enddo end function getElementsByTagName function importNode(doc , arg, deep , ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: doc type(Node), pointer :: arg logical, intent(in) :: deep type(Node), pointer :: np type(Node), pointer :: this, thatParent, new, treeroot type(xml_doc_state), pointer :: xds type(element_t), pointer :: elem type(attribute_t), pointer :: att logical :: doneAttributes, doneChildren, brokenNS integer :: i_tree if (.not.associated(doc).or..not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "importNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(doc)/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "importNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (getNodeType(arg)==DOCUMENT_NODE .or. & getNodeType(arg)==DOCUMENT_TYPE_NODE) then if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif brokenNS = doc%docExtras%brokenNS doc%docExtras%brokenNS = .true. ! We need to do stupid NS things xds => getXds(doc) thatParent => null() treeroot => arg i_tree = 0 doneChildren = .false. doneAttributes = .false. this => treeroot do if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then new => null() select case (getNodeType(this, ex)) case (ELEMENT_NODE) if (.not.doneAttributes) then ! We dont create an empty node - we insist on having all default ! properties created. if (getParameter(getDomConfig(doc, ex), "namespaces", ex)) then new => createElementNS(doc, getNamespaceURI(this, ex), getTagName(this, ex), ex) else new => createElement(doc, getTagName(this, ex), ex) endif endif case (ATTRIBUTE_NODE) if (associated(this, arg).or.getSpecified(this, ex)) then ! We are importing just this attribute node ! or this was an explicitly specified attribute; either ! way, we import it as is, and it remains specified. if (getParameter(getDomConfig(doc), "namespaces")) then new => createAttributeNS(doc, getNamespaceURI(this, ex), getName(this, ex), ex) else new => createAttribute(doc, getName(this), ex) endif call setSpecified(new, .true.) else ! This is an attribute being imported as part of a hierarchy, ! but its only here by default. Is there a default attribute ! of this name in the new document? elem => get_element(xds%element_list, & getTagName(getOwnerElement(this))) att => get_attribute_declaration(elem, getName(this)) if (attribute_has_default(att)) then ! Create the new default: if (getParameter(getDomConfig(doc, ex), "namespaces", ex)) then ! We create a namespaced attribute. Of course, its ! namespaceURI remains empty for the moment unless we know it ... if (prefixOfQName(getName(this, ex))=="xml") then new => createAttributeNS(doc, & "http://www.w3.org/XML/1998/namespace", & getName(this, ex), ex) elseif (getName(this, ex)=="xmlns" & .or. prefixOfQName(getName(this, ex))=="xmlns") then new => createAttributeNS(doc, & "http://www.w3.org/2000/xmlns/", & getName(this, ex), ex) else ! Wait for namespace fixup ... new => createAttributeNS(doc, "", & getName(this, ex), ex) endif else new => createAttribute(doc, getName(this, ex), ex) endif call setValue(new, str_vs(att%default), ex) call setSpecified(new, .false.) endif ! In any case, we dont want to copy the children of this node. doneChildren=.true. endif case (TEXT_NODE) new => createTextNode(doc, getData(this, ex), ex) case (CDATA_SECTION_NODE) new => createCDataSection(doc, getData(this, ex), ex) case (ENTITY_REFERENCE_NODE) new => createEntityReference(doc, getNodeName(this, ex), ex) ! This will automatically populate the entity reference if doc defines it, so no children needed doneChildren = .true. case (ENTITY_NODE) new => createEntity(doc, getNodeName(this, ex), & getPublicId(this, ex), getSystemId(this, ex), & getNotationName(this, ex), ex) case (PROCESSING_INSTRUCTION_NODE) new => createProcessingInstruction(doc, & getTarget(this, ex), getData(this, ex), ex) case (COMMENT_NODE) new => createComment(doc, getData(this, ex), ex) case (DOCUMENT_NODE) if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif case (DOCUMENT_TYPE_NODE) if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif case (DOCUMENT_FRAGMENT_NODE) new => createDocumentFragment(doc, ex) case (NOTATION_NODE) new => createNotation(doc, getNodeName(this, ex), & getPublicId(this, ex), getSystemId(this, ex), ex) end select if (.not.associated(thatParent)) then thatParent => new elseif (associated(new)) then if (getNodeType(this, ex)==ATTRIBUTE_NODE) then new => setAttributeNode(thatParent, new, ex) else new => appendChild(thatParent, new, ex) endif endif if (.not.deep) then if (getNodeType(arg, ex)==ATTRIBUTE_NODE & .or.getNodeType(arg, ex)==ELEMENT_NODE) then continue else exit endif endif else if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then doneAttributes = .true. else endif endif if (.not.doneChildren) then if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then if (getLength(getAttributes(this))>0) then if (.not.associated(this, treeroot)) thatParent => getLastChild(thatParent) this => item(getAttributes(this), 0) else if (.not.deep) exit doneAttributes = .true. endif elseif (hasChildNodes(this)) then if (getNodeType(this)==ELEMENT_NODE.and..not.deep) exit if (.not.associated(this, treeroot)) then if (getNodeType(this)==ATTRIBUTE_NODE) then thatParent => item(getAttributes(thatParent), i_tree) else thatParent => getLastChild(thatParent) endif endif this => getFirstChild(this) doneChildren = .false. doneAttributes = .false. else doneChildren = .true. doneAttributes = .false. endif else ! if doneChildren if (associated(this, treeroot)) exit if (getNodeType(this)==ATTRIBUTE_NODE) then if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) doneChildren = .false. else i_tree= 0 if (associated(getParentNode(thatParent))) thatParent => getParentNode(thatParent) this => getOwnerElement(this) doneAttributes = .true. doneChildren = .false. endif elseif (associated(getNextSibling(this))) then this => getNextSibling(this) doneChildren = .false. doneAttributes = .false. else this => getParentNode(this) if (.not.associated(this, treeroot)) then if (getNodeType(this)==ATTRIBUTE_NODE) then thatParent => getOwnerElement(thatParent) else thatParent => getParentNode(thatParent) endif endif endif endif enddo np => thatParent doc%docExtras%brokenNS = brokenNS ! call namespaceFixup(np) end function importNode function createElementNS(arg, namespaceURI, qualifiedName, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: namespaceURI, qualifiedName type(Node), pointer :: np type(xml_doc_state), pointer :: xds type(element_t), pointer :: elem type(attribute_t), pointer :: att integer :: i logical :: brokenNS type(URI), pointer :: URIref if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createElementNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createElementNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then call throw_exception(INVALID_CHARACTER_ERR, "createElementNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then if (getFoX_checks().or.NAMESPACE_ERR<200) then call throw_exception(NAMESPACE_ERR, "createElementNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (prefixOfQName(qualifiedName)/="" & .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then if (getFoX_checks().or.NAMESPACE_ERR<200) then call throw_exception(NAMESPACE_ERR, "createElementNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & prefixOfQName(qualifiedName)=="xml") then if (getFoX_checks().or.NAMESPACE_ERR<200) then call throw_exception(NAMESPACE_ERR, "createElementNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then if (getFoX_checks().or.NAMESPACE_ERR<200) then call throw_exception(NAMESPACE_ERR, "createElementNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif URIref => parseURI(namespaceURI) if (.not.associated(URIref)) then if (getFoX_checks().or.FoX_INVALID_URI<200) then call throw_exception(FoX_INVALID_URI, "createElementNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif call destroyURI(URIref) np => createNode(arg, ELEMENT_NODE, qualifiedName, "") allocate(np%elExtras) np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) np%elExtras%prefix => vs_str_alloc(prefixOfQName(qualifiedname)) np%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) allocate(np%elExtras%namespaceNodes%nodes(0)) np%elExtras%attributes%ownerElement => np if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) ! We only add default attributes if we are *not* building the doc xds => getXds(arg) elem => get_element(xds%element_list, qualifiedName) if (associated(elem)) then do i = 1, get_attlist_size(elem) att => get_attribute_declaration(elem, i) if (attribute_has_default(att)) then ! Since this is a namespaced function, we create a namespaced ! attribute. Of course, its namespaceURI remains empty ! for the moment unless we know it ... if (prefixOfQName(str_vs(att%name))=="xml") then call setAttributeNS(np, & "http://www.w3.org/XML/1998/namespace", & str_vs(att%name), str_vs(att%default), ex) elseif (str_vs(att%name)=="xmlns" & .or. prefixOfQName(str_vs(att%name))=="xmlns") then call setAttributeNS(np, & "http://www.w3.org/2000/xmlns/", & str_vs(att%name), str_vs(att%default), ex) else ! Wait for namespace fixup ... brokenNS = arg%docExtras%brokenNS arg%docExtras%brokenNS = .true. call setAttributeNS(np, "", str_vs(att%name), & str_vs(att%default), ex) arg%docExtras%brokenNS = brokenNS endif endif enddo endif else np%inDocument = .true. endif end function createElementNS function createEmptyElementNS(arg, namespaceURI, qualifiedName, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: namespaceURI, qualifiedName type(Node), pointer :: np ! NO CHECKS ! np => createNode(arg, ELEMENT_NODE, qualifiedName, "") allocate(np%elExtras) np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) np%elExtras%prefix => vs_str_alloc(prefixOfQName(qualifiedname)) np%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) allocate(np%elExtras%namespaceNodes%nodes(0)) np%elExtras%attributes%ownerElement => np if (getGCstate(arg)) then call append(arg%docExtras%hangingnodes, np) np%inDocument = .false. else np%inDocument = .true. endif end function createEmptyElementNS function createAttributeNS(arg, namespaceURI, qualifiedname, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: namespaceURI, qualifiedName type(Node), pointer :: np type(URI), pointer :: URIref if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "createAttributeNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "createAttributeNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then call throw_exception(INVALID_CHARACTER_ERR, "createAttributeNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then if (getFoX_checks().or.NAMESPACE_ERR<200) then call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (prefixOfQName(qualifiedName)/="" & .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then if (getFoX_checks().or.NAMESPACE_ERR<200) then call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & prefixOfQName(qualifiedName)=="xml") then if (getFoX_checks().or.NAMESPACE_ERR<200) then call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (namespaceURI=="http://www.w3.org/2000/xmlns/" .neqv. & (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns")) then if (getFoX_checks().or.NAMESPACE_ERR<200) then call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif URIref => parseURI(namespaceURI) if (.not.associated(URIref)) then if (getFoX_checks().or.FoX_INVALID_URI<200) then call throw_exception(FoX_INVALID_URI, "createAttributeNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif call destroyURI(URIref) np => createNode(arg, ATTRIBUTE_NODE, qualifiedName, "") allocate(np%elExtras) np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) np%elExtras%localname => vs_str_alloc(localPartofQName(qualifiedname)) np%elExtras%prefix => vs_str_alloc(PrefixofQName(qualifiedname)) if (getGCstate(arg)) then np%inDocument = .false. call append(arg%docExtras%hangingnodes, np) else np%inDocument = .true. endif end function createAttributeNS function getElementsByTagNameNS(doc, namespaceURI, localName, ex)result(list) type(DOMException), intent(out), optional :: ex type(Node), pointer :: doc character(len=*), intent(in) :: namespaceURI, localName type(NodeList), pointer :: list type(NodeListPtr), pointer :: nll(:), temp_nll(:) type(Node), pointer :: this, arg, treeroot logical :: doneChildren, doneAttributes, allLocalNames, allNameSpaces integer :: i, i_tree if (.not.associated(doc)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagNameNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (doc%nodeType/=DOCUMENT_NODE.and.doc%nodeType/=ELEMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getElementsByTagNameNS", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif allNamespaces = (namespaceURI=="*") allLocalNames = (localName=="*") if (doc%nodeType==DOCUMENT_NODE) then arg => getDocumentElement(doc) else arg => doc endif allocate(list) allocate(list%nodes(0)) list%element => doc list%localName => vs_str_alloc(localName) list%namespaceURI => vs_str_alloc(namespaceURI) if (doc%nodeType==DOCUMENT_NODE) then nll => doc%docExtras%nodelists elseif (doc%nodeType==ELEMENT_NODE) then nll => doc%ownerDocument%docExtras%nodelists endif allocate(temp_nll(size(nll)+1)) do i = 1, size(nll) temp_nll(i)%this => nll(i)%this enddo temp_nll(i)%this => list deallocate(nll) if (doc%nodeType==DOCUMENT_NODE) then doc%docExtras%nodelists => temp_nll elseif (doc%nodeType==ELEMENT_NODE) then doc%ownerDocument%docExtras%nodelists => temp_nll endif treeroot => arg i_tree = 0 doneChildren = .false. doneAttributes = .false. this => treeroot do if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then if (getNodeType(this)==ELEMENT_NODE) then if (getNamespaceURI(this)/="") then if ((allNameSpaces .or. getNameSpaceURI(this)==namespaceURI) & .and. (allLocalNames .or. getLocalName(this)==localName) & .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & call append(list, this) else if ((allNameSpaces .or. namespaceURI=="") & .and. (allLocalNames .or. getNodeName(this)==localName) & .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & call append(list, this) endif doneAttributes = .true. ! Never search attributes endif else if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then doneAttributes = .true. else endif endif if (.not.doneChildren) then if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then if (getLength(getAttributes(this))>0) then this => item(getAttributes(this), 0) else doneAttributes = .true. endif elseif (hasChildNodes(this)) then this => getFirstChild(this) doneChildren = .false. doneAttributes = .false. else doneChildren = .true. doneAttributes = .false. endif else ! if doneChildren if (associated(this, treeroot)) exit if (getNodeType(this)==ATTRIBUTE_NODE) then if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) doneChildren = .false. else i_tree= 0 this => getOwnerElement(this) doneAttributes = .true. doneChildren = .false. endif elseif (associated(getNextSibling(this))) then this => getNextSibling(this) doneChildren = .false. doneAttributes = .false. else this => getParentNode(this) endif endif enddo end function getElementsByTagNameNS function getElementById(arg, elementId, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*), intent(in) :: elementId type(Node), pointer :: np type(Node), pointer :: this, treeroot integer :: i_tree logical :: doneChildren, doneAttributes if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getElementById", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getElementById", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np => null() treeroot => getDocumentElement(arg) i_tree = 0 doneChildren = .false. doneAttributes = .false. this => treeroot do if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then if (this%nodeType==ATTRIBUTE_NODE) then if (getIsId(this).and.getValue(this)==elementId) then np => getOwnerElement(this) return endif endif else if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then doneAttributes = .true. else endif endif if (.not.doneChildren) then if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then if (getLength(getAttributes(this))>0) then this => item(getAttributes(this), 0) else doneAttributes = .true. endif elseif (hasChildNodes(this)) then this => getFirstChild(this) doneChildren = .false. doneAttributes = .false. else doneChildren = .true. doneAttributes = .false. endif else ! if doneChildren if (associated(this, treeroot)) exit if (getNodeType(this)==ATTRIBUTE_NODE) then if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) doneChildren = .false. else i_tree= 0 this => getOwnerElement(this) doneAttributes = .true. doneChildren = .false. endif elseif (associated(getNextSibling(this))) then this => getNextSibling(this) doneChildren = .false. doneAttributes = .false. else this => getParentNode(this) endif endif enddo end function getElementById function getxmlStandalone(np, ex)result(c) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np logical :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getxmlStandalone", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getxmlStandalone", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif c = np%docExtras%xds%standalone end function getxmlStandalone subroutine setxmlStandalone(np, c, ex) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np logical :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "setxmlStandalone", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setxmlStandalone", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np%docExtras%xds%standalone = c end subroutine setxmlStandalone ! FIXME additional check on setting - do we have any undefined entrefs present? function getXmlVersion(arg, ex)result(s) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=3) :: s if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getXmlVersion", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE & .and.arg%nodeType/=ENTITY_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getXmlVersion", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getXmlVersionEnum(arg)==XML1_0) then s = "1.0" elseif (getXmlVersionEnum(arg)==XML1_1) then s = "1.1" else s = "XXX" endif end function getXmlVersion subroutine setXmlVersion(arg, s, ex) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg character(len=*) :: s if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "setXmlVersion", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setXmlVersion", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (s=="1.0") then arg%docExtras%xds%xml_version = XML1_0 elseif (s=="1.1") then arg%docExtras%xds%xml_version = XML1_1 else if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "setXmlVersion", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif end subroutine setXmlVersion pure function getXmlEncoding_len(arg, p) result(n) type(Node), pointer :: arg logical, intent(in) :: p integer :: n n = 0 if (.not.p) return if (arg%nodeType==DOCUMENT_NODE) & n = size(arg%docExtras%xds%encoding) end function getXmlEncoding_len function getXmlEncoding(arg, ex)result(s) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg #ifdef RESTRICTED_ASSOCIATED_BUG character(len=getXmlEncoding_len(arg, .true.)) :: s #else character(len=getXmlEncoding_len(arg, associated(arg))) :: s #endif if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getXmlEncoding", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType==DOCUMENT_NODE) then s = str_vs(arg%docExtras%xds%encoding) elseif (arg%nodeType==ENTITY_NODE) then s = "" !FIXME revisit when we have working external entities else if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getXmlEncoding", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif end function getXmlEncoding pure function getInputEncoding_len(arg, p) result(n) type(Node), pointer :: arg logical, intent(in) :: p integer :: n n = 0 if (.not.p) return if (arg%nodeType==DOCUMENT_NODE) & n = size(arg%docExtras%xds%inputEncoding) end function getInputEncoding_len function getInputEncoding(arg, ex)result(s) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg #ifdef RESTRICTED_ASSOCIATED_BUG character(len=getInputEncoding_len(arg, .true.)) :: s #else character(len=getInputEncoding_len(arg, associated(arg))) :: s #endif if (.not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getInputEncoding", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (arg%nodeType==DOCUMENT_NODE) then s = str_vs(arg%docExtras%xds%inputEncoding) elseif (arg%nodeType==ENTITY_NODE) then s = "" !FIXME revisit when we have working external entities else if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getInputEncoding", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif end function getInputEncoding pure function getdocumentURI_len(np, p) result(n) type(Node), intent(in) :: np logical, intent(in) :: p integer :: n if (p .and. ( & np%nodeType==DOCUMENT_NODE .or. & .false.)) then n = size(np%docExtras%xds%documentURI) else n = 0 endif end function getdocumentURI_len function getdocumentURI(np, ex)result(c) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np #ifdef RESTRICTED_ASSOCIATED_BUG character(len=getdocumentURI_len(np, .true.)) :: c #else character(len=getdocumentURI_len(np, associated(np))) :: c #endif if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getdocumentURI", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getdocumentURI", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif c = str_vs(np%docExtras%xds%documentURI) end function getdocumentURI subroutine setdocumentURI(np, c, ex) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np character(len=*) :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "setdocumentURI", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setdocumentURI", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (associated(np%docExtras%xds%documentURI)) deallocate(np%docExtras%xds%documentURI) np%docExtras%xds%documentURI => vs_str_alloc(c) end subroutine setdocumentURI function getstrictErrorChecking(np, ex)result(c) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np logical :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getstrictErrorChecking", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getstrictErrorChecking", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif c = np%docExtras%strictErrorChecking end function getstrictErrorChecking subroutine setstrictErrorChecking(np, c, ex) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np logical :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "setstrictErrorChecking", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setstrictErrorChecking", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np%docExtras%strictErrorChecking = c end subroutine setstrictErrorChecking function adoptNode(doc , arg , ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: doc type(Node), pointer :: arg type(Node), pointer :: np type(Node), pointer :: this, thatParent, new, treeroot, parent, dead type(xml_doc_state), pointer :: xds type(element_t), pointer :: elem type(attribute_t), pointer :: att logical :: doneAttributes, doneChildren, brokenNS integer :: i_tree if (.not.associated(doc).or..not.associated(arg)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "adoptNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(doc)/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "adoptNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (getNodeType(arg)==DOCUMENT_NODE .or. & getNodeType(arg)==DOCUMENT_TYPE_NODE .or. & getNodeType(arg)==NOTATION_NODE .or. & getNodeType(arg)==ENTITY_NODE) then if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (getReadonly(arg)) then if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "adoptNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif brokenNS = doc%docExtras%brokenNS doc%docExtras%brokenNS = .true. ! We need to do stupid NS things xds => getXds(doc) if (associated(getParentNode(arg))) then np => removeChild(getParentNode(arg), arg) else np => arg endif if (associated(arg, getOwnerDocument(arg))) return thatParent => null() treeroot => np i_tree = 0 doneChildren = .false. doneAttributes = .false. this => treeroot do if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then select case (getNodeType(this)) case (ELEMENT_NODE) if (.not.doneAttributes) call setOwnerDocument(this, doc) case (ATTRIBUTE_NODE) if (associated(this, arg).or.getSpecified(this)) then ! We are importing just this attribute node ! or this was an explicitly specified attribute; either ! way, we import it as is, and it becomes/remains specified. call setOwnerDocument(this, doc) call setSpecified(this, .true.) else ! This is an attribute being imported as part of a hierarchy, ! but its only here by default. Is there a default attribute ! of this name in the new document? elem => get_element(xds%element_list, & getTagName(getOwnerElement(this))) att => get_attribute_declaration(elem, getName(this)) if (attribute_has_default(att)) then ! Create the new default: if (getParameter(getDomConfig(doc), "namespaces")) then ! We create a namespaced attribute. Of course, its ! namespaceURI remains empty for the moment unless we know it ... if (prefixOfQName(getName(this))=="xml") then new => createAttributeNS(np, & "http://www.w3.org/XML/1998/namespace", & getName(this)) elseif (getName(this)=="xmlns" & .or. prefixOfQName(getName(this))=="xmlns") then new => createAttributeNS(np, & "http://www.w3.org/2000/xmlns/", & getName(this)) else ! Wait for namespace fixup ... new => createAttributeNS(np, "", & getName(this)) endif else new => createAttribute(doc, getName(this)) endif call setValue(new, str_vs(att%default)) call setSpecified(new, .false.) ! In any case, we dont want to copy the children of this node. doneChildren = .true. dead => setAttributeNode(getOwnerElement(this), new) this => new call destroyAllNodesRecursively(dead) endif ! Otherwise no attribute here, so go back to previous node dead => this if (i_tree==0) then this => getOwnerElement(this) else i_tree = i_tree - 1 this => item(getAttributes(getOwnerElement(this)), i_tree) doneChildren = .true. endif call removeAttribute(getOwnerElement(dead), getNodeName(dead)) endif case (ENTITY_REFERENCE_NODE) new => createEntityReference(doc, getNodeName(this)) ! This will automatically populate the entity reference if doc defines it, so no children needed parent => getParentNode(this) if (associated(parent)) then dead => replaceChild(parent, new, this) this => new call destroyAllNodesRecursively(dead) endif doneChildren = .true. case (ENTITY_NODE) if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif case (DOCUMENT_NODE) if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif case (DOCUMENT_TYPE_NODE) if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif case (NOTATION_NODE) if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif case default call setOwnerDocument(this, doc) end select else if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then doneAttributes = .true. else endif endif if (.not.doneChildren) then if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then if (getLength(getAttributes(this))>0) then this => item(getAttributes(this), 0) else doneAttributes = .true. endif elseif (hasChildNodes(this)) then this => getFirstChild(this) doneChildren = .false. doneAttributes = .false. else doneChildren = .true. doneAttributes = .false. endif else ! if doneChildren if (associated(this, treeroot)) exit if (getNodeType(this)==ATTRIBUTE_NODE) then if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) doneChildren = .false. else i_tree= 0 this => getOwnerElement(this) doneAttributes = .true. doneChildren = .false. endif elseif (associated(getNextSibling(this))) then this => getNextSibling(this) doneChildren = .false. doneAttributes = .false. else this => getParentNode(this) endif endif enddo doc%docExtras%brokenNS = brokenNS ! call namespaceFixup(np) end function adoptNode function getdomConfig(np, ex)result(c) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np type(DOMConfiguration), pointer :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "getdomConfig", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "getdomConfig", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif c => np%docExtras%domConfig end function getdomConfig subroutine setdomConfig(np, c, ex) type(DOMException), intent(out), optional :: ex type(Node), pointer :: np type(DOMConfiguration), pointer :: c if (.not.associated(np)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "setdomConfig", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(np)/=DOCUMENT_NODE .and. & .true.) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "setdomConfig", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif np%docExtras%domConfig => c end subroutine setdomConfig function renameNode(arg, n, namespaceURI, qualifiedName, ex)result(np) type(DOMException), intent(out), optional :: ex type(Node), pointer :: arg type(Node), pointer :: n character(len=*), intent(in) :: namespaceURI character(len=*), intent(in) :: qualifiedName type(Node), pointer :: np type(Node), pointer :: attNode integer :: i logical :: brokenNS type(element_t), pointer :: elem type(attribute_t), pointer :: att type(xml_doc_state), pointer :: xds type(URI), pointer :: URIref if (.not.associated(arg).or..not.associated(n)) then if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then call throw_exception(FoX_NODE_IS_NULL, "renameNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif endif if (getNodeType(arg)/=DOCUMENT_NODE) then if (getFoX_checks().or.FoX_INVALID_NODE<200) then call throw_exception(FoX_INVALID_NODE, "renameNode", ex) if (present(ex)) then if (inException(ex)) then return endif endif endif elseif (.not.associated(arg, getOwnerDocument(n))) 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