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