1! ATTENTION 2! THIS FILE IS AUTOGENERATED 3! DO NOT EDIT DIRECTLY 4! EDIT FILES dom/m_dom_***.m4 5! 6module m_dom_dom 7 8 use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc 9 use fox_m_fsys_format, only: operator(//) 10 use fox_m_fsys_string, only: toLower 11 use fox_m_utils_uri, only: URI, parseURI, destroyURI, isAbsoluteURI, & 12 rebaseURI, expressURI 13 use m_common_charset, only: checkChars, XML1_0, XML1_1 14 use m_common_element, only: element_t, get_element, attribute_t, & 15 attribute_has_default, get_attribute_declaration, get_attlist_size 16 use m_common_namecheck, only: checkQName, prefixOfQName, localPartOfQName, & 17 checkName, checkPublicId, checkNCName 18 use m_common_struct, only: xml_doc_state, init_xml_doc_state, destroy_xml_doc_state 19 20 use m_dom_error, only: DOMException, throw_exception, inException, getExceptionCode, & 21 NO_MODIFICATION_ALLOWED_ERR, NOT_FOUND_ERR, HIERARCHY_REQUEST_ERR, & 22 WRONG_DOCUMENT_ERR, FoX_INTERNAL_ERROR, FoX_NODE_IS_NULL, FoX_LIST_IS_NULL, & 23 INUSE_ATTRIBUTE_ERR, FoX_MAP_IS_NULL, INVALID_CHARACTER_ERR, NAMESPACE_ERR, & 24 FoX_INVALID_PUBLIC_ID, FoX_INVALID_SYSTEM_ID, FoX_IMPL_IS_NULL, FoX_INVALID_NODE, & 25 FoX_INVALID_CHARACTER, FoX_INVALID_COMMENT, FoX_INVALID_CDATA_SECTION, & 26 FoX_INVALID_PI_DATA, NOT_SUPPORTED_ERR, FoX_INVALID_ENTITY, & 27 INDEX_SIZE_ERR, FoX_NO_SUCH_ENTITY, FoX_HIERARCHY_REQUEST_ERR, & 28 FoX_INVALID_URI 29 30 implicit none 31 private 32 33 34 integer, parameter :: configParamLen = 42 35 36 character(len=configParamLen), parameter :: configParams(24) = (/ & 37 ! DOM 3 Core: 38 "canonical-form ", & 39 "cdata-sections ", & 40 "check-character-normalization ", & 41 "comments ", & 42 "datatype-normalization ", & 43 "element-content-whitespace ", & 44 "entities ", & 45 "error-handler ", & 46! "infoset ", & is not a real config option 47 "namespaces ", & 48 "namespace-declarations ", & 49 "normalize-characters ", & 50! "schema-location ", & we dont implement 51! "schema-type ", & we dont implement 52 "split-cdata-sections ", & 53 "validate ", & 54 "validate-if-schema ", & 55 "well-formed ", & 56 ! DOM 3 LS (Parser): 57 "charset-overrides-xml-encoding ", & 58 "disallow-doctype ", & 59 "ignore-unknown-character-denormalizations", & 60 "resource-resolver ", & 61 "supported-media-types-only ", & 62 ! DOM 3 LS (Serializer) 63 "discard-default-content ", & 64 "format-pretty-print ", & 65 "xml-declaration ", & 66 ! Extra (FoX) configuration options 67 "invalid-pretty-print " /) 68 69 integer, parameter :: paramSettable = 27293398 70 integer, parameter :: paramDefaults = 10786516 71 72 type DOMConfiguration 73 private 74 integer :: parameters = paramDefaults 75 ! FIXME make sure this is 32 bit at least. 76 end type DOMConfiguration 77 78 interface canSetParameter 79 module procedure canSetParameter_log 80 module procedure canSetParameter_ch 81 end interface canSetParameter 82 83 public :: setParameter 84 public :: getParameter 85 public :: canSetParameter 86 public :: getParameterNames 87 88 public :: newDOMConfig 89 public :: copyDOMConfig 90 91 92 integer, parameter :: ELEMENT_NODE = 1 93 integer, parameter :: ATTRIBUTE_NODE = 2 94 integer, parameter :: TEXT_NODE = 3 95 integer, parameter :: CDATA_SECTION_NODE = 4 96 integer, parameter :: ENTITY_REFERENCE_NODE = 5 97 integer, parameter :: ENTITY_NODE = 6 98 integer, parameter :: PROCESSING_INSTRUCTION_NODE = 7 99 integer, parameter :: COMMENT_NODE = 8 100 integer, parameter :: DOCUMENT_NODE = 9 101 integer, parameter :: DOCUMENT_TYPE_NODE = 10 102 integer, parameter :: DOCUMENT_FRAGMENT_NODE = 11 103 integer, parameter :: NOTATION_NODE = 12 104 integer, parameter :: XPATH_NAMESPACE_NODE = 13 105 106 type DOMImplementation 107 private 108 character(len=7) :: id = "FoX_DOM" 109 logical :: FoX_checks = .true. ! Do extra checks not mandated by DOM 110 end type DOMImplementation 111 112 type ListNode 113 private 114 type(Node), pointer :: this => null() 115 end type ListNode 116 117 type NodeList 118 private 119 character, pointer :: nodeName(:) => null() ! What was getByTagName run on? 120 character, pointer :: localName(:) => null() ! What was getByTagNameNS run on? 121 character, pointer :: namespaceURI(:) => null() ! What was getByTagNameNS run on? 122 type(Node), pointer :: element => null() ! which element or document was the getByTagName run from? 123 type(ListNode), pointer :: nodes(:) => null() 124 integer :: length = 0 125 end type NodeList 126 127 type NodeListptr 128 private 129 type(NodeList), pointer :: this 130 end type NodeListptr 131 132 type NamedNodeMap 133 private 134 logical :: readonly = .false. 135 type(Node), pointer :: ownerElement => null() 136 type(ListNode), pointer :: nodes(:) => null() 137 integer :: length = 0 138 end type NamedNodeMap 139 140 type documentExtras 141 type(DOMImplementation), pointer :: implementation => null() ! only for doctype 142 type(Node), pointer :: docType => null() 143 type(Node), pointer :: documentElement => null() 144 character, pointer :: inputEncoding(:) => null() 145 character, pointer :: xmlEncoding(:) => null() 146 type(NodeListPtr), pointer :: nodelists(:) => null() ! document 147 ! In order to keep track of all nodes not connected to the document 148 logical :: liveNodeLists ! For the document, are nodelists live? 149 type(NodeList) :: hangingNodes ! For the document, list of nodes not associated with doc 150 type(xml_doc_state), pointer :: xds => null() 151 logical :: strictErrorChecking = .true. 152 logical :: brokenNS = .false. ! FIXME consolidate these logical variables into bitmask 153 type(DOMConfiguration), pointer :: domConfig => null() 154 end type documentExtras 155 156 type elementOrAttributeExtras 157 ! Needed for all: 158 character, pointer, dimension(:) :: namespaceURI => null() 159 character, pointer, dimension(:) :: prefix => null() 160 character, pointer, dimension(:) :: localName => null() 161 ! Needed for elements: 162 type(NamedNodeMap) :: attributes 163 type(NodeList) :: namespaceNodes 164 ! Needed for attributes: 165 type(Node), pointer :: ownerElement => null() 166 logical :: specified = .true. 167 logical :: isId = .false. 168 logical :: dom1 = .false. 169 end type elementOrAttributeExtras 170 171 type docTypeExtras 172 character, pointer :: publicId(:) => null() ! doctype, entity, notation 173 character, pointer :: systemId(:) => null() ! doctype, entity, notation 174 character, pointer :: notationName(:) => null() ! entity 175 logical :: illFormed = .false. ! entity 176 type(namedNodeMap) :: entities ! doctype 177 type(namedNodeMap) :: notations ! doctype 178 end type docTypeExtras 179 180 type Node 181 private 182 logical :: readonly = .false. 183 character, pointer, dimension(:) :: nodeName => null() 184 character, pointer, dimension(:) :: nodeValue => null() 185 integer :: nodeType = 0 186 type(Node), pointer :: parentNode => null() 187 type(Node), pointer :: firstChild => null() 188 type(Node), pointer :: lastChild => null() 189 type(Node), pointer :: previousSibling => null() 190 type(Node), pointer :: nextSibling => null() 191 type(Node), pointer :: ownerDocument => null() 192 type(NodeList) :: childNodes ! not for text, cdata, PI, comment, notation, docType, XPath 193 logical :: inDocument = .false.! For a node, is this node associated to the doc? 194 logical :: ignorableWhitespace = .false. ! Text nodes only 195 type(documentExtras), pointer :: docExtras => null() 196 type(elementOrAttributeExtras), pointer :: elExtras => null() 197 type(docTypeExtras), pointer :: dtdExtras => null() 198 integer :: textContentLength = 0 199 end type Node 200 201 type(DOMImplementation), save, target :: FoX_DOM 202 203 interface destroy 204 module procedure destroyNode 205 module procedure destroyNodeList 206 module procedure destroyNamedNodeMap 207 module procedure destroyDOMConfig 208 end interface destroy 209 210 public :: ELEMENT_NODE 211 public :: ATTRIBUTE_NODE 212 public :: TEXT_NODE 213 public :: CDATA_SECTION_NODE 214 public :: ENTITY_REFERENCE_NODE 215 public :: ENTITY_NODE 216 public :: PROCESSING_INSTRUCTION_NODE 217 public :: COMMENT_NODE 218 public :: DOCUMENT_NODE 219 public :: DOCUMENT_TYPE_NODE 220 public :: DOCUMENT_FRAGMENT_NODE 221 public :: NOTATION_NODE 222 223 public :: DOMImplementation 224 public :: DOMConfiguration 225 public :: Node 226 227 public :: ListNode 228 public :: NodeList 229 public :: NamedNodeMap 230 231 public :: destroy 232 public :: destroyAllNodesRecursively 233 234 235 236 public :: getNodeName 237 public :: getNodeValue 238 public :: setNodeValue 239 public :: getNodeType 240 public :: getParentNode 241 public :: getChildNodes 242 public :: getFirstChild 243 public :: getLastChild 244 public :: getNextSibling 245 public :: getPreviousSibling 246 public :: getAttributes 247 public :: getOwnerDocument 248 public :: insertBefore 249 public :: replaceChild 250 public :: removeChild 251 public :: appendChild 252 public :: hasChildNodes 253 public :: cloneNode 254 public :: normalize 255 public :: isSupported 256 public :: getNamespaceURI 257 public :: getPrefix 258 public :: setPrefix 259 public :: getLocalName 260 public :: hasAttributes 261 public :: isEqualNode 262 public :: isSameNode 263 public :: isDefaultNamespace 264 public :: lookupNamespaceURI 265 public :: lookupPrefix 266 public :: getTextContent 267 public :: setTextContent 268 269 public :: getNodePath 270 271 public :: setStringValue 272 public :: getStringValue 273 public :: setReadonlyNode 274 public :: getReadOnly 275 276 public :: getBaseURI 277 278 279 280 public :: item 281 public :: append 282 public :: pop_nl 283 public :: remove_nl 284 public :: destroyNodeList 285 286 interface append 287 module procedure append_nl 288 end interface 289 290 interface item 291 module procedure item_nl 292 end interface 293 294 interface getLength 295 module procedure getLength_nl 296 end interface getLength 297 298 299 public :: getNamedItem 300 public :: setNamedItem 301 public :: removeNamedItem 302! public :: item 303! public :: getLength 304 public :: getNamedItemNS 305 public :: setNamedItemNS 306 public :: removeNamedItemNS 307 308! public :: append 309 public :: setReadOnlyMap 310 public :: destroyNamedNodeMap 311 312 313 interface item 314 module procedure item_nnm 315 end interface 316 317 interface getLength 318 module procedure getLength_nnm 319 end interface 320 321 322 323 public :: hasFeature 324 public :: createDocument 325 public :: createDocumentType 326 327 public :: destroyDocument 328 public :: createEmptyDocument 329 330 public :: getFoX_checks 331 public :: setFoX_checks 332 333 334 335!FIXME lots of these should have a check if(namespaces) checkNCName 336 337 public :: getDocType 338 public :: getImplementation 339 public :: getDocumentElement 340 public :: setDocumentElement 341 342 public :: createElement 343 public :: createDocumentFragment 344 public :: createTextNode 345 public :: createComment 346 public :: createCdataSection 347 public :: createProcessingInstruction 348 public :: createAttribute 349 public :: createEntityReference 350 public :: createEmptyEntityReference 351 public :: getElementsByTagName 352 public :: importNode 353 public :: createElementNS 354 public :: createAttributeNS 355 public :: getElementsByTagNameNS 356 public :: getElementById 357 public :: getXmlStandalone 358 public :: setXmlStandalone 359 public :: getXmlVersion 360 public :: setXmlVersion 361 public :: getXmlEncoding 362 public :: getInputEncoding 363 public :: getDocumentURI 364 public :: setDocumentURI 365 public :: getStrictErrorChecking 366 public :: setStrictErrorChecking 367 public :: getDomConfig 368 public :: renameNode 369 public :: adoptNode 370 371 public :: setDocType 372 public :: setDomConfig 373 public :: setXds 374 public :: createNamespaceNode 375 public :: createEntity 376 public :: createNotation 377 public :: setGCstate 378 public :: getXds 379 public :: getLiveNodeLists 380 public :: setLiveNodeLists 381 382 383 !public :: getName 384 public :: getEntities 385 public :: getNotations 386! public :: getPublicId 387! public :: getSystemId 388 public :: getInternalSubset 389 390 391 392 public :: getTagName 393 public :: getAttribute 394 public :: setAttribute 395 public :: removeAttribute 396 public :: getAttributeNode 397 public :: setAttributeNode 398 public :: removeAttributeNode 399 public :: getAttributeNS 400 public :: setAttributeNS 401 public :: removeAttributeNS 402 public :: getAttributeNodeNS 403 public :: setAttributeNodeNS 404 public :: removeAttributeNodeNS 405 public :: hasAttribute 406 public :: hasAttributeNS 407 public :: setIdAttribute 408 public :: setIdAttributeNS 409 public :: setIdAttributeNode 410 411 412 413 !public :: getName 414 public :: getSpecified 415 public :: setSpecified 416 interface getValue 417 module procedure getValue_DOM 418 end interface 419 public :: getValue 420 public :: setValue 421 public :: getOwnerElement 422 423 public :: getIsId 424 public :: setIsId 425 interface getIsId 426 module procedure getIsId_DOM 427 end interface 428 interface setIsId 429 module procedure setIsId_DOM 430 end interface 431 432 433 434 public :: getLength 435! public :: getData 436! public :: setData 437 public :: substringData 438 public :: appendData 439 public :: insertData 440 public :: deleteData 441 public :: replaceData 442 443 interface getLength 444 module procedure getLength_characterdata 445 end interface 446 447 448 449 public :: getNotationName 450 451 public :: getIllFormed 452 public :: setIllFormed 453 454 455 456 public :: getTarget 457 458 459 public :: splitText 460 public :: getIsElementContentWhitespace 461 public :: setIsElementContentWhitespace 462 463 464! Assorted functions with identical signatures despite belonging to different types. 465 466 public :: getData 467 public :: setData 468 public :: getName 469 public :: getPublicId 470 public :: getSystemId 471 472 473 474 public :: normalizeDocument 475 476 public :: getNamespaceNodes 477 public :: namespaceFixup 478 479 480contains 481 482 483 subroutine resetParameter(domConfig, name) 484 type(DOMConfiguration), pointer :: domConfig 485 character(len=*), intent(in) :: name 486 487 integer :: i, n 488 do i = 1, size(configParams) 489 if (toLower(name)==trim(configParams(i))) then 490 n = i 491 exit 492 endif 493 enddo 494 if (i>size(configParams)) return 495 if (.not.btest(paramSettable, n)) return 496 if (btest(paramDefaults, n)) then 497 domConfig%parameters = ibset(domConfig%parameters, n) 498 else 499 domConfig%parameters = ibclr(domConfig%parameters, n) 500 endif 501 end subroutine resetParameter 502 503 recursive subroutine setParameter(domConfig, name, value, ex) 504 type(DOMException), intent(out), optional :: ex 505 type(DOMConfiguration), pointer :: domConfig 506 character(len=*), intent(in) :: name 507 logical, intent(in) :: value 508 integer :: i, n 509 510 if (toLower(name)=="infoset") then 511 if (value) then 512 call setParameter(domConfig, "validate-if-schema", .false.) 513 call setParameter(domConfig, "entities", .false.) 514 ! cant do datatype-normalization 515 call setParameter(domConfig, "cdata-sections", .false.) 516 call setParameter(domConfig, "namespace-declarations", .true.) 517 ! well-formed cannot be changed 518 call setParameter(domConfig, "element-content-whitespace", .true.) 519 call setParameter(domConfig, "comments", .true.) 520 call setParameter(domConfig, "namespaces", .true.) 521 endif 522 return 523 endif 524 525 do i = 1, size(configParams) 526 if (toLower(name)==trim(configParams(i))) then 527 n = i 528 exit 529 endif 530 enddo 531 if (i > size(configParams)) then 532 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 533 call throw_exception(NOT_FOUND_ERR, "setParameter", ex) 534 if (present(ex)) then 535 if (inException(ex)) then 536 return 537 endif 538 endif 539endif 540 541 endif 542 if (.not.canSetParameter(domConfig, name, value)) then 543 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 544 call throw_exception(NOT_SUPPORTED_ERR, "setParameter", ex) 545 if (present(ex)) then 546 if (inException(ex)) then 547 return 548 endif 549 endif 550endif 551 552 endif 553 554 if (value) then 555 domConfig%parameters = ibset(domConfig%parameters, n) 556 else 557 domConfig%parameters = ibclr(domConfig%parameters, n) 558 endif 559 560 select case (toLower(name)) 561 case ("canonical-form") 562 if (value) then 563 domConfig%parameters = ibclr(domConfig%parameters, 7) 564 ! cant do normalize-characters 565 domConfig%parameters = ibclr(domConfig%parameters, 2) 566 domConfig%parameters = ibset(domConfig%parameters, 9) 567 domConfig%parameters = ibset(domConfig%parameters, 10) 568 ! well-formed cannot be changed 569 domConfig%parameters = ibset(domConfig%parameters, 6) 570 ! FIXME when we work out pretty-print/preserve-whitespace semantics 571 ! call setParameter(domConfig, "format-pretty-print", .false.) 572 domConfig%parameters = ibclr(domConfig%parameters, 21) 573 domConfig%parameters = ibclr(domConfig%parameters, 23) 574 domConfig%parameters = ibclr(domConfig%parameters, 24) 575 else 576 call resetParameter(domConfig, "entities") 577 ! cant do normalize-characters 578 call resetParameter(domConfig, "cdata-sections") 579 call resetParameter(domConfig, "namespaces") 580 call resetParameter(domConfig, "namespace-declarations") 581 ! well-formed cannot be changed 582 call resetParameter(domConfig, "element-content-whitespace") 583 call resetParameter(domConfig, "format-pretty-print") 584 call resetParameter(domConfig, "discard-default-content") 585 call resetParameter(domConfig, "xml-declaration") 586 call resetParameter(domConfig, "invalid-pretty-print") 587 endif 588 case ("cdata-sections") 589 if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) 590 case ("element-content-whitespace") 591 if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) 592 case ("entities") 593 if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) 594 case ("namespaces") 595 if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) 596 case ("namespaces-declarations") 597 if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) 598 case("validate") 599 if (value) domConfig%parameters = ibclr(domConfig%parameters, 14) 600 case ("validate-if-schema") 601 if (value) domConfig%parameters = ibclr(domConfig%parameters, 13) 602 case ("format-pretty-print") 603 if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) 604 case ("discard-default-content") 605 if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) 606 case ("xml-declaration") 607 if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) 608 case ("invalid-pretty-print") 609 if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) 610 end select 611 612 end subroutine setParameter 613 614 recursive function getParameter(domConfig, name, ex)result(value) 615 type(DOMException), intent(out), optional :: ex 616 type(DOMConfiguration), pointer :: domConfig 617 character(len=*), intent(in) :: name 618 logical :: value 619 620 integer :: i, n 621 622 if (toLower(name)=="infoset") then 623 value = & 624 .not.getParameter(domConfig, "validate-if-schema") & 625 .and..not.getParameter(domConfig, "entities") & 626 .and..not.getParameter(domConfig, "datatype-normalization") & 627 .and..not.getParameter(domConfig, "cdata-sections") & 628 .and.getParameter(domConfig, "namespace-declarations") & 629 .and.getParameter(domConfig, "well-formed") & 630 .and.getParameter(domConfig, "element-content-whitespace") & 631 .and.getParameter(domConfig, "comments") & 632 .and.getParameter(domConfig, "namespaces") 633 return 634 endif 635 636 do i = 1, size(configParams) 637 if (toLower(name)==trim(configParams(i))) then 638 n = i 639 exit 640 endif 641 enddo 642 if (i > size(configParams)) then 643 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 644 call throw_exception(NOT_FOUND_ERR, "getParameter", ex) 645 if (present(ex)) then 646 if (inException(ex)) then 647 return 648 endif 649 endif 650endif 651 652 endif 653 654 value = btest(domConfig%parameters, n) 655 656 end function getParameter 657 658 function canSetParameter_log(domConfig, name, value, ex)result(p) 659 type(DOMException), intent(out), optional :: ex 660 type(DOMConfiguration), pointer :: domConfig 661 character(len=*), intent(in) :: name 662 logical, intent(in) :: value 663 logical :: p 664 665 integer :: i, n 666 667 if (toLower(name)=="infoset") then 668 p = .true. 669 return 670 endif 671 do i = 1, size(configParams) 672 if (toLower(name)==trim(configParams(i))) then 673 n = i 674 exit 675 endif 676 enddo 677 if (i > size(configParams)) then 678 p = .false. 679 return 680 endif 681 682 p = btest(paramSettable, n) 683 684 end function canSetParameter_log 685 686 function canSetParameter_ch(domConfig, name, value, ex)result(p) 687 type(DOMException), intent(out), optional :: ex 688 type(DOMConfiguration), pointer :: domConfig 689 character(len=*), intent(in) :: name 690 character(len=*), intent(in) :: value 691 logical :: p 692 693 ! DOM 3 allows some config options to be set to strings 694 ! (eg schemaLocation) but we dont support any of these, 695 ! so no parameter can be set to a string. 696 p = .false. 697 698 end function canSetParameter_ch 699 700 function getParameterNames(domConfig, ex)result(s) 701 type(DOMException), intent(out), optional :: ex 702 type(DOMConfiguration), pointer :: domConfig 703 character(len=configParamLen) :: s(size(configParams)) 704 705 s = configParams 706 end function getParameterNames 707 708 function newDOMConfig() result(dc) 709 type(DOMConfiguration), pointer :: dc 710 allocate(dc) 711 end function newDOMConfig 712 713 subroutine copyDOMConfig(dc1, dc2) 714 type(DOMConfiguration), pointer :: dc1, dc2 715 716 dc1%parameters = dc2%parameters 717 end subroutine copyDOMConfig 718 719 subroutine destroyDOMConfig(dc) 720 type(DOMConfiguration), pointer :: dc 721 722 deallocate(dc) 723 end subroutine destroyDOMConfig 724 725 726 727 function createNode(arg, nodeType, nodeName, nodeValue, ex)result(np) 728 type(DOMException), intent(out), optional :: ex 729 type(Node), pointer :: arg 730 integer, intent(in) :: nodeType 731 character(len=*), intent(in) :: nodeName 732 character(len=*), intent(in) :: nodeValue 733 type(Node), pointer :: np 734 735 allocate(np) 736 np%ownerDocument => arg 737 np%nodeType = nodeType 738 np%nodeName => vs_str_alloc(nodeName) 739 np%nodeValue => vs_str_alloc(nodeValue) 740 741 allocate(np%childNodes%nodes(0)) 742 743 end function createNode 744 745 recursive subroutine destroyNode(np, ex) 746 type(DOMException), intent(out), optional :: ex 747 type(Node), pointer :: np 748 749 if (.not.associated(np)) return 750 751 select case(np%nodeType) 752 case (ELEMENT_NODE, ATTRIBUTE_NODE, XPATH_NAMESPACE_NODE) 753 call destroyElementOrAttribute(np, ex) 754 case (DOCUMENT_TYPE_NODE) 755 call destroyDocumentType(np, ex) 756 case (ENTITY_NODE, NOTATION_NODE) 757 call destroyEntityOrNotation(np, ex) 758 case (DOCUMENT_NODE) 759 call destroyDocument(np,ex) 760 end select 761 call destroyNodeContents(np) 762 deallocate(np) 763 764 end subroutine destroyNode 765 766 recursive subroutine destroyElementOrAttribute(np, ex) 767 type(DOMException), intent(out), optional :: ex 768 type(Node), pointer :: np 769 770 integer :: i 771 772 if (np%nodeType /= ELEMENT_NODE & 773 .and. np%nodeType /= ATTRIBUTE_NODE & 774 .and. np%nodeType /= XPATH_NAMESPACE_NODE) then 775 if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then 776 call throw_exception(FoX_INTERNAL_ERROR, "destroyElementOrAttribute", ex) 777 if (present(ex)) then 778 if (inException(ex)) then 779 return 780 endif 781 endif 782endif 783 784 endif 785 786 if (associated(np%elExtras%attributes%nodes)) deallocate(np%elExtras%attributes%nodes) 787 do i = 1, np%elExtras%namespaceNodes%length 788 call destroyNode(np%elExtras%namespaceNodes%nodes(i)%this) 789 enddo 790 if (associated(np%elExtras%namespaceNodes%nodes)) deallocate(np%elExtras%namespaceNodes%nodes) 791 if (associated(np%elExtras%namespaceURI)) deallocate(np%elExtras%namespaceURI) 792 if (associated(np%elExtras%prefix)) deallocate(np%elExtras%prefix) 793 if (associated(np%elExtras%localName)) deallocate(np%elExtras%localName) 794 deallocate(np%elExtras) 795 796 end subroutine destroyElementOrAttribute 797 798 subroutine destroyEntityOrNotation(np, ex) 799 type(DOMException), intent(out), optional :: ex 800 type(Node), pointer :: np 801 802 if (np%nodeType /= ENTITY_NODE & 803 .and. np%nodeType /= NOTATION_NODE) then 804 if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then 805 call throw_exception(FoX_INTERNAL_ERROR, "destroyEntityOrNotation", ex) 806 if (present(ex)) then 807 if (inException(ex)) then 808 return 809 endif 810 endif 811endif 812 813 endif 814 815 if (associated(np%dtdExtras%publicId)) deallocate(np%dtdExtras%publicId) 816 if (associated(np%dtdExtras%systemId)) deallocate(np%dtdExtras%systemId) 817 if (associated(np%dtdExtras%notationName)) deallocate(np%dtdExtras%notationName) 818 819 deallocate(np%dtdExtras) 820 821 end subroutine destroyEntityOrNotation 822 823 subroutine destroyDocumentType(np, ex) 824 type(DOMException), intent(out), optional :: ex 825 type(Node), pointer :: np 826 827 integer :: i 828 829 if (np%nodeType /= DOCUMENT_TYPE_NODE) then 830 if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then 831 call throw_exception(FoX_INTERNAL_ERROR, "destroyDocumentType", ex) 832 if (present(ex)) then 833 if (inException(ex)) then 834 return 835 endif 836 endif 837endif 838 839 endif 840 841 if (associated(np%dtdExtras%publicId)) deallocate(np%dtdExtras%publicId) 842 if (associated(np%dtdExtras%systemId)) deallocate(np%dtdExtras%systemId) 843 844 ! Destroy all entities & notations (docType only) 845 if (associated(np%dtdExtras%entities%nodes)) then 846 do i = 1, size(np%dtdExtras%entities%nodes) 847 call destroyAllNodesRecursively(np%dtdExtras%entities%nodes(i)%this) 848 enddo 849 deallocate(np%dtdExtras%entities%nodes) 850 endif 851 if (associated(np%dtdExtras%notations%nodes)) then 852 do i = 1, size(np%dtdExtras%notations%nodes) 853 call destroy(np%dtdExtras%notations%nodes(i)%this) 854 enddo 855 deallocate(np%dtdExtras%notations%nodes) 856 endif 857 858 deallocate(np%dtdExtras) 859 860 end subroutine destroyDocumentType 861 862 recursive subroutine destroyAllNodesRecursively(arg, except) 863 ! Only recurses once into destroyDocumentType 864 type(Node), pointer :: arg 865 logical, intent(in), optional :: except 866 867 type(Node), pointer :: this, deadNode, treeroot 868 logical :: doneChildren, doneAttributes 869 integer :: i_tree 870 871 if (.not.associated(arg)) return 872 873 treeroot => arg 874 875 i_tree = 0 876 doneChildren = .false. 877 doneAttributes = .false. 878 this => treeroot 879 deadNode => null() 880 do 881 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 882 883 else 884 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 885 doneAttributes = .true. 886 else 887 888 endif 889 endif 890 891 deadNode => null() 892 893 if (.not.doneChildren) then 894 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 895 if (getLength(getAttributes(this))>0) then 896 this => item(getAttributes(this), 0) 897 else 898 doneAttributes = .true. 899 endif 900 elseif (hasChildNodes(this)) then 901 this => getFirstChild(this) 902 doneChildren = .false. 903 doneAttributes = .false. 904 else 905 doneChildren = .true. 906 doneAttributes = .false. 907 endif 908 909 else ! if doneChildren 910 911 deadNode => this 912 if (associated(this, treeroot)) exit 913 if (getNodeType(this)==ATTRIBUTE_NODE) then 914 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 915 i_tree= i_tree+ 1 916 this => item(getAttributes(getOwnerElement(this)), i_tree) 917 doneChildren = .false. 918 else 919 i_tree= 0 920 this => getOwnerElement(this) 921 doneAttributes = .true. 922 doneChildren = .false. 923 endif 924 elseif (associated(getNextSibling(this))) then 925 926 this => getNextSibling(this) 927 doneChildren = .false. 928 doneAttributes = .false. 929 else 930 this => getParentNode(this) 931 endif 932 call destroy(deadNode) 933 endif 934 935 enddo 936 937 938 939 deallocate(arg%childNodes%nodes) 940 allocate(arg%childNodes%nodes(0)) 941 arg%firstChild => null() 942 arg%lastChild => null() 943 944 if (.not.present(except)) call destroyNode(arg) 945 946 end subroutine destroyAllNodesRecursively 947 948 subroutine destroyNodeContents(np) 949 type(Node), intent(inout) :: np 950 951 if (associated(np%nodeName)) deallocate(np%nodeName) 952 if (associated(np%nodeValue)) deallocate(np%nodeValue) 953 954 deallocate(np%childNodes%nodes) 955 956 end subroutine destroyNodeContents 957 958 959 960 961 pure function getnodeName_len(np, p) result(n) 962 type(Node), intent(in) :: np 963 logical, intent(in) :: p 964 integer :: n 965 966 if (p) then 967 n = size(np%nodeName) 968 else 969 n = 0 970 endif 971 end function getnodeName_len 972function getnodeName(np, ex)result(c) 973 type(DOMException), intent(out), optional :: ex 974 type(Node), pointer :: np 975#ifdef RESTRICTED_ASSOCIATED_BUG 976 character(len=getnodeName_len(np, .true.)) :: c 977#else 978 character(len=getnodeName_len(np, associated(np))) :: c 979#endif 980 981 982 if (.not.associated(np)) then 983 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 984 call throw_exception(FoX_NODE_IS_NULL, "getnodeName", ex) 985 if (present(ex)) then 986 if (inException(ex)) then 987 return 988 endif 989 endif 990endif 991 992 endif 993 994 995 c = str_vs(np%nodeName) 996 997 end function getnodeName 998 999 1000 pure function getNodeValue_len(np, p) result(n) 1001 type(Node), intent(in) :: np 1002 logical, intent(in) :: p 1003 integer :: n 1004 1005 n = 0 1006 if (.not.p) return 1007 1008 select case(np%nodeType) 1009 case (ATTRIBUTE_NODE) 1010 n = getTextContent_len(np, .true.) 1011 case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) 1012 n = size(np%nodeValue) 1013 end select 1014 1015 end function getNodeValue_len 1016 1017 function getNodeValue(np, ex)result(c) 1018 type(DOMException), intent(out), optional :: ex 1019 type(Node), pointer :: np 1020#ifdef RESTRICTED_ASSOCIATED_BUG 1021 character(len=getNodeValue_len(np, .true.)) :: c 1022#else 1023 character(len=getNodeValue_len(np, associated(np))) :: c 1024#endif 1025 1026 if (.not.associated(np)) then 1027 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1028 call throw_exception(FoX_NODE_IS_NULL, "getNodeValue", ex) 1029 if (present(ex)) then 1030 if (inException(ex)) then 1031 return 1032 endif 1033 endif 1034endif 1035 1036 endif 1037 1038 select case(np%nodeType) 1039 case (ATTRIBUTE_NODE) 1040 c = getTextContent(np) 1041 case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) 1042 c = str_vs(np%nodeValue) 1043 case default 1044 c = "" 1045 end select 1046 1047 end function getNodeValue 1048 1049 subroutine setNodeValue(arg, nodeValue, ex) 1050 type(DOMException), intent(out), optional :: ex 1051 type(Node), pointer :: arg 1052 character(len=*) :: nodeValue 1053 1054 if (.not.associated(arg)) then 1055 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1056 call throw_exception(FoX_NODE_IS_NULL, "setNodeValue", ex) 1057 if (present(ex)) then 1058 if (inException(ex)) then 1059 return 1060 endif 1061 endif 1062endif 1063 1064 endif 1065 1066 if (associated(getOwnerDocument(arg))) then 1067 if (.not.checkChars(nodeValue, getXmlVersionEnum(getOwnerDocument(arg)))) then 1068 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 1069 call throw_exception(FoX_INVALID_CHARACTER, "setNodeValue", ex) 1070 if (present(ex)) then 1071 if (inException(ex)) then 1072 return 1073 endif 1074 endif 1075endif 1076 1077 endif 1078 endif ! Otherwise its a document node, and nothing will happen anyway 1079 1080 select case(arg%nodeType) 1081 case (ATTRIBUTE_NODE) 1082 call setValue(arg, nodeValue, ex) 1083 case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) 1084 call setData(arg, nodeValue, ex) 1085 end select 1086 1087 end subroutine setNodeValue 1088 1089function getnodeType(np, ex)result(c) 1090 type(DOMException), intent(out), optional :: ex 1091 type(Node), pointer :: np 1092 integer :: c 1093 1094 1095 if (.not.associated(np)) then 1096 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1097 call throw_exception(FoX_NODE_IS_NULL, "getnodeType", ex) 1098 if (present(ex)) then 1099 if (inException(ex)) then 1100 return 1101 endif 1102 endif 1103endif 1104 1105 endif 1106 1107 1108 c = np%nodeType 1109 1110 end function getnodeType 1111 1112 1113function getparentNode(np, ex)result(c) 1114 type(DOMException), intent(out), optional :: ex 1115 type(Node), pointer :: np 1116 type(Node), pointer :: c 1117 1118 1119 if (.not.associated(np)) then 1120 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1121 call throw_exception(FoX_NODE_IS_NULL, "getparentNode", ex) 1122 if (present(ex)) then 1123 if (inException(ex)) then 1124 return 1125 endif 1126 endif 1127endif 1128 1129 endif 1130 1131 1132 c => np%parentNode 1133 1134 end function getparentNode 1135 1136 1137function getchildNodes(np, ex)result(c) 1138 type(DOMException), intent(out), optional :: ex 1139 type(Node), pointer :: np 1140 type(NodeList), pointer :: c 1141 1142 1143 if (.not.associated(np)) then 1144 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1145 call throw_exception(FoX_NODE_IS_NULL, "getchildNodes", ex) 1146 if (present(ex)) then 1147 if (inException(ex)) then 1148 return 1149 endif 1150 endif 1151endif 1152 1153 endif 1154 1155 1156 c => np%childNodes 1157 1158 end function getchildNodes 1159 1160 1161function getfirstChild(np, ex)result(c) 1162 type(DOMException), intent(out), optional :: ex 1163 type(Node), pointer :: np 1164 type(Node), pointer :: c 1165 1166 1167 if (.not.associated(np)) then 1168 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1169 call throw_exception(FoX_NODE_IS_NULL, "getfirstChild", ex) 1170 if (present(ex)) then 1171 if (inException(ex)) then 1172 return 1173 endif 1174 endif 1175endif 1176 1177 endif 1178 1179 1180 c => np%firstChild 1181 1182 end function getfirstChild 1183 1184 1185function getlastChild(np, ex)result(c) 1186 type(DOMException), intent(out), optional :: ex 1187 type(Node), pointer :: np 1188 type(Node), pointer :: c 1189 1190 1191 if (.not.associated(np)) then 1192 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1193 call throw_exception(FoX_NODE_IS_NULL, "getlastChild", ex) 1194 if (present(ex)) then 1195 if (inException(ex)) then 1196 return 1197 endif 1198 endif 1199endif 1200 1201 endif 1202 1203 1204 c => np%lastChild 1205 1206 end function getlastChild 1207 1208 1209function getpreviousSibling(np, ex)result(c) 1210 type(DOMException), intent(out), optional :: ex 1211 type(Node), pointer :: np 1212 type(Node), pointer :: c 1213 1214 1215 if (.not.associated(np)) then 1216 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1217 call throw_exception(FoX_NODE_IS_NULL, "getpreviousSibling", ex) 1218 if (present(ex)) then 1219 if (inException(ex)) then 1220 return 1221 endif 1222 endif 1223endif 1224 1225 endif 1226 1227 1228 c => np%previousSibling 1229 1230 end function getpreviousSibling 1231 1232 1233function getnextSibling(np, ex)result(c) 1234 type(DOMException), intent(out), optional :: ex 1235 type(Node), pointer :: np 1236 type(Node), pointer :: c 1237 1238 1239 if (.not.associated(np)) then 1240 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1241 call throw_exception(FoX_NODE_IS_NULL, "getnextSibling", ex) 1242 if (present(ex)) then 1243 if (inException(ex)) then 1244 return 1245 endif 1246 endif 1247endif 1248 1249 endif 1250 1251 1252 c => np%nextSibling 1253 1254 end function getnextSibling 1255 1256 1257 function getAttributes(arg, ex)result(nnm) 1258 type(DOMException), intent(out), optional :: ex 1259 type(Node), pointer :: arg 1260 type(NamedNodeMap), pointer :: nnm 1261 1262 if (.not.associated(arg)) then 1263 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1264 call throw_exception(FoX_NODE_IS_NULL, "getAttributes", ex) 1265 if (present(ex)) then 1266 if (inException(ex)) then 1267 return 1268 endif 1269 endif 1270endif 1271 1272 endif 1273 1274 if (getNodeType(arg)==ELEMENT_NODE) then 1275 nnm => arg%elExtras%attributes 1276 else 1277 nnm => null() 1278 endif 1279 end function getAttributes 1280 1281 function getOwnerDocument(arg, ex)result(np) 1282 type(DOMException), intent(out), optional :: ex 1283 type(Node), pointer :: arg 1284 type(Node), pointer :: np 1285 1286 if (.not.associated(arg)) then 1287 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1288 call throw_exception(FoX_NODE_IS_NULL, "getOwnerDocument", ex) 1289 if (present(ex)) then 1290 if (inException(ex)) then 1291 return 1292 endif 1293 endif 1294endif 1295 1296 endif 1297 1298 if (arg%nodeType==DOCUMENT_NODE) then 1299 np => null() 1300 else 1301 np => arg%ownerDocument 1302 endif 1303 end function getOwnerDocument 1304 1305subroutine setownerDocument(np, c, ex) 1306 type(DOMException), intent(out), optional :: ex 1307 type(Node), pointer :: np 1308 type(Node), pointer :: c 1309 1310 1311 if (.not.associated(np)) then 1312 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1313 call throw_exception(FoX_NODE_IS_NULL, "setownerDocument", ex) 1314 if (present(ex)) then 1315 if (inException(ex)) then 1316 return 1317 endif 1318 endif 1319endif 1320 1321 endif 1322 1323 if (getNodeType(np)/=DOCUMENT_NODE .and. & 1324 .true.) then 1325 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 1326 call throw_exception(FoX_INVALID_NODE, "setownerDocument", ex) 1327 if (present(ex)) then 1328 if (inException(ex)) then 1329 return 1330 endif 1331 endif 1332endif 1333 1334 endif 1335 1336 np%ownerDocument => c 1337 1338 end subroutine setownerDocument 1339 1340 1341 function insertBefore(arg, newChild, refChild, ex)result(np) 1342 type(DOMException), intent(out), optional :: ex 1343 type(Node), pointer :: arg 1344 type(Node), pointer :: newChild 1345 type(Node), pointer :: refChild 1346 type(Node), pointer :: np 1347 1348 type(Node), pointer :: testChild, testParent, treeroot, this 1349 type(ListNode), pointer :: temp_nl(:) 1350 integer :: i, i2, i_t, i_tree 1351 logical :: doneChildren, doneAttributes 1352 1353 if (.not.associated(arg).or..not.associated(newChild)) then 1354 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1355 call throw_exception(FoX_NODE_IS_NULL, "insertBefore", ex) 1356 if (present(ex)) then 1357 if (inException(ex)) then 1358 return 1359 endif 1360 endif 1361endif 1362 1363 endif 1364 1365 if (.not.associated(refChild)) then 1366 np => appendChild(arg, newChild, ex) 1367 return 1368 endif 1369 1370 if (arg%readonly) then 1371 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 1372 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "insertBefore", ex) 1373 if (present(ex)) then 1374 if (inException(ex)) then 1375 return 1376 endif 1377 endif 1378endif 1379 1380 endif 1381 1382 testParent => arg 1383 ! Check if you are allowed to put a newChild nodetype under a arg nodetype 1384 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 1385 do i = 1, newChild%childNodes%length 1386 testChild => newChild%childNodes%nodes(i)%this 1387 select case(testParent%nodeType) 1388 case (ELEMENT_NODE) 1389 if (testChild%nodeType/=ELEMENT_NODE & 1390 .and. testChild%nodeType/=TEXT_NODE & 1391 .and. testChild%nodeType/=COMMENT_NODE & 1392 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 1393 .and. testChild%nodeType/=CDATA_SECTION_NODE & 1394 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 1395 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1396 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1397 if (present(ex)) then 1398 if (inException(ex)) then 1399 return 1400 endif 1401 endif 1402endif 1403 1404 endif 1405 case (ATTRIBUTE_NODE) 1406 if (testChild%nodeType/=TEXT_NODE & 1407 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 1408 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1409 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1410 if (present(ex)) then 1411 if (inException(ex)) then 1412 return 1413 endif 1414 endif 1415endif 1416 1417 endif 1418 if (testChild%nodeType==ENTITY_REFERENCE_NODE) then 1419 treeroot => testChild 1420 1421 i_tree = 0 1422 doneChildren = .false. 1423 doneAttributes = .false. 1424 this => treeroot 1425 do 1426 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 1427 1428 if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then 1429 if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then 1430 call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1431 if (present(ex)) then 1432 if (inException(ex)) then 1433 return 1434 endif 1435 endif 1436endif 1437 1438 endif 1439 1440 else 1441 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 1442 doneAttributes = .true. 1443 else 1444 1445 endif 1446 endif 1447 1448 1449 if (.not.doneChildren) then 1450 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 1451 if (getLength(getAttributes(this))>0) then 1452 this => item(getAttributes(this), 0) 1453 else 1454 doneAttributes = .true. 1455 endif 1456 elseif (hasChildNodes(this)) then 1457 this => getFirstChild(this) 1458 doneChildren = .false. 1459 doneAttributes = .false. 1460 else 1461 doneChildren = .true. 1462 doneAttributes = .false. 1463 endif 1464 1465 else ! if doneChildren 1466 1467 if (associated(this, treeroot)) exit 1468 if (getNodeType(this)==ATTRIBUTE_NODE) then 1469 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 1470 i_tree= i_tree+ 1 1471 this => item(getAttributes(getOwnerElement(this)), i_tree) 1472 doneChildren = .false. 1473 else 1474 i_tree= 0 1475 this => getOwnerElement(this) 1476 doneAttributes = .true. 1477 doneChildren = .false. 1478 endif 1479 elseif (associated(getNextSibling(this))) then 1480 1481 this => getNextSibling(this) 1482 doneChildren = .false. 1483 doneAttributes = .false. 1484 else 1485 this => getParentNode(this) 1486 endif 1487 endif 1488 1489 enddo 1490 1491 1492 endif 1493 case (DOCUMENT_NODE) 1494 if ((testChild%nodeType/=ELEMENT_NODE .or. & 1495 (testChild%nodeType==ELEMENT_NODE & 1496 .and.associated(testParent%docExtras%documentElement))) & 1497 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 1498 .and. testChild%nodeType/=COMMENT_NODE & 1499 .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & 1500 (testChild%nodeType==DOCUMENT_TYPE_NODE & 1501 .and.associated(testParent%docExtras%docType)))) then 1502 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1503 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1504 if (present(ex)) then 1505 if (inException(ex)) then 1506 return 1507 endif 1508 endif 1509endif 1510 1511 endif 1512 case (DOCUMENT_FRAGMENT_NODE) 1513 if (testChild%nodeType/=ELEMENT_NODE & 1514 .and. testChild%nodeType/=TEXT_NODE & 1515 .and. testChild%nodeType/=COMMENT_NODE & 1516 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 1517 .and. testChild%nodeType/=CDATA_SECTION_NODE & 1518 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 1519 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1520 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1521 if (present(ex)) then 1522 if (inException(ex)) then 1523 return 1524 endif 1525 endif 1526endif 1527 1528 endif 1529 case (ENTITY_NODE) 1530 continue ! only allowed by DOM parser, not by user. 1531 ! but entity nodes are always readonly anyway, so no problem 1532 case (ENTITY_REFERENCE_NODE) 1533 continue ! only allowed by DOM parser, not by user. 1534 ! but entity nodes are always readonly anyway, so no problem 1535 case default 1536 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1537 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1538 if (present(ex)) then 1539 if (inException(ex)) then 1540 return 1541 endif 1542 endif 1543endif 1544 1545 end select 1546 1547 enddo 1548 else 1549 testChild => newChild 1550 select case(testParent%nodeType) 1551 case (ELEMENT_NODE) 1552 if (testChild%nodeType/=ELEMENT_NODE & 1553 .and. testChild%nodeType/=TEXT_NODE & 1554 .and. testChild%nodeType/=COMMENT_NODE & 1555 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 1556 .and. testChild%nodeType/=CDATA_SECTION_NODE & 1557 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 1558 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1559 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1560 if (present(ex)) then 1561 if (inException(ex)) then 1562 return 1563 endif 1564 endif 1565endif 1566 1567 endif 1568 case (ATTRIBUTE_NODE) 1569 if (testChild%nodeType/=TEXT_NODE & 1570 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 1571 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1572 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1573 if (present(ex)) then 1574 if (inException(ex)) then 1575 return 1576 endif 1577 endif 1578endif 1579 1580 endif 1581 if (testChild%nodeType==ENTITY_REFERENCE_NODE) then 1582 treeroot => testChild 1583 1584 i_tree = 0 1585 doneChildren = .false. 1586 doneAttributes = .false. 1587 this => treeroot 1588 do 1589 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 1590 1591 if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then 1592 if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then 1593 call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1594 if (present(ex)) then 1595 if (inException(ex)) then 1596 return 1597 endif 1598 endif 1599endif 1600 1601 endif 1602 1603 else 1604 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 1605 doneAttributes = .true. 1606 else 1607 1608 endif 1609 endif 1610 1611 1612 if (.not.doneChildren) then 1613 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 1614 if (getLength(getAttributes(this))>0) then 1615 this => item(getAttributes(this), 0) 1616 else 1617 doneAttributes = .true. 1618 endif 1619 elseif (hasChildNodes(this)) then 1620 this => getFirstChild(this) 1621 doneChildren = .false. 1622 doneAttributes = .false. 1623 else 1624 doneChildren = .true. 1625 doneAttributes = .false. 1626 endif 1627 1628 else ! if doneChildren 1629 1630 if (associated(this, treeroot)) exit 1631 if (getNodeType(this)==ATTRIBUTE_NODE) then 1632 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 1633 i_tree= i_tree+ 1 1634 this => item(getAttributes(getOwnerElement(this)), i_tree) 1635 doneChildren = .false. 1636 else 1637 i_tree= 0 1638 this => getOwnerElement(this) 1639 doneAttributes = .true. 1640 doneChildren = .false. 1641 endif 1642 elseif (associated(getNextSibling(this))) then 1643 1644 this => getNextSibling(this) 1645 doneChildren = .false. 1646 doneAttributes = .false. 1647 else 1648 this => getParentNode(this) 1649 endif 1650 endif 1651 1652 enddo 1653 1654 1655 endif 1656 case (DOCUMENT_NODE) 1657 if ((testChild%nodeType/=ELEMENT_NODE .or. & 1658 (testChild%nodeType==ELEMENT_NODE & 1659 .and.associated(testParent%docExtras%documentElement))) & 1660 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 1661 .and. testChild%nodeType/=COMMENT_NODE & 1662 .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & 1663 (testChild%nodeType==DOCUMENT_TYPE_NODE & 1664 .and.associated(testParent%docExtras%docType)))) then 1665 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1666 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1667 if (present(ex)) then 1668 if (inException(ex)) then 1669 return 1670 endif 1671 endif 1672endif 1673 1674 endif 1675 case (DOCUMENT_FRAGMENT_NODE) 1676 if (testChild%nodeType/=ELEMENT_NODE & 1677 .and. testChild%nodeType/=TEXT_NODE & 1678 .and. testChild%nodeType/=COMMENT_NODE & 1679 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 1680 .and. testChild%nodeType/=CDATA_SECTION_NODE & 1681 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 1682 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1683 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1684 if (present(ex)) then 1685 if (inException(ex)) then 1686 return 1687 endif 1688 endif 1689endif 1690 1691 endif 1692 case (ENTITY_NODE) 1693 continue ! only allowed by DOM parser, not by user. 1694 ! but entity nodes are always readonly anyway, so no problem 1695 case (ENTITY_REFERENCE_NODE) 1696 continue ! only allowed by DOM parser, not by user. 1697 ! but entity nodes are always readonly anyway, so no problem 1698 case default 1699 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1700 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1701 if (present(ex)) then 1702 if (inException(ex)) then 1703 return 1704 endif 1705 endif 1706endif 1707 1708 end select 1709 1710 ! And then check that newChild is not arg or one of args ancestors 1711 ! (this would never be true if newChild is a documentFragment) 1712 testParent => arg 1713 do while (associated(testParent)) 1714 if (associated(testParent, newChild)) then 1715 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1716 call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) 1717 if (present(ex)) then 1718 if (inException(ex)) then 1719 return 1720 endif 1721 endif 1722endif 1723 1724 endif 1725 testParent => testParent%parentNode 1726 enddo 1727 endif 1728 1729 if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & 1730 .not.(associated(arg%ownerDocument, newChild%ownerDocument) & 1731 .or.associated(arg, newChild%ownerDocument))) then 1732 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 1733 call throw_exception(WRONG_DOCUMENT_ERR, "insertBefore", ex) 1734 if (present(ex)) then 1735 if (inException(ex)) then 1736 return 1737 endif 1738 endif 1739endif 1740 1741 endif 1742 1743 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE & 1744 .and. newChild%childNodes%length==0) then 1745 np => newChild 1746 return 1747 ! Nothing to do 1748 endif 1749 if (associated(getParentNode(newChild))) then 1750 np => removeChild(getParentNode(newChild), newChild, ex) 1751 newChild => np 1752 endif 1753 1754 if (arg%childNodes%length==0) then 1755 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 1756 call throw_exception(NOT_FOUND_ERR, "insertBefore", ex) 1757 if (present(ex)) then 1758 if (inException(ex)) then 1759 return 1760 endif 1761 endif 1762endif 1763 1764 elseif (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 1765 allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length)) 1766 else 1767 allocate(temp_nl(arg%childNodes%length+1)) 1768 endif 1769 1770 i_t = 0 1771 np => null() 1772 do i = 1, arg%childNodes%length 1773 if (associated(arg%childNodes%nodes(i)%this, refChild)) then 1774 np => refChild 1775 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 1776 do i2 = 1, newChild%childNodes%length 1777 i_t = i_t + 1 1778 temp_nl(i_t)%this => newChild%childNodes%nodes(i2)%this 1779 temp_nl(i_t)%this%parentNode => arg 1780! call namespaceFixup(temp_nl(i_t)%this) 1781 enddo 1782 else 1783 i_t = i_t + 1 1784 temp_nl(i_t)%this => newChild 1785 temp_nl(i_t)%this%parentNode => arg 1786! call namespaceFixup(temp_nl(i_t)%this) 1787 endif 1788 if (i==1) then 1789 arg%firstChild => temp_nl(1)%this 1790 !temp_nl(1)%this%previousSibling => null() ! This is a no-op 1791 else 1792 temp_nl(i-1)%this%nextSibling => temp_nl(i)%this 1793 temp_nl(i)%this%previousSibling => temp_nl(i-1)%this 1794 endif 1795 arg%childNodes%nodes(i)%this%previousSibling => temp_nl(i_t)%this 1796 temp_nl(i_t)%this%nextSibling => arg%childNodes%nodes(i)%this 1797 endif 1798 i_t = i_t + 1 1799 temp_nl(i_t)%this => arg%childNodes%nodes(i)%this 1800 enddo 1801 1802 if (.not.associated(np)) then 1803 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 1804 call throw_exception(NOT_FOUND_ERR, "insertBefore", ex) 1805 if (present(ex)) then 1806 if (inException(ex)) then 1807 1808 if (associated(temp_nl)) deallocate(temp_nl) 1809 return 1810 endif 1811 endif 1812endif 1813 1814 endif 1815 1816 np => newChild 1817 if (getGCstate(arg%ownerDocument)) then 1818 if (arg%inDocument) then 1819 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 1820 do i = 1, newChild%childNodes%length 1821 call putNodesInDocument(arg%ownerDocument, newChild%childNodes%nodes(i)%this) 1822 enddo 1823 else 1824 call putNodesInDocument(arg%ownerDocument, newChild) 1825 endif 1826 ! If newChild was originally in document, it was removed above so must be re-added 1827 ! Ideally we would avoid the cost of removal & readding to hanging nodelist 1828 endif 1829 ! If arg was not in the document, then newChildren were either 1830 ! a) removed above in call to removeChild or 1831 ! b) in a document fragment and therefore not part of doc either 1832 endif 1833 1834 1835 if (getNodeType(newChild)==DOCUMENT_FRAGMENT_NODE) then 1836 deallocate(newChild%childNodes%nodes) 1837 allocate(newChild%childNodes%nodes(0)) 1838 newChild%childNodes%length = 0 1839 endif 1840 deallocate(arg%childNodes%nodes) 1841 arg%childNodes%nodes => temp_nl 1842 arg%childNodes%length = size(arg%childNodes%nodes) 1843 1844 call updateNodeLists(arg%ownerDocument) 1845 1846 call updateTextContentLength(arg, newChild%textContentLength) 1847 1848 end function insertBefore 1849 1850 1851 function replaceChild(arg, newChild, oldChild, ex)result(np) 1852 type(DOMException), intent(out), optional :: ex 1853 type(Node), pointer :: arg 1854 type(Node), pointer :: newChild 1855 type(Node), pointer :: oldChild 1856 type(Node), pointer :: np 1857 1858 type(Node), pointer :: testChild, testParent, treeroot, this 1859 type(ListNode), pointer :: temp_nl(:) 1860 integer :: i, i2, i_t, i_tree 1861 logical :: doneChildren, doneAttributes 1862 1863 if (.not.associated(arg).or..not.associated(newChild).or..not.associated(oldChild)) then 1864 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 1865 call throw_exception(FoX_NODE_IS_NULL, "replaceChild", ex) 1866 if (present(ex)) then 1867 if (inException(ex)) then 1868 return 1869 endif 1870 endif 1871endif 1872 1873 endif 1874 1875 if (arg%readonly) then 1876 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 1877 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "replaceChild", ex) 1878 if (present(ex)) then 1879 if (inException(ex)) then 1880 return 1881 endif 1882 endif 1883endif 1884 1885 endif 1886 1887 testParent => arg 1888 ! Check if you are allowed to put a newChild nodetype under a arg nodetype 1889 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 1890 do i = 1, newChild%childNodes%length 1891 testChild => newChild%childNodes%nodes(i)%this 1892 select case(testParent%nodeType) 1893 case (ELEMENT_NODE) 1894 if (testChild%nodeType/=ELEMENT_NODE & 1895 .and. testChild%nodeType/=TEXT_NODE & 1896 .and. testChild%nodeType/=COMMENT_NODE & 1897 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 1898 .and. testChild%nodeType/=CDATA_SECTION_NODE & 1899 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 1900 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1901 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 1902 if (present(ex)) then 1903 if (inException(ex)) then 1904 return 1905 endif 1906 endif 1907endif 1908 1909 endif 1910 case (ATTRIBUTE_NODE) 1911 if (testChild%nodeType/=TEXT_NODE & 1912 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 1913 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 1914 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 1915 if (present(ex)) then 1916 if (inException(ex)) then 1917 return 1918 endif 1919 endif 1920endif 1921 1922 endif 1923 if (testChild%nodeType==ENTITY_REFERENCE_NODE) then 1924 treeroot => testChild 1925 1926 i_tree = 0 1927 doneChildren = .false. 1928 doneAttributes = .false. 1929 this => treeroot 1930 do 1931 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 1932 1933 if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then 1934 if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then 1935 call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "replaceChild", ex) 1936 if (present(ex)) then 1937 if (inException(ex)) then 1938 return 1939 endif 1940 endif 1941endif 1942 1943 endif 1944 1945 else 1946 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 1947 doneAttributes = .true. 1948 else 1949 1950 endif 1951 endif 1952 1953 1954 if (.not.doneChildren) then 1955 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 1956 if (getLength(getAttributes(this))>0) then 1957 this => item(getAttributes(this), 0) 1958 else 1959 doneAttributes = .true. 1960 endif 1961 elseif (hasChildNodes(this)) then 1962 this => getFirstChild(this) 1963 doneChildren = .false. 1964 doneAttributes = .false. 1965 else 1966 doneChildren = .true. 1967 doneAttributes = .false. 1968 endif 1969 1970 else ! if doneChildren 1971 1972 if (associated(this, treeroot)) exit 1973 if (getNodeType(this)==ATTRIBUTE_NODE) then 1974 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 1975 i_tree= i_tree+ 1 1976 this => item(getAttributes(getOwnerElement(this)), i_tree) 1977 doneChildren = .false. 1978 else 1979 i_tree= 0 1980 this => getOwnerElement(this) 1981 doneAttributes = .true. 1982 doneChildren = .false. 1983 endif 1984 elseif (associated(getNextSibling(this))) then 1985 1986 this => getNextSibling(this) 1987 doneChildren = .false. 1988 doneAttributes = .false. 1989 else 1990 this => getParentNode(this) 1991 endif 1992 endif 1993 1994 enddo 1995 1996 1997 endif 1998 case (DOCUMENT_NODE) 1999 if ((testChild%nodeType/=ELEMENT_NODE .or. & 2000 (testChild%nodeType==ELEMENT_NODE & 2001 .and.associated(testParent%docExtras%documentElement) & 2002 .and.oldChild%nodeType/=ELEMENT_NODE)) & 2003 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2004 .and. testChild%nodeType/=COMMENT_NODE & 2005 .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & 2006 (testChild%nodeType==DOCUMENT_TYPE_NODE & 2007 .and.associated(testParent%docExtras%docType) & 2008 .and.oldChild%nodeType/=DOCUMENT_TYPE_NODE))) then 2009 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2010 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2011 if (present(ex)) then 2012 if (inException(ex)) then 2013 return 2014 endif 2015 endif 2016endif 2017 2018 endif 2019 case (DOCUMENT_FRAGMENT_NODE) 2020 if (testChild%nodeType/=ELEMENT_NODE & 2021 .and. testChild%nodeType/=TEXT_NODE & 2022 .and. testChild%nodeType/=COMMENT_NODE & 2023 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2024 .and. testChild%nodeType/=CDATA_SECTION_NODE & 2025 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2026 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2027 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2028 if (present(ex)) then 2029 if (inException(ex)) then 2030 return 2031 endif 2032 endif 2033endif 2034 2035 endif 2036 case (ENTITY_NODE) 2037 continue ! only allowed by DOM parser, not by user. 2038 ! but entity nodes are always readonly anyway, so no problem 2039 case (ENTITY_REFERENCE_NODE) 2040 continue ! only allowed by DOM parser, not by user. 2041 ! but entity nodes are always readonly anyway, so no problem 2042 case default 2043 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2044 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2045 if (present(ex)) then 2046 if (inException(ex)) then 2047 return 2048 endif 2049 endif 2050endif 2051 2052 end select 2053 2054 enddo 2055 else 2056 testChild => newChild 2057 select case(testParent%nodeType) 2058 case (ELEMENT_NODE) 2059 if (testChild%nodeType/=ELEMENT_NODE & 2060 .and. testChild%nodeType/=TEXT_NODE & 2061 .and. testChild%nodeType/=COMMENT_NODE & 2062 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2063 .and. testChild%nodeType/=CDATA_SECTION_NODE & 2064 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2065 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2066 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2067 if (present(ex)) then 2068 if (inException(ex)) then 2069 return 2070 endif 2071 endif 2072endif 2073 2074 endif 2075 case (ATTRIBUTE_NODE) 2076 if (testChild%nodeType/=TEXT_NODE & 2077 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2078 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2079 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2080 if (present(ex)) then 2081 if (inException(ex)) then 2082 return 2083 endif 2084 endif 2085endif 2086 2087 endif 2088 if (testChild%nodeType==ENTITY_REFERENCE_NODE) then 2089 treeroot => testChild 2090 2091 i_tree = 0 2092 doneChildren = .false. 2093 doneAttributes = .false. 2094 this => treeroot 2095 do 2096 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 2097 2098 if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then 2099 if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then 2100 call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2101 if (present(ex)) then 2102 if (inException(ex)) then 2103 return 2104 endif 2105 endif 2106endif 2107 2108 endif 2109 2110 else 2111 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 2112 doneAttributes = .true. 2113 else 2114 2115 endif 2116 endif 2117 2118 2119 if (.not.doneChildren) then 2120 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 2121 if (getLength(getAttributes(this))>0) then 2122 this => item(getAttributes(this), 0) 2123 else 2124 doneAttributes = .true. 2125 endif 2126 elseif (hasChildNodes(this)) then 2127 this => getFirstChild(this) 2128 doneChildren = .false. 2129 doneAttributes = .false. 2130 else 2131 doneChildren = .true. 2132 doneAttributes = .false. 2133 endif 2134 2135 else ! if doneChildren 2136 2137 if (associated(this, treeroot)) exit 2138 if (getNodeType(this)==ATTRIBUTE_NODE) then 2139 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 2140 i_tree= i_tree+ 1 2141 this => item(getAttributes(getOwnerElement(this)), i_tree) 2142 doneChildren = .false. 2143 else 2144 i_tree= 0 2145 this => getOwnerElement(this) 2146 doneAttributes = .true. 2147 doneChildren = .false. 2148 endif 2149 elseif (associated(getNextSibling(this))) then 2150 2151 this => getNextSibling(this) 2152 doneChildren = .false. 2153 doneAttributes = .false. 2154 else 2155 this => getParentNode(this) 2156 endif 2157 endif 2158 2159 enddo 2160 2161 2162 endif 2163 case (DOCUMENT_NODE) 2164 if ((testChild%nodeType/=ELEMENT_NODE .or. & 2165 (testChild%nodeType==ELEMENT_NODE & 2166 .and.associated(testParent%docExtras%documentElement) & 2167 .and.oldChild%nodeType/=ELEMENT_NODE)) & 2168 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2169 .and. testChild%nodeType/=COMMENT_NODE & 2170 .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & 2171 (testChild%nodeType==DOCUMENT_TYPE_NODE & 2172 .and.associated(testParent%docExtras%docType) & 2173 .and.oldChild%nodeType/=DOCUMENT_TYPE_NODE))) then 2174 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2175 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2176 if (present(ex)) then 2177 if (inException(ex)) then 2178 return 2179 endif 2180 endif 2181endif 2182 2183 endif 2184 case (DOCUMENT_FRAGMENT_NODE) 2185 if (testChild%nodeType/=ELEMENT_NODE & 2186 .and. testChild%nodeType/=TEXT_NODE & 2187 .and. testChild%nodeType/=COMMENT_NODE & 2188 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2189 .and. testChild%nodeType/=CDATA_SECTION_NODE & 2190 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2191 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2192 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2193 if (present(ex)) then 2194 if (inException(ex)) then 2195 return 2196 endif 2197 endif 2198endif 2199 2200 endif 2201 case (ENTITY_NODE) 2202 continue ! only allowed by DOM parser, not by user. 2203 ! but entity nodes are always readonly anyway, so no problem 2204 case (ENTITY_REFERENCE_NODE) 2205 continue ! only allowed by DOM parser, not by user. 2206 ! but entity nodes are always readonly anyway, so no problem 2207 case default 2208 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2209 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2210 if (present(ex)) then 2211 if (inException(ex)) then 2212 return 2213 endif 2214 endif 2215endif 2216 2217 end select 2218 2219 ! And then check that newChild is not arg or one of args ancestors 2220 ! (this would never be true if newChild is a documentFragment) 2221 testParent => arg 2222 do while (associated(testParent)) 2223 if (associated(testParent, newChild)) then 2224 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2225 call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) 2226 if (present(ex)) then 2227 if (inException(ex)) then 2228 return 2229 endif 2230 endif 2231endif 2232 2233 endif 2234 testParent => testParent%parentNode 2235 enddo 2236 endif 2237 2238 if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & 2239 .not.(associated(arg%ownerDocument, newChild%ownerDocument) & 2240 .or.associated(arg, newChild%ownerDocument))) then 2241 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 2242 call throw_exception(WRONG_DOCUMENT_ERR, "replaceChild", ex) 2243 if (present(ex)) then 2244 if (inException(ex)) then 2245 return 2246 endif 2247 endif 2248endif 2249 2250 endif 2251 2252 if (associated(getParentNode(newChild))) & 2253 newChild => removeChild(getParentNode(newChild), newChild, ex) 2254 2255 if (arg%childNodes%length==0) then 2256 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 2257 call throw_exception(NOT_FOUND_ERR, "replaceChild", ex) 2258 if (present(ex)) then 2259 if (inException(ex)) then 2260 return 2261 endif 2262 endif 2263endif 2264 2265 elseif (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 2266 allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length-1)) 2267 else 2268 temp_nl => arg%childNodes%nodes 2269 endif 2270 2271 i_t = 0 2272 np => null() 2273 do i = 1, arg%childNodes%length 2274 if (associated(arg%childNodes%nodes(i)%this, oldChild)) then 2275 np => oldChild 2276 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 2277 do i2 = 1, newChild%childNodes%length 2278 i_t = i_t + 1 2279 temp_nl(i_t)%this => newChild%childNodes%nodes(i2)%this 2280 temp_nl(i_t)%this%parentNode => arg 2281! call namespaceFixup(temp_nl(i_t)%this) 2282 enddo 2283 else 2284 i_t = i_t + 1 2285 temp_nl(i_t)%this => newChild 2286 temp_nl(i_t)%this%parentNode => arg 2287! call namespaceFixup(temp_nl(i_t)%this) 2288 endif 2289 if (i==1) then 2290 arg%firstChild => temp_nl(1)%this 2291 !temp_nl(1)%this%previousSibling => null() ! This is a no-op 2292 else 2293 temp_nl(i-1)%this%nextSibling => temp_nl(i)%this 2294 temp_nl(i)%this%previousSibling => temp_nl(i-1)%this 2295 endif 2296 if (i==arg%childNodes%length) then 2297 arg%lastChild => temp_nl(i_t)%this 2298 !temp_nl(i_t)%this%nextSibling => null() ! This is a no-op 2299 else 2300 arg%childNodes%nodes(i+1)%this%previousSibling => temp_nl(i_t)%this 2301 temp_nl(i_t)%this%nextSibling => arg%childNodes%nodes(i+1)%this 2302 endif 2303 else 2304 i_t = i_t + 1 2305 temp_nl(i_t)%this => arg%childNodes%nodes(i)%this 2306 endif 2307 enddo 2308 2309 if (.not.associated(np)) then 2310 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 2311 call throw_exception(NOT_FOUND_ERR, "replaceChild", ex) 2312 if (present(ex)) then 2313 if (inException(ex)) then 2314 return 2315 endif 2316 endif 2317endif 2318 2319 endif 2320 np%parentNode => null() 2321 np%previousSibling => null() 2322 np%nextSibling => null() 2323 2324! call namespaceFixup(np) 2325 2326 if (getGCstate(arg%ownerDocument)) then 2327 if (arg%inDocument) then 2328 call removeNodesFromDocument(arg%ownerDocument, oldChild) 2329 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 2330 do i = 1, newChild%childNodes%length 2331 call putNodesInDocument(arg%ownerDocument, newChild%childNodes%nodes(i)%this) 2332 enddo 2333 else 2334 call putNodesInDocument(arg%ownerDocument, newChild) 2335 endif 2336 ! If newChild was originally in document, it was removed above so must be re-added 2337 ! Ideally we would avoid the cost of removing & re-adding to hangingnodelist 2338 endif 2339 ! If arg was not in the document, then newChildren were either 2340 ! a) removed above in call to removeChild or 2341 ! b) in a document fragment and therefore not part of doc either 2342 endif 2343 2344 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 2345 deallocate(newChild%childNodes%nodes) 2346 allocate(newChild%childNodes%nodes(0)) 2347 newChild%childNodes%length = 0 2348 deallocate(arg%childNodes%nodes) 2349 arg%childNodes%nodes => temp_nl 2350 arg%childNodes%length = size(arg%childNodes%nodes) 2351 endif 2352 2353 call updateNodeLists(arg%ownerDocument) 2354 2355 call updateTextContentLength(arg, newChild%textContentLength-oldChild%textContentLength) 2356 2357 end function replaceChild 2358 2359 2360 function removeChild(arg, oldChild, ex)result(np) 2361 type(DOMException), intent(out), optional :: ex 2362 type(Node), pointer :: arg 2363 type(Node), pointer :: oldChild 2364 type(Node), pointer :: np 2365 2366 type(ListNode), pointer :: temp_nl(:) 2367 integer :: i, i_t 2368 2369 if (.not.associated(arg).or..not.associated(oldChild)) then 2370 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 2371 call throw_exception(FoX_NODE_IS_NULL, "removeChild", ex) 2372 if (present(ex)) then 2373 if (inException(ex)) then 2374 return 2375 endif 2376 endif 2377endif 2378 2379 endif 2380 2381 if (arg%readonly) then 2382 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 2383 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeChild", ex) 2384 if (present(ex)) then 2385 if (inException(ex)) then 2386 return 2387 endif 2388 endif 2389endif 2390 2391 endif 2392 2393 allocate(temp_nl(size(arg%childNodes%nodes)-1)) 2394 i_t = 1 2395 do i = 1, size(arg%childNodes%nodes) 2396 if (associated(arg%childNodes%nodes(i)%this, oldChild)) then 2397 if (associated(arg%firstChild, arg%lastChild)) then 2398 ! There is only one child, we are removing it. 2399 arg%firstChild => null() 2400 arg%lastChild => null() 2401 elseif (i==1) then 2402 ! We are removing the first child, but there is a second 2403 arg%firstChild => arg%childNodes%nodes(2)%this 2404 arg%childNodes%nodes(2)%this%previousSibling => null() 2405 elseif (i==size(arg%childNodes%nodes)) then 2406 ! We are removing the last child, but there is a second-to-last 2407 arg%lastChild => arg%childNodes%nodes(i-1)%this 2408 arg%childNodes%nodes(i-1)%this%nextSibling => null() 2409 else 2410 ! We are removing a child in the middle 2411 arg%childNodes%nodes(i-1)%this%nextSibling => arg%childNodes%nodes(i+1)%this 2412 arg%childNodes%nodes(i+1)%this%previousSibling => arg%childNodes%nodes(i-1)%this 2413 endif 2414 else 2415 if (i_t==size(arg%childNodes%nodes)) exit ! We have failed to find the child 2416 temp_nl(i_t)%this => arg%childNodes%nodes(i)%this 2417 i_t = i_t + 1 2418 endif 2419 enddo 2420 2421 deallocate(arg%childNodes%nodes) 2422 arg%childNodes%nodes => temp_nl 2423 arg%childNodes%length = size(temp_nl) 2424 if (i==i_t) then 2425 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 2426 call throw_exception(NOT_FOUND_ERR, "removeChild", ex) 2427 if (present(ex)) then 2428 if (inException(ex)) then 2429 return 2430 endif 2431 endif 2432endif 2433 2434 endif 2435 oldChild%parentNode => null() 2436 oldChild%previousSibling => null() 2437 oldChild%nextSibling => null() 2438 2439! call namespaceFixup(oldChild) 2440 2441 if (getGCstate(arg%ownerDocument)) then 2442 if (arg%inDocument) then 2443 call removeNodesFromDocument(arg%ownerDocument, oldChild) 2444 endif 2445 endif 2446 2447 np => oldChild 2448 2449 call updateNodeLists(arg%ownerDocument) 2450 2451 call updateTextContentLength(arg, -oldChild%textContentLength) 2452 2453 end function removeChild 2454 2455 2456 function appendChild(arg, newChild, ex)result(np) 2457 type(DOMException), intent(out), optional :: ex 2458 type(Node), pointer :: arg 2459 type(Node), pointer :: newChild 2460 type(Node), pointer :: np 2461 2462 type(Node), pointer :: testChild, testParent, treeroot, this 2463 type(ListNode), pointer :: temp_nl(:) 2464 integer :: i, i_t, i_tree 2465 logical :: doneChildren, doneAttributes 2466 2467 if (.not.associated(arg).or..not.associated(newChild)) then 2468 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 2469 call throw_exception(FoX_NODE_IS_NULL, "appendChild", ex) 2470 if (present(ex)) then 2471 if (inException(ex)) then 2472 return 2473 endif 2474 endif 2475endif 2476 2477 endif 2478 2479 if (arg%readonly) then 2480 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 2481 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "appendChild", ex) 2482 if (present(ex)) then 2483 if (inException(ex)) then 2484 return 2485 endif 2486 endif 2487endif 2488 2489 endif 2490 2491 testParent => arg 2492 ! Check if you are allowed to put a newChild nodetype under a arg nodetype 2493 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 2494 do i = 1, newChild%childNodes%length 2495 testChild => newChild%childNodes%nodes(i)%this 2496 select case(testParent%nodeType) 2497 case (ELEMENT_NODE) 2498 if (testChild%nodeType/=ELEMENT_NODE & 2499 .and. testChild%nodeType/=TEXT_NODE & 2500 .and. testChild%nodeType/=COMMENT_NODE & 2501 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2502 .and. testChild%nodeType/=CDATA_SECTION_NODE & 2503 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2504 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2505 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2506 if (present(ex)) then 2507 if (inException(ex)) then 2508 return 2509 endif 2510 endif 2511endif 2512 2513 endif 2514 case (ATTRIBUTE_NODE) 2515 if (testChild%nodeType/=TEXT_NODE & 2516 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2517 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2518 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2519 if (present(ex)) then 2520 if (inException(ex)) then 2521 return 2522 endif 2523 endif 2524endif 2525 2526 endif 2527 if (testChild%nodeType==ENTITY_REFERENCE_NODE) then 2528 treeroot => testChild 2529 2530 i_tree = 0 2531 doneChildren = .false. 2532 doneAttributes = .false. 2533 this => treeroot 2534 do 2535 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 2536 2537 if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then 2538 if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then 2539 call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "appendChild", ex) 2540 if (present(ex)) then 2541 if (inException(ex)) then 2542 return 2543 endif 2544 endif 2545endif 2546 2547 endif 2548 2549 else 2550 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 2551 doneAttributes = .true. 2552 else 2553 2554 endif 2555 endif 2556 2557 2558 if (.not.doneChildren) then 2559 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 2560 if (getLength(getAttributes(this))>0) then 2561 this => item(getAttributes(this), 0) 2562 else 2563 doneAttributes = .true. 2564 endif 2565 elseif (hasChildNodes(this)) then 2566 this => getFirstChild(this) 2567 doneChildren = .false. 2568 doneAttributes = .false. 2569 else 2570 doneChildren = .true. 2571 doneAttributes = .false. 2572 endif 2573 2574 else ! if doneChildren 2575 2576 if (associated(this, treeroot)) exit 2577 if (getNodeType(this)==ATTRIBUTE_NODE) then 2578 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 2579 i_tree= i_tree+ 1 2580 this => item(getAttributes(getOwnerElement(this)), i_tree) 2581 doneChildren = .false. 2582 else 2583 i_tree= 0 2584 this => getOwnerElement(this) 2585 doneAttributes = .true. 2586 doneChildren = .false. 2587 endif 2588 elseif (associated(getNextSibling(this))) then 2589 2590 this => getNextSibling(this) 2591 doneChildren = .false. 2592 doneAttributes = .false. 2593 else 2594 this => getParentNode(this) 2595 endif 2596 endif 2597 2598 enddo 2599 2600 2601 endif 2602 case (DOCUMENT_NODE) 2603 if ((testChild%nodeType/=ELEMENT_NODE .or. & 2604 (testChild%nodeType==ELEMENT_NODE & 2605 .and.associated(testParent%docExtras%documentElement))) & 2606 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2607 .and. testChild%nodeType/=COMMENT_NODE & 2608 .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & 2609 (testChild%nodeType==DOCUMENT_TYPE_NODE & 2610 .and.associated(testParent%docExtras%docType)))) then 2611 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2612 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2613 if (present(ex)) then 2614 if (inException(ex)) then 2615 return 2616 endif 2617 endif 2618endif 2619 2620 endif 2621 case (DOCUMENT_FRAGMENT_NODE) 2622 if (testChild%nodeType/=ELEMENT_NODE & 2623 .and. testChild%nodeType/=TEXT_NODE & 2624 .and. testChild%nodeType/=COMMENT_NODE & 2625 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2626 .and. testChild%nodeType/=CDATA_SECTION_NODE & 2627 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2628 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2629 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2630 if (present(ex)) then 2631 if (inException(ex)) then 2632 return 2633 endif 2634 endif 2635endif 2636 2637 endif 2638 case (ENTITY_NODE) 2639 continue ! only allowed by DOM parser, not by user. 2640 ! but entity nodes are always readonly anyway, so no problem 2641 case (ENTITY_REFERENCE_NODE) 2642 continue ! only allowed by DOM parser, not by user. 2643 ! but entity nodes are always readonly anyway, so no problem 2644 case default 2645 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2646 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2647 if (present(ex)) then 2648 if (inException(ex)) then 2649 return 2650 endif 2651 endif 2652endif 2653 2654 end select 2655 2656 enddo 2657 else 2658 testChild => newChild 2659 select case(testParent%nodeType) 2660 case (ELEMENT_NODE) 2661 if (testChild%nodeType/=ELEMENT_NODE & 2662 .and. testChild%nodeType/=TEXT_NODE & 2663 .and. testChild%nodeType/=COMMENT_NODE & 2664 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2665 .and. testChild%nodeType/=CDATA_SECTION_NODE & 2666 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2667 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2668 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2669 if (present(ex)) then 2670 if (inException(ex)) then 2671 return 2672 endif 2673 endif 2674endif 2675 2676 endif 2677 case (ATTRIBUTE_NODE) 2678 if (testChild%nodeType/=TEXT_NODE & 2679 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2680 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2681 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2682 if (present(ex)) then 2683 if (inException(ex)) then 2684 return 2685 endif 2686 endif 2687endif 2688 2689 endif 2690 if (testChild%nodeType==ENTITY_REFERENCE_NODE) then 2691 treeroot => testChild 2692 2693 i_tree = 0 2694 doneChildren = .false. 2695 doneAttributes = .false. 2696 this => treeroot 2697 do 2698 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 2699 2700 if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then 2701 if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then 2702 call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "appendChild", ex) 2703 if (present(ex)) then 2704 if (inException(ex)) then 2705 return 2706 endif 2707 endif 2708endif 2709 2710 endif 2711 2712 else 2713 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 2714 doneAttributes = .true. 2715 else 2716 2717 endif 2718 endif 2719 2720 2721 if (.not.doneChildren) then 2722 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 2723 if (getLength(getAttributes(this))>0) then 2724 this => item(getAttributes(this), 0) 2725 else 2726 doneAttributes = .true. 2727 endif 2728 elseif (hasChildNodes(this)) then 2729 this => getFirstChild(this) 2730 doneChildren = .false. 2731 doneAttributes = .false. 2732 else 2733 doneChildren = .true. 2734 doneAttributes = .false. 2735 endif 2736 2737 else ! if doneChildren 2738 2739 if (associated(this, treeroot)) exit 2740 if (getNodeType(this)==ATTRIBUTE_NODE) then 2741 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 2742 i_tree= i_tree+ 1 2743 this => item(getAttributes(getOwnerElement(this)), i_tree) 2744 doneChildren = .false. 2745 else 2746 i_tree= 0 2747 this => getOwnerElement(this) 2748 doneAttributes = .true. 2749 doneChildren = .false. 2750 endif 2751 elseif (associated(getNextSibling(this))) then 2752 2753 this => getNextSibling(this) 2754 doneChildren = .false. 2755 doneAttributes = .false. 2756 else 2757 this => getParentNode(this) 2758 endif 2759 endif 2760 2761 enddo 2762 2763 2764 endif 2765 case (DOCUMENT_NODE) 2766 if ((testChild%nodeType/=ELEMENT_NODE .or. & 2767 (testChild%nodeType==ELEMENT_NODE & 2768 .and.associated(testParent%docExtras%documentElement))) & 2769 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2770 .and. testChild%nodeType/=COMMENT_NODE & 2771 .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & 2772 (testChild%nodeType==DOCUMENT_TYPE_NODE & 2773 .and.associated(testParent%docExtras%docType)))) then 2774 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2775 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2776 if (present(ex)) then 2777 if (inException(ex)) then 2778 return 2779 endif 2780 endif 2781endif 2782 2783 endif 2784 case (DOCUMENT_FRAGMENT_NODE) 2785 if (testChild%nodeType/=ELEMENT_NODE & 2786 .and. testChild%nodeType/=TEXT_NODE & 2787 .and. testChild%nodeType/=COMMENT_NODE & 2788 .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & 2789 .and. testChild%nodeType/=CDATA_SECTION_NODE & 2790 .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then 2791 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2792 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2793 if (present(ex)) then 2794 if (inException(ex)) then 2795 return 2796 endif 2797 endif 2798endif 2799 2800 endif 2801 case (ENTITY_NODE) 2802 continue ! only allowed by DOM parser, not by user. 2803 ! but entity nodes are always readonly anyway, so no problem 2804 case (ENTITY_REFERENCE_NODE) 2805 continue ! only allowed by DOM parser, not by user. 2806 ! but entity nodes are always readonly anyway, so no problem 2807 case default 2808 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2809 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2810 if (present(ex)) then 2811 if (inException(ex)) then 2812 return 2813 endif 2814 endif 2815endif 2816 2817 end select 2818 2819 ! And then check that newChild is not arg or one of args ancestors 2820 ! (this would never be true if newChild is a documentFragment) 2821 testParent => arg 2822 do while (associated(testParent)) 2823 if (associated(testParent, newChild)) then 2824 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 2825 call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) 2826 if (present(ex)) then 2827 if (inException(ex)) then 2828 return 2829 endif 2830 endif 2831endif 2832 2833 endif 2834 testParent => testParent%parentNode 2835 enddo 2836 endif 2837 2838 if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & 2839 .not.(associated(arg%ownerDocument, newChild%ownerDocument) & 2840 .or.associated(arg, newChild%ownerDocument))) then 2841 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 2842 call throw_exception(WRONG_DOCUMENT_ERR, "appendChild", ex) 2843 if (present(ex)) then 2844 if (inException(ex)) then 2845 return 2846 endif 2847 endif 2848endif 2849 2850 endif 2851 2852 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE & 2853 .and. newChild%childNodes%length==0) then 2854 np => newChild 2855 return 2856 ! Nothing to do 2857 endif 2858 2859 if (associated(getParentNode(newChild))) & 2860 newChild => removeChild(getParentNode(newChild), newChild, ex) 2861 2862 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 2863 allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length)) 2864 else 2865 allocate(temp_nl(arg%childNodes%length+1)) 2866 endif 2867 2868 do i = 1, arg%childNodes%length 2869 temp_nl(i)%this => arg%childNodes%nodes(i)%this 2870 enddo 2871 2872 if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then 2873 i_t = arg%childNodes%length 2874 do i = 1, newChild%childNodes%length 2875 i_t = i_t + 1 2876 temp_nl(i_t)%this => newChild%childNodes%nodes(i)%this 2877 if (arg%inDocument) & 2878 call putNodesInDocument(arg%ownerDocument, temp_nl(i_t)%this) 2879 temp_nl(i_t)%this%parentNode => arg 2880! call namespaceFixup(temp_nl(i_t)%this) 2881 enddo 2882 if (arg%childNodes%length==0) then 2883 arg%firstChild => newChild%firstChild 2884 else 2885 newChild%firstChild%previousSibling => arg%lastChild 2886 arg%lastChild%nextSibling => newChild%firstChild 2887 endif 2888 arg%lastChild => newChild%lastChild 2889 newChild%firstChild => null() 2890 newChild%lastChild => null() 2891 deallocate(newChild%childNodes%nodes) 2892 allocate(newChild%childNodes%nodes(0)) 2893 newChild%childNodes%length = 0 2894 else 2895 temp_nl(i)%this => newChild 2896 if (i==1) then 2897 arg%firstChild => newChild 2898 newChild%previousSibling => null() 2899 else 2900 temp_nl(i-1)%this%nextSibling => newChild 2901 newChild%previousSibling => temp_nl(i-1)%this 2902 endif 2903 if (getGCstate(arg%ownerDocument)) then 2904 if (arg%inDocument.and..not.newChild%inDocument) then 2905 call putNodesInDocument(arg%ownerDocument, newChild) 2906 endif 2907 endif 2908 newChild%nextSibling => null() 2909 arg%lastChild => newChild 2910 newChild%parentNode => arg 2911! call namespaceFixup(newChild) 2912 endif 2913 2914 deallocate(arg%childNodes%nodes) 2915 arg%childNodes%nodes => temp_nl 2916 arg%childNodes%length = size(temp_nl) 2917 2918 np => newChild 2919 2920 call updateNodeLists(arg%ownerDocument) 2921 2922 call updateTextContentLength(arg, newChild%textContentLength) 2923 2924 end function appendChild 2925 2926 2927 function hasChildNodes(arg, ex) 2928 type(DOMException), intent(out), optional :: ex 2929 type(Node), pointer :: arg 2930 logical :: hasChildNodes 2931 2932 if (.not.associated(arg)) then 2933 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 2934 call throw_exception(FoX_NODE_IS_NULL, "hasChildNodes", ex) 2935 if (present(ex)) then 2936 if (inException(ex)) then 2937 return 2938 endif 2939 endif 2940endif 2941 2942 endif 2943 2944 hasChildNodes = associated(arg%firstChild) 2945 2946 end function hasChildNodes 2947 2948 recursive function cloneNode(arg, deep, ex)result(np) 2949 type(DOMException), intent(out), optional :: ex 2950 ! Needs to be recursive in case of entity-references within each other. 2951 type(Node), pointer :: arg 2952 logical, intent(in) :: deep 2953 type(Node), pointer :: np 2954 2955 type(Node), pointer :: doc, treeroot, thatParent, this, new, ERchild 2956 2957 logical :: doneAttributes, doneChildren, readonly, brokenNS 2958 integer :: i_tree 2959 2960 if (.not.associated(arg)) then 2961 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 2962 call throw_exception(FoX_NODE_IS_NULL, "cloneNode", ex) 2963 if (present(ex)) then 2964 if (inException(ex)) then 2965 return 2966 endif 2967 endif 2968endif 2969 2970 endif 2971 2972 thatParent => null() 2973 ERchild => null() 2974 doc => getOwnerDocument(arg) 2975 if (.not.associated(doc)) return 2976 np => null() 2977 brokenNS = doc%docExtras%brokenNS 2978 doc%docExtras%brokenNS = .true. ! May need to do stupid NS things 2979 readonly = .false. 2980 2981 treeroot => arg 2982 2983 i_tree = 0 2984 doneChildren = .false. 2985 doneAttributes = .false. 2986 this => treeroot 2987 do 2988 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 2989 2990 2991 new => null() 2992 select case(getNodeType(this)) 2993 case (ELEMENT_NODE) 2994 if (getParameter(getDomConfig(doc), "namespaces")) then 2995 new => createEmptyElementNS(doc, getNamespaceURI(this), getTagName(this)) 2996 else 2997 new => createEmptyElement(doc, getTagName(this)) 2998 endif 2999 case (ATTRIBUTE_NODE) 3000 if (getParameter(getDomConfig(doc), "namespaces")) then 3001 new => createAttributeNS(doc, getNamespaceURI(this), getName(this)) 3002 else 3003 new => createAttribute(doc, getName(this)) 3004 endif 3005 if (associated(this, arg)) then 3006 call setSpecified(new, .true.) 3007 else 3008 call setSpecified(new, getSpecified(this)) 3009 endif 3010 case (TEXT_NODE) 3011 new => createTextNode(doc, getData(this)) 3012 case (CDATA_SECTION_NODE) 3013 new => createCDataSection(doc, getData(this)) 3014 case (ENTITY_REFERENCE_NODE) 3015 ERchild => this 3016 readonly = .true. 3017 new => createEntityReference(doc, getNodeName(this)) 3018 doneChildren = .true. 3019 case (ENTITY_NODE) 3020 return 3021 case (PROCESSING_INSTRUCTION_NODE) 3022 new => createProcessingInstruction(doc, getTarget(this), getData(this)) 3023 case (COMMENT_NODE) 3024 new => createComment(doc, getData(this)) 3025 case (DOCUMENT_NODE) 3026 return 3027 case (DOCUMENT_TYPE_NODE) 3028 return 3029 case (DOCUMENT_FRAGMENT_NODE) 3030 new => createDocumentFragment(doc) 3031 case (NOTATION_NODE) 3032 return 3033 end select 3034 3035 if (.not.associated(thatParent)) then 3036 thatParent => new 3037 elseif (associated(new)) then 3038 if (this%nodeType==ATTRIBUTE_NODE) then 3039 new => setAttributeNode(thatParent, new) 3040 else 3041 new => appendChild(thatParent, new) 3042 endif 3043 endif 3044 3045 if (.not.deep) then 3046 if (getNodeType(arg)==ATTRIBUTE_NODE.or.getNodeType(arg)==ELEMENT_NODE) then 3047 continue 3048 else 3049 exit 3050 endif 3051 endif 3052 3053 else 3054 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 3055 doneAttributes = .true. 3056 else 3057 3058 3059 if (getNodeType(this)==ENTITY_REFERENCE_NODE & 3060 .and.associated(ERchild, this)) then 3061 ERchild => null() 3062 readonly = .false. 3063 endif 3064 this%readonly = readonly 3065 3066 3067 endif 3068 endif 3069 3070 3071 if (.not.doneChildren) then 3072 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 3073 if (getLength(getAttributes(this))>0) then 3074 if (.not.associated(this, treeroot)) thatParent => getLastChild(thatParent) 3075 this => item(getAttributes(this), 0) 3076 else 3077 if (.not.deep) exit 3078 doneAttributes = .true. 3079 endif 3080 elseif (hasChildNodes(this)) then 3081 if (getNodeType(this)==ELEMENT_NODE.and..not.deep) exit 3082 if (.not.associated(this, treeroot)) then 3083 if (getNodeType(this)==ATTRIBUTE_NODE) then 3084 thatParent => item(getAttributes(thatParent), i_tree) 3085 else 3086 thatParent => getLastChild(thatParent) 3087 endif 3088 endif 3089 this => getFirstChild(this) 3090 doneChildren = .false. 3091 doneAttributes = .false. 3092 else 3093 doneChildren = .true. 3094 doneAttributes = .false. 3095 endif 3096 3097 else ! if doneChildren 3098 3099 if (associated(this, treeroot)) exit 3100 if (getNodeType(this)==ATTRIBUTE_NODE) then 3101 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 3102 i_tree= i_tree+ 1 3103 this => item(getAttributes(getOwnerElement(this)), i_tree) 3104 doneChildren = .false. 3105 else 3106 i_tree= 0 3107 if (associated(getParentNode(thatParent))) thatParent => getParentNode(thatParent) 3108 this => getOwnerElement(this) 3109 doneAttributes = .true. 3110 doneChildren = .false. 3111 endif 3112 elseif (associated(getNextSibling(this))) then 3113 3114 this => getNextSibling(this) 3115 doneChildren = .false. 3116 doneAttributes = .false. 3117 else 3118 this => getParentNode(this) 3119 if (.not.associated(this, treeroot)) then 3120 if (getNodeType(this)==ATTRIBUTE_NODE) then 3121 thatParent => getOwnerElement(thatParent) 3122 else 3123 thatParent => getParentNode(thatParent) 3124 endif 3125 endif 3126 endif 3127 endif 3128 3129 enddo 3130 3131 3132 3133 np => thatParent 3134 doc%docExtras%brokenNS = brokenNS 3135 3136 end function cloneNode 3137 3138 3139 function hasAttributes(arg, ex) 3140 type(DOMException), intent(out), optional :: ex 3141 type(Node), pointer :: arg 3142 logical :: hasAttributes 3143 3144 if (.not.associated(arg)) then 3145 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3146 call throw_exception(FoX_NODE_IS_NULL, "hasAttributes", ex) 3147 if (present(ex)) then 3148 if (inException(ex)) then 3149 return 3150 endif 3151 endif 3152endif 3153 3154 endif 3155 3156 if (arg%nodeType == ELEMENT_NODE) then 3157 hasAttributes = (getLength(getAttributes(arg)) > 0) 3158 else 3159 hasAttributes = .false. 3160 endif 3161 3162 end function hasAttributes 3163 3164! function getBaseURI FIXME 3165 3166! function compareDocumentPosition FIXME 3167 3168 subroutine normalize(arg, ex) 3169 type(DOMException), intent(out), optional :: ex 3170 type(Node), pointer :: arg 3171 type(Node), pointer :: this, tempNode, oldNode, treeroot 3172 integer :: i_tree, i_t 3173 logical :: doneChildren, doneAttributes 3174 character, pointer :: temp(:) 3175 3176 if (.not.associated(arg)) then 3177 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3178 call throw_exception(FoX_NODE_IS_NULL, "normalize", ex) 3179 if (present(ex)) then 3180 if (inException(ex)) then 3181 return 3182 endif 3183 endif 3184endif 3185 3186 endif 3187 3188! DOM standard requires we ignore readonly status 3189 treeroot => arg 3190 3191 i_tree = 0 3192 doneChildren = .false. 3193 doneAttributes = .false. 3194 this => treeroot 3195 do 3196 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 3197 3198 3199 if (getNodeType(this)==TEXT_NODE) then 3200 if (associated(this, arg)) exit ! If we are called on a text node itself, then do nothing. 3201 i_t = getLength(this) 3202 tempNode => getNextSibling(this) 3203 do while (associated(tempNode)) 3204 if (getNodeType(tempNode)/=TEXT_NODE) exit 3205 i_t = i_t + getLength(tempNode) 3206 tempNode => getNextSibling(tempNode) 3207 enddo 3208 if (.not.associated(tempNode, getNextSibling(this))) then 3209 allocate(temp(i_t)) 3210 temp(:getLength(this)) = vs_str(getData(this)) 3211 i_t = getLength(this) 3212 tempNode => getNextSibling(this) 3213 do while (associated(tempNode)) 3214 if (getNodeType(tempNode)/=TEXT_NODE) exit 3215 temp(i_t+1:i_t+getLength(tempNode)) = vs_str(getData(tempNode)) 3216 i_t = i_t + getLength(tempNode) 3217 oldNode => tempNode 3218 tempNode => getNextSibling(tempNode) 3219 oldNode => removeChild(getParentNode(oldNode), oldNode) 3220 call remove_node_nl(arg%ownerDocument%docExtras%hangingNodes, oldNode) 3221 call destroy(oldNode) 3222 enddo 3223 deallocate(this%nodeValue) 3224 this%nodeValue => temp 3225 endif 3226 end if 3227 3228 else 3229 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 3230 doneAttributes = .true. 3231 else 3232 3233 endif 3234 endif 3235 3236 3237 if (.not.doneChildren) then 3238 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 3239 if (getLength(getAttributes(this))>0) then 3240 this => item(getAttributes(this), 0) 3241 else 3242 doneAttributes = .true. 3243 endif 3244 elseif (hasChildNodes(this)) then 3245 this => getFirstChild(this) 3246 doneChildren = .false. 3247 doneAttributes = .false. 3248 else 3249 doneChildren = .true. 3250 doneAttributes = .false. 3251 endif 3252 3253 else ! if doneChildren 3254 3255 if (associated(this, treeroot)) exit 3256 if (getNodeType(this)==ATTRIBUTE_NODE) then 3257 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 3258 i_tree= i_tree+ 1 3259 this => item(getAttributes(getOwnerElement(this)), i_tree) 3260 doneChildren = .false. 3261 else 3262 i_tree= 0 3263 this => getOwnerElement(this) 3264 doneAttributes = .true. 3265 doneChildren = .false. 3266 endif 3267 elseif (associated(getNextSibling(this))) then 3268 3269 this => getNextSibling(this) 3270 doneChildren = .false. 3271 doneAttributes = .false. 3272 else 3273 this => getParentNode(this) 3274 endif 3275 endif 3276 3277 enddo 3278 3279 3280 3281 3282 end subroutine normalize 3283 3284 function isSupported(arg, feature, version, ex)result(p) 3285 type(DOMException), intent(out), optional :: ex 3286 type(Node), pointer :: arg 3287 character(len=*), intent(in) :: feature 3288 character(len=*), intent(in) :: version 3289 logical :: p 3290 3291 if (.not.associated(arg)) then 3292 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3293 call throw_exception(FoX_NODE_IS_NULL, "isSupported", ex) 3294 if (present(ex)) then 3295 if (inException(ex)) then 3296 return 3297 endif 3298 endif 3299endif 3300 3301 endif 3302 3303 p = hasFeature(getImplementation(arg%ownerDocument), feature, version) 3304 end function isSupported 3305 3306 pure function getNamespaceURI_len(arg, p) result(n) 3307 type(Node), intent(in) :: arg 3308 logical, intent(in) :: p 3309 integer :: n 3310 3311 n = 0 3312 if (p) then 3313 if (arg%nodeType==ELEMENT_NODE & 3314 .or. arg%nodeType==ATTRIBUTE_NODE & 3315 .or. arg%nodeType==XPATH_NAMESPACE_NODE) then 3316 n = size(arg%elExtras%namespaceURI) 3317 endif 3318 endif 3319 3320 end function getNamespaceURI_len 3321 3322 function getNamespaceURI(arg, ex)result(c) 3323 type(DOMException), intent(out), optional :: ex 3324 type(Node), pointer :: arg 3325#ifdef RESTRICTED_ASSOCIATED_BUG 3326 character(len=getNamespaceURI_len(arg, .true.)) :: c 3327#else 3328 character(len=getNamespaceURI_len(arg, associated(arg))) :: c 3329#endif 3330 3331 if (.not.associated(arg)) then 3332 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3333 call throw_exception(FoX_NODE_IS_NULL, "getNamespaceURI", ex) 3334 if (present(ex)) then 3335 if (inException(ex)) then 3336 return 3337 endif 3338 endif 3339endif 3340 3341 endif 3342 3343 c = "" 3344 if (arg%nodeType==ELEMENT_NODE & 3345 .or. arg%nodeType==ATTRIBUTE_NODE & 3346 .or. arg%nodeType==XPATH_NAMESPACE_NODE) then 3347 c = str_vs(arg%elExtras%namespaceURI) 3348 endif 3349 end function getNamespaceURI 3350 3351subroutine setnamespaceURI(np, c, ex) 3352 type(DOMException), intent(out), optional :: ex 3353 type(Node), pointer :: np 3354 character(len=*) :: c 3355 3356 3357 if (.not.associated(np)) then 3358 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3359 call throw_exception(FoX_NODE_IS_NULL, "setnamespaceURI", ex) 3360 if (present(ex)) then 3361 if (inException(ex)) then 3362 return 3363 endif 3364 endif 3365endif 3366 3367 endif 3368 3369 if (getNodeType(np)/=XPATH_NAMESPACE_NODE .and. & 3370 .true.) then 3371 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 3372 call throw_exception(FoX_INVALID_NODE, "setnamespaceURI", ex) 3373 if (present(ex)) then 3374 if (inException(ex)) then 3375 return 3376 endif 3377 endif 3378endif 3379 3380 endif 3381 3382 if (associated(np%elExtras%namespaceURI)) deallocate(np%elExtras%namespaceURI) 3383 np%elExtras%namespaceURI => vs_str_alloc(c) 3384 3385 end subroutine setnamespaceURI 3386 3387 3388 pure function getPrefix_len(arg, p) result(n) 3389 type(Node), intent(in) :: arg 3390 logical, intent(in) :: p 3391 integer :: n 3392 3393 n = 0 3394 if (p) then 3395 if (arg%nodeType==ELEMENT_NODE & 3396 .or. arg%nodeType==ATTRIBUTE_NODE & 3397 .or. arg%nodeType==XPATH_NAMESPACE_NODE) then 3398 n = size(arg%elExtras%prefix) 3399 endif 3400 endif 3401 3402 end function getPrefix_len 3403 3404 function getPrefix(arg, ex)result(c) 3405 type(DOMException), intent(out), optional :: ex 3406 type(Node), pointer :: arg 3407#ifdef RESTRICTED_ASSOCIATED_BUG 3408 character(len=getPrefix_len(arg, .true.)) :: c 3409#else 3410 character(len=getPrefix_len(arg, associated(arg))) :: c 3411#endif 3412 3413 if (.not.associated(arg)) then 3414 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3415 call throw_exception(FoX_NODE_IS_NULL, "getPrefix", ex) 3416 if (present(ex)) then 3417 if (inException(ex)) then 3418 return 3419 endif 3420 endif 3421endif 3422 3423 endif 3424 3425 c = "" 3426 if (arg%nodeType==ELEMENT_NODE & 3427 .or. arg%nodeType==ATTRIBUTE_NODE & 3428 .or. arg%nodeType==XPATH_NAMESPACE_NODE) then 3429 c = str_vs(arg%elExtras%prefix) 3430 endif 3431 3432 end function getPrefix 3433 3434 subroutine setPrefix(arg, prefix, ex) 3435 type(DOMException), intent(out), optional :: ex 3436 type(Node), pointer :: arg 3437 character(len=*) :: prefix 3438 3439 character, pointer :: tmp(:) 3440 integer :: i 3441 3442 if (.not.associated(arg)) then 3443 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3444 call throw_exception(FoX_NODE_IS_NULL, "setPrefix", ex) 3445 if (present(ex)) then 3446 if (inException(ex)) then 3447 return 3448 endif 3449 endif 3450endif 3451 3452 endif 3453 3454 if (arg%nodeType==ELEMENT_NODE & 3455 .or. arg%nodeType==ATTRIBUTE_NODE & 3456 .or. arg%nodeType==XPATH_NAMESPACE_NODE) then 3457 if (arg%readonly) then 3458 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 3459 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setPrefix", ex) 3460 if (present(ex)) then 3461 if (inException(ex)) then 3462 return 3463 endif 3464 endif 3465endif 3466 3467 elseif (.not.checkName(prefix, getXmlVersionEnum(getOwnerDocument(arg)))) then 3468 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 3469 call throw_exception(INVALID_CHARACTER_ERR, "setPrefix", ex) 3470 if (present(ex)) then 3471 if (inException(ex)) then 3472 return 3473 endif 3474 endif 3475endif 3476 3477 elseif (.not.checkNCName(prefix, getXmlVersionEnum(getOwnerDocument(arg)))) then 3478 if (getFoX_checks().or.NAMESPACE_ERR<200) then 3479 call throw_exception(NAMESPACE_ERR, "setPrefix", ex) 3480 if (present(ex)) then 3481 if (inException(ex)) then 3482 return 3483 endif 3484 endif 3485endif 3486 3487 elseif (size(arg%elExtras%namespaceURI)==0) then 3488 if (getFoX_checks().or.NAMESPACE_ERR<200) then 3489 call throw_exception(NAMESPACE_ERR, "setPrefix", ex) 3490 if (present(ex)) then 3491 if (inException(ex)) then 3492 return 3493 endif 3494 endif 3495endif 3496 3497 elseif (prefix=="xml" .and. & 3498 str_vs(arg%elExtras%namespaceURI)/="http://www.w3.org/XML/1998/namespace") then 3499 if (getFoX_checks().or.NAMESPACE_ERR<200) then 3500 call throw_exception(NAMESPACE_ERR, "setPrefix", ex) 3501 if (present(ex)) then 3502 if (inException(ex)) then 3503 return 3504 endif 3505 endif 3506endif 3507 3508 elseif (prefix=="xmlns" .and. (getNodeType(arg)/=ATTRIBUTE_NODE & 3509 .or. str_vs(arg%elExtras%namespaceURI)/="http://www.w3.org/2000/xmlns/")) then 3510 if (getFoX_checks().or.NAMESPACE_ERR<200) then 3511 call throw_exception(NAMESPACE_ERR, "setPrefix", ex) 3512 if (present(ex)) then 3513 if (inException(ex)) then 3514 return 3515 endif 3516 endif 3517endif 3518 3519 elseif (getNodeType(arg)==ATTRIBUTE_NODE.and.getName(arg)=="xmlns") then 3520 if (getFoX_checks().or.NAMESPACE_ERR<200) then 3521 call throw_exception(NAMESPACE_ERR, "setPrefix", ex) 3522 if (present(ex)) then 3523 if (inException(ex)) then 3524 return 3525 endif 3526 endif 3527endif 3528 3529 endif 3530! FIXME check if prefix is declared and already points to same namespace 3531! but only if we ever get full error-checking up and running. 3532 deallocate(arg%elExtras%prefix) 3533 arg%elExtras%prefix => vs_str_alloc(prefix) 3534 tmp => arg%nodeName 3535 i = index(str_vs(arg%nodeName), ":") 3536 if (i==0) then 3537 arg%nodeName => vs_str_alloc(prefix//":"//str_vs(tmp)) 3538 else 3539 arg%nodeName => vs_str_alloc(prefix//str_vs(tmp(i:))) 3540 endif 3541 deallocate(tmp) 3542 endif 3543 3544 call updateNodeLists(arg%ownerDocument) 3545 3546 end subroutine setPrefix 3547 3548 pure function getLocalName_len(arg, p) result(n) 3549 type(Node), intent(in) :: arg 3550 logical, intent(in) :: p 3551 integer :: n 3552 3553 n = 0 3554 if (p) then 3555 if (arg%nodeType==ELEMENT_NODE & 3556 .or. arg%nodeType==ATTRIBUTE_NODE & 3557 .or. arg%nodeType==XPATH_NAMESPACE_NODE) then 3558 n = size(arg%elExtras%localName) 3559 endif 3560 endif 3561 3562 end function getLocalName_len 3563 3564 function getLocalName(arg, ex)result(c) 3565 type(DOMException), intent(out), optional :: ex 3566 type(Node), pointer :: arg 3567#ifdef RESTRICTED_ASSOCIATED_BUG 3568 character(len=getLocalName_len(arg, .true.)) :: c 3569#else 3570 character(len=getLocalName_len(arg, associated(arg))) :: c 3571#endif 3572 3573 if (.not.associated(arg)) then 3574 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3575 call throw_exception(FoX_NODE_IS_NULL, "getLocalName", ex) 3576 if (present(ex)) then 3577 if (inException(ex)) then 3578 return 3579 endif 3580 endif 3581endif 3582 3583 endif 3584 3585 c = "" 3586 if (arg%nodeType==ELEMENT_NODE & 3587 .or. arg%nodeType==ATTRIBUTE_NODE & 3588 .or. arg%nodeType==XPATH_NAMESPACE_NODE) then 3589 c = str_vs(arg%elExtras%localName) 3590 endif 3591 3592 end function getLocalName 3593 3594 recursive function isEqualNode(arg, other, ex)result(p) 3595 type(DOMException), intent(out), optional :: ex 3596 ! We only have one level of recursion, in case of element attributes 3597 type(Node), pointer :: arg 3598 type(Node), pointer :: other 3599 logical :: p 3600 3601 type(Node), pointer :: this, that, treeroot, treeroot2, att1, att2 3602 type(NodeList), pointer :: children1, children2 3603 type(NamedNodeMap), pointer :: atts1, atts2 3604 3605 integer :: i_tree, i 3606 logical :: doneChildren, doneAttributes, equal 3607 3608 if (.not.associated(arg)) then 3609 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3610 call throw_exception(FoX_NODE_IS_NULL, "isEqualNode", ex) 3611 if (present(ex)) then 3612 if (inException(ex)) then 3613 return 3614 endif 3615 endif 3616endif 3617 3618 endif 3619 3620 if (isSameNode(arg, other)) then 3621 ! Shortcut the treewalking 3622 p = .true. 3623 return 3624 else 3625 p = .false. 3626 endif 3627 3628 treeroot => arg 3629 treeroot2 => other 3630 3631 i_tree = 0 3632 doneChildren = .false. 3633 doneAttributes = .false. 3634 this => treeroot 3635 that => treeroot2 3636 equal = .false. 3637 do 3638 if (getNodeType(this)/=getNodeType(that)) exit 3639 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 3640 3641 3642 if (getNodeType(this)/=getNodeType(that)) return 3643 ! Check necessary equal attributes ... 3644 if (getNodeName(this)/=getNodeName(that) & 3645 .or. getLocalName(this)/=getLocalName(that) & 3646 .or. getNamespaceURI(this)/=getNamespaceURI(that) & 3647 .or. getPrefix(this)/=getPrefix(that) & 3648 .or. getNodeValue(this)/=getNodeValue(that)) & 3649 return 3650 children1 => getChildNodes(this) 3651 children2 => getChildNodes(that) 3652 if (getLength(children1)/=getLength(children2)) return 3653 ! Well get to the contents of the children later on anyway. 3654 if (getNodeType(this)==ELEMENT_NODE) then 3655 ! We must treat attributes specially here (rather than relying on 3656 ! treewalk) since the order can legitimately change. 3657 atts1 => getAttributes(this) 3658 atts2 => getAttributes(that) 3659 if (getLength(atts1)/=getLength(atts2)) return 3660 do i = 0, getLength(atts1)-1 3661 att1 => item(atts1, i) 3662 if (getNamespaceURI(att1)=="") then 3663 att2 => getNamedItem(atts2, getNodeName(att1)) 3664 else 3665 att2 => getNamedItemNS(atts2, getLocalName(att1), getNamespaceURI(att1)) 3666 endif 3667 if (.not.associated(att2)) return 3668 if (.not.isEqualNode(att1, att2)) return 3669 enddo 3670 doneAttributes = .true. 3671 elseif (getNodeType(this)==DOCUMENT_TYPE_NODE) then 3672 if (getPublicId(this)/=getPublicId(that) & 3673 .or. getSystemId(this)/=getSystemId(that) & 3674 .or. getInternalSubset(this)/=getInternalSubset(that)) return 3675 atts1 => getEntities(this) 3676 atts2 => getEntities(that) 3677 if (getLength(atts1)/=getLength(atts2)) return 3678 do i = 0, getLength(atts1)-1 3679 att1 => item(atts1, i) 3680 att2 => getNamedItem(atts2, getNodeName(att1)) 3681 if (.not.associated(att2)) return 3682 if (.not.isEqualNode(att1, att2)) return 3683 enddo 3684 atts1 => getNotations(this) 3685 atts2 => getNotations(that) 3686 if (getLength(atts1)/=getLength(atts2)) return 3687 do i = 0, getLength(atts1)-1 3688 att1 => item(atts1, i) 3689 att2 => getNamedItem(atts2, getNodeName(att1)) 3690 if (.not.associated(att2)) return 3691 if (.not.isEqualNode(att1, att2)) return 3692 enddo 3693 endif 3694 3695 else 3696 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 3697 doneAttributes = .true. 3698 else 3699 3700 endif 3701 endif 3702 3703 3704 if (.not.doneChildren) then 3705 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 3706 if (getLength(getAttributes(this))/=getLength(getAttributes(that))) exit 3707 if (getLength(getAttributes(this))>0) then 3708 this => item(getAttributes(this), 0) 3709 that => item(getAttributes(that), 0) 3710 else 3711 doneAttributes = .true. 3712 endif 3713 elseif (hasChildNodes(this).or.hasChildNodes(that)) then 3714 if (getLength(getChildNodes(this))/=getLength(getChildNodes(that))) exit 3715 this => getFirstChild(this) 3716 that => getFirstChild(that) 3717 doneChildren = .false. 3718 doneAttributes = .false. 3719 else 3720 doneChildren = .true. 3721 doneAttributes = .false. 3722 endif 3723 3724 else ! if doneChildren 3725 3726 if (associated(this, treeroot)) exit 3727 if (getNodeType(this)==ATTRIBUTE_NODE) then 3728 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 3729 i_tree= i_tree+ 1 3730 this => item(getAttributes(getOwnerElement(this)), i_tree) 3731 that => item(getAttributes(getOwnerElement(that)), i_tree) 3732 doneChildren = .false. 3733 else 3734 i_tree= 0 3735 this => getOwnerElement(this) 3736 that => getOwnerElement(that) 3737 doneAttributes = .true. 3738 doneChildren = .false. 3739 endif 3740 elseif (associated(getNextSibling(this))) then 3741 3742 this => getNextSibling(this) 3743 that => getNextSibling(that) 3744 doneChildren = .false. 3745 doneAttributes = .false. 3746 else 3747 this => getParentNode(this) 3748 that => getParentNode(that) 3749 endif 3750 endif 3751 3752 enddo 3753 3754 3755 3756 p = .true. 3757 3758 end function isEqualNode 3759 3760 3761 function isSameNode(arg, other, ex) 3762 type(DOMException), intent(out), optional :: ex 3763 type(Node), pointer :: arg 3764 type(Node), pointer :: other 3765 logical :: isSameNode 3766 3767 if (.not.associated(arg).or..not.associated(other)) then 3768 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3769 call throw_exception(FoX_NODE_IS_NULL, "isSameNode", ex) 3770 if (present(ex)) then 3771 if (inException(ex)) then 3772 return 3773 endif 3774 endif 3775endif 3776 3777 endif 3778 3779 isSameNode = associated(arg, other) 3780 3781 end function isSameNode 3782 3783 !FIXME all the lookup* functions below are out of spec, 3784 ! since they rely on a statically-calculated set of NSnodes 3785 ! which is only generated at parse time, and updated after 3786 ! normalize. 3787 ! the spec reckons it should be dynamic, but because we need 3788 ! to know string lengths, which must be calculated inside 3789 ! a pure function, we cant do the recursive walk we need to. 3790 ! (although isDefaultNamespace could be fixed easily enough) 3791 3792 function isDefaultNamespace(np, namespaceURI, ex)result(p) 3793 type(DOMException), intent(out), optional :: ex 3794 type(Node), pointer :: np 3795 character(len=*), intent(in) :: namespaceURI 3796 logical :: p 3797 3798 type(Node), pointer :: el 3799 integer :: i 3800 3801 if (.not.associated(np)) then 3802 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3803 call throw_exception(FoX_NODE_IS_NULL, "isDefaultNamespace", ex) 3804 if (present(ex)) then 3805 if (inException(ex)) then 3806 return 3807 endif 3808 endif 3809endif 3810 3811 endif 3812 3813 el => null() 3814 select case(getNodeType(np)) 3815 case (ELEMENT_NODE) 3816 el => np 3817 case (ATTRIBUTE_NODE) 3818 el => getOwnerElement(np) 3819 case (DOCUMENT_NODE) 3820 el => getDocumentElement(np) 3821 end select 3822 3823 p = .false. 3824 if (associated(el)) then 3825 do i = 1, el%elExtras%namespaceNodes%length 3826 if (size(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==0) then 3827 p = (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) 3828 return 3829 endif 3830 enddo 3831 endif 3832 end function isDefaultNamespace 3833 3834 pure function lookupNamespaceURI_len(np, prefix, p) result(n) 3835 type(Node), intent(in) :: np 3836 character(len=*), intent(in) :: prefix 3837 logical, intent(in) :: p 3838 integer :: n 3839 3840 integer :: i 3841 3842 n = 0 3843 if (.not.p) return 3844 if (np%nodeType/=ELEMENT_NODE & 3845 .and. np%nodeType/=ATTRIBUTE_NODE & 3846 .and. np%nodeType/=DOCUMENT_NODE) return 3847 3848 if (prefix=="xml".or.prefix=="xmlns") then 3849 n = 0 3850 return 3851 endif 3852 3853 select case(np%nodeType) 3854 case (ELEMENT_NODE) 3855 do i = 1, np%elExtras%namespaceNodes%length 3856 if (str_vs(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then 3857 n = size(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) 3858 return 3859 endif 3860 enddo 3861 case (ATTRIBUTE_NODE) 3862 if (associated(np%elExtras%ownerElement)) then 3863 do i = 1, np%elExtras%ownerElement%elExtras%namespaceNodes%length 3864 if (str_vs(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then 3865 n = size(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) 3866 return 3867 endif 3868 enddo 3869 endif 3870 case (DOCUMENT_NODE) 3871 if (associated(np%docExtras%documentElement)) then 3872 do i = 1, np%docExtras%documentElement%elExtras%namespaceNodes%length 3873 if (str_vs(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then 3874 n = size(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) 3875 return 3876 endif 3877 enddo 3878 endif 3879 end select 3880 3881 end function lookupNamespaceURI_len 3882 3883 function lookupNamespaceURI(np, prefix, ex)result(c) 3884 type(DOMException), intent(out), optional :: ex 3885 type(Node), pointer :: np 3886 character(len=*), intent(in) :: prefix 3887#ifdef RESTRICTED_ASSOCIATED_BUG 3888 character(len=lookupNamespaceURI_len(np, prefix, .true.)) :: c 3889#else 3890 character(len=lookupNamespaceURI_len(np, prefix, associated(np))) :: c 3891#endif 3892 3893 type(Node), pointer :: el 3894 integer :: i 3895 3896 if (.not.associated(np)) then 3897 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3898 call throw_exception(FoX_NODE_IS_NULL, "lookupNamespaceURI", ex) 3899 if (present(ex)) then 3900 if (inException(ex)) then 3901 return 3902 endif 3903 endif 3904endif 3905 3906 endif 3907 3908 if (len(c)==0) then 3909 c = "" 3910 return 3911 endif 3912 3913 el => null() 3914 select case(getNodeType(np)) 3915 case (ELEMENT_NODE) 3916 el => np 3917 case (ATTRIBUTE_NODE) 3918 el => getOwnerElement(np) 3919 case (DOCUMENT_NODE) 3920 el => getDocumentElement(np) 3921 end select 3922 3923 if (associated(el)) then 3924 do i = 1, el%elExtras%namespaceNodes%length 3925 if (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then 3926 c = str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) 3927 return 3928 endif 3929 enddo 3930 endif 3931 3932 end function lookupNamespaceURI 3933 3934 pure function lookupPrefix_len(np, namespaceURI, p) result(n) 3935 type(Node), intent(in) :: np 3936 character(len=*), intent(in) :: namespaceURI 3937 logical, intent(in) :: p 3938 integer :: n 3939 3940 integer :: i 3941 3942 n = 0 3943 if (.not.p) return 3944 if (np%nodeType/=ELEMENT_NODE & 3945 .and. np%nodeType/=ATTRIBUTE_NODE & 3946 .and. np%nodeType/=DOCUMENT_NODE) return 3947 3948 if (namespaceURI=="" & 3949 .or. namespaceURI=="http://www.w3.org/XML/1998/namespace" & 3950 .or. namespaceURI=="http://www.w3.org/2000/xmlns/") then 3951 return 3952 endif 3953 3954 select case(np%nodeType) 3955 case (ELEMENT_NODE) 3956 do i = 1, np%elExtras%namespaceNodes%length 3957 if (str_vs(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then 3958 n = size(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) 3959 return 3960 endif 3961 enddo 3962 case (ATTRIBUTE_NODE) 3963 if (associated(np%elExtras%ownerElement)) then 3964 do i = 1, np%elExtras%ownerElement%elExtras%namespaceNodes%length 3965 if (str_vs(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then 3966 n = size(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) 3967 return 3968 endif 3969 enddo 3970 endif 3971 case (DOCUMENT_NODE) 3972 if (associated(np%docExtras%documentElement)) then 3973 do i = 1, np%docExtras%documentElement%elExtras%namespaceNodes%length 3974 if (str_vs(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then 3975 n = size(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) 3976 return 3977 endif 3978 enddo 3979 endif 3980 end select 3981 3982 end function lookupPrefix_len 3983 3984 function lookupPrefix(np, namespaceURI, ex)result(c) 3985 type(DOMException), intent(out), optional :: ex 3986 type(Node), pointer :: np 3987 character(len=*), intent(in) :: namespaceURI 3988#ifdef RESTRICTED_ASSOCIATED_BUG 3989 character(len=lookupPrefix_len(np, namespaceURI, .true.)) :: c 3990#else 3991 character(len=lookupPrefix_len(np, namespaceURI, associated(np))) :: c 3992#endif 3993 3994 type(Node), pointer :: el 3995 integer :: i 3996 3997 if (.not.associated(np)) then 3998 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 3999 call throw_exception(FoX_NODE_IS_NULL, "lookupPrefix", ex) 4000 if (present(ex)) then 4001 if (inException(ex)) then 4002 return 4003 endif 4004 endif 4005endif 4006 4007 endif 4008 4009 if (len(c)==0) then 4010 c = "" 4011 return 4012 endif 4013 4014 el => null() 4015 select case(getNodeType(np)) 4016 case (ELEMENT_NODE) 4017 el => np 4018 case (ATTRIBUTE_NODE) 4019 el => getOwnerElement(np) 4020 case (DOCUMENT_NODE) 4021 el => getDocumentElement(np) 4022 end select 4023 4024 if (associated(el)) then 4025 do i = 1, el%elExtras%namespaceNodes%length 4026 if (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then 4027 c = str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) 4028 return 4029 endif 4030 enddo 4031 endif 4032 end function lookupPrefix 4033 4034 ! function getUserData 4035 ! function setUserData 4036 ! will not implement ... 4037 4038 subroutine updateTextContentLength(np, n) 4039 type(Node), pointer :: np 4040 integer, intent(in) :: n 4041 4042 type(Node), pointer :: this 4043 4044 if (n/=0) then 4045 this => np 4046 do while (associated(this)) 4047 this%textContentLength = this%textContentLength + n 4048 this => getParentNode(this) 4049 if (associated(this)) then 4050 if (getNodeType(this)==DOCUMENT_NODE) exit 4051 endif 4052 enddo 4053 endif 4054 end subroutine updateTextContentLength 4055 4056 pure function getTextContent_len(arg, p) result(n) 4057 type(Node), intent(in) :: arg 4058 logical, intent(in) :: p 4059 integer :: n 4060 4061 if (p) then 4062 n = arg%textContentLength 4063 else 4064 n = 0 4065 endif 4066 end function getTextContent_len 4067 4068 function getTextContent(arg, ex)result(c) 4069 type(DOMException), intent(out), optional :: ex 4070 type(Node), pointer :: arg 4071#ifdef RESTRICTED_ASSOCIATED_BUG 4072 character(len=getTextContent_len(arg, .true.)) :: c 4073#else 4074 character(len=getTextContent_len(arg, associated(arg))) :: c 4075#endif 4076 4077 type(Node), pointer :: this, treeroot 4078 integer :: i, i_tree 4079 logical :: doneChildren, doneAttributes 4080 4081 if (.not.associated(arg)) then 4082 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 4083 call throw_exception(FoX_NODE_IS_NULL, "getTextContent", ex) 4084 if (present(ex)) then 4085 if (inException(ex)) then 4086 return 4087 endif 4088 endif 4089endif 4090 4091 endif 4092 4093 if (len(c) == 0) then 4094 c = "" 4095 return 4096 endif 4097 4098 i = 1 4099 treeroot => arg 4100 4101 i_tree = 0 4102 doneChildren = .false. 4103 doneAttributes = .false. 4104 this => treeroot 4105 do 4106 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 4107 4108 if (associated(this, treeroot).and.isCharData(getNodeType(this))) then 4109 c = getData(this) 4110 return 4111 endif 4112 select case(getNodeType(this)) 4113 case (ELEMENT_NODE) 4114 doneAttributes = .true. 4115 ! Ignore attributes for text content (unless this is an attribute!) 4116 case(TEXT_NODE, CDATA_SECTION_NODE) 4117 if (.not.getIsElementContentWhitespace(this)) then 4118 c(i:i+size(this%nodeValue)-1) = str_vs(this%nodeValue) 4119 i = i + size(this%nodeValue) 4120 endif 4121 end select 4122 4123 else 4124 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 4125 doneAttributes = .true. 4126 else 4127 4128 endif 4129 endif 4130 4131 4132 if (.not.doneChildren) then 4133 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 4134 if (getLength(getAttributes(this))>0) then 4135 this => item(getAttributes(this), 0) 4136 else 4137 doneAttributes = .true. 4138 endif 4139 elseif (hasChildNodes(this)) then 4140 this => getFirstChild(this) 4141 doneChildren = .false. 4142 doneAttributes = .false. 4143 else 4144 doneChildren = .true. 4145 doneAttributes = .false. 4146 endif 4147 4148 else ! if doneChildren 4149 4150 if (associated(this, treeroot)) exit 4151 if (getNodeType(this)==ATTRIBUTE_NODE) then 4152 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 4153 i_tree= i_tree+ 1 4154 this => item(getAttributes(getOwnerElement(this)), i_tree) 4155 doneChildren = .false. 4156 else 4157 i_tree= 0 4158 this => getOwnerElement(this) 4159 doneAttributes = .true. 4160 doneChildren = .false. 4161 endif 4162 elseif (associated(getNextSibling(this))) then 4163 4164 this => getNextSibling(this) 4165 doneChildren = .false. 4166 doneAttributes = .false. 4167 else 4168 this => getParentNode(this) 4169 endif 4170 endif 4171 4172 enddo 4173 4174 4175 end function getTextContent 4176 4177 subroutine setTextContent(arg, textContent, ex) 4178 type(DOMException), intent(out), optional :: ex 4179 type(Node), pointer :: arg 4180 character(len=*), intent(in) :: textContent 4181 4182 type(Node), pointer :: np 4183 integer :: i 4184 4185 if (.not.associated(arg)) then 4186 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 4187 call throw_exception(FoX_NODE_IS_NULL, "setTextContent", ex) 4188 if (present(ex)) then 4189 if (inException(ex)) then 4190 return 4191 endif 4192 endif 4193endif 4194 4195 endif 4196 4197 if (.not.checkChars(textContent, getXmlVersionEnum(getOwnerDocument(arg)))) then 4198 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 4199 call throw_exception(FoX_INVALID_CHARACTER, "setTextContent", ex) 4200 if (present(ex)) then 4201 if (inException(ex)) then 4202 return 4203 endif 4204 endif 4205endif 4206 4207 endif 4208 4209 select case(getNodeType(arg)) 4210 case (ELEMENT_NODE, ATTRIBUTE_NODE, DOCUMENT_FRAGMENT_NODE) 4211 if (arg%readonly) then 4212 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 4213 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setTextContent", ex) 4214 if (present(ex)) then 4215 if (inException(ex)) then 4216 return 4217 endif 4218 endif 4219endif 4220 4221 endif 4222 do i = 1, getLength(getChildNodes(arg)) 4223 call destroyNode(arg%childNodes%nodes(i)%this) 4224 enddo 4225 deallocate(arg%childNodes%nodes) 4226 allocate(arg%childNodes%nodes(0)) 4227 arg%childNodes%length = 0 4228 arg%firstChild => null() 4229 arg%lastChild => null() 4230 arg%textContentLength = 0 4231 np => createTextNode(getOwnerDocument(arg), textContent) 4232 np => appendChild(arg, np) 4233 case (TEXT_NODE, CDATA_SECTION_NODE, PROCESSING_INSTRUCTION_NODE, COMMENT_NODE) 4234 call setData(arg, textContent) 4235 case (ENTITY_NODE, ENTITY_REFERENCE_NODE) 4236 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 4237 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setTextContent", ex) 4238 if (present(ex)) then 4239 if (inException(ex)) then 4240 return 4241 endif 4242 endif 4243endif 4244 4245 end select 4246 end subroutine setTextContent 4247 4248 function getBaseURI(arg, ex)result(baseURI) 4249 type(DOMException), intent(out), optional :: ex 4250 type(Node), pointer :: arg 4251 character(len=200) :: baseURI 4252 4253 type(Node), pointer :: el 4254 type(URI), pointer :: URIref, URIbase, newURI 4255 4256 select case(getNodeType(arg)) 4257 case (ELEMENT_NODE) 4258 el => arg 4259 case (ATTRIBUTE_NODE) 4260 if (getName(arg)=="xml:base") then 4261 if (associated(getOwnerElement(arg))) then 4262 el => getParentNode(getOwnerElement(arg)) 4263 else 4264 el => null() 4265 endif 4266 else 4267 el => getOwnerElement(arg) 4268 endif 4269 case (TEXT_NODE) 4270 ! then are we in an attribute or textContent? 4271 el => getParentNode(arg) 4272 do while (associated(el)) 4273 if (getNodeType(el)==ELEMENT_NODE) then 4274 exit 4275 elseif (getNodeType(el)==ATTRIBUTE_NODE) then 4276 el => getOwnerElement(el) 4277 exit 4278 else 4279 el => getParentNode(el) 4280 endif 4281 enddo 4282 case (PROCESSING_INSTRUCTION_NODE) 4283 ! then are we in or out of element content? 4284 el => getParentNode(arg) 4285 do while (associated(el)) 4286 if (getNodeType(el)==ELEMENT_NODE) then 4287 exit 4288 elseif (getNodeType(el)==DOCUMENT_NODE) then 4289 el => getOwnerElement(el) 4290 exit 4291 else 4292 el => getParentNode(el) 4293 endif 4294 enddo 4295 case default 4296 el => null() 4297 end select 4298 4299 URIref => parseURI("") 4300 4301 do while (associated(el)) 4302 select case (getNodeType(el)) 4303 case (ELEMENT_NODE) 4304 if (hasAttribute(el, "xml:base")) then 4305 URIbase => parseURI(getAttribute(el, "xml:base")) 4306 newURI => rebaseURI(URIbase, URIref) 4307 call destroyURI(URIbase) 4308 call destroyURI(URIref) 4309 URIref => newURI 4310 if (isAbsoluteURI(URIref)) exit 4311 endif 4312 case (ENTITY_REFERENCE_NODE) 4313 if (getSystemId(el)/="") then 4314 URIbase => parseURI(getSystemId(el)) 4315 newURI => rebaseURI(URIbase, URIref) 4316 call destroyURI(URIbase) 4317 call destroyURI(URIref) 4318 URIref => newURI 4319 if (isAbsoluteURI(URIref)) exit 4320 endif 4321 case default 4322 exit 4323 end select 4324 el => getParentNode(el) 4325 end do 4326 4327 if (isAbsoluteURI(URIref)) then 4328 baseURI = expressURI(URIref) 4329 else 4330 baseURI = "" 4331 endif 4332 call destroyURI(URIref) 4333 4334 end function getBaseURI 4335 4336 recursive function getNodePath(arg, ex)result(c) 4337 type(DOMException), intent(out), optional :: ex 4338 ! recursive only for atts and text 4339 type(Node), pointer :: arg 4340 character(len=100) :: c 4341 4342 type(Node), pointer :: this, this2 4343 character(len=len(c)) :: c2 4344 integer :: n 4345 4346 if (.not.associated(arg)) then 4347 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 4348 call throw_exception(FoX_NODE_IS_NULL, "getNodePath", ex) 4349 if (present(ex)) then 4350 if (inException(ex)) then 4351 return 4352 endif 4353 endif 4354endif 4355 4356 endif 4357 4358 c = "" 4359 if (.not.arg%inDocument) return 4360 select case(getNodeType(arg)) 4361 4362 case (ELEMENT_NODE) 4363 this => arg 4364 do while (getNodeType(this)/=DOCUMENT_NODE) 4365 c2 = "" 4366 this2 => getPreviousSibling(this) 4367 n = 0 4368 do while (associated(this2)) 4369 if (getNodeType(this2)==ELEMENT_NODE & 4370 .and.getNodeName(this2)==getNodeName(this)) n = n + 1 4371 this2 => getPreviousSibling(this2) 4372 enddo 4373 if (n==0) then 4374 this2 => getNextSibling(this) 4375 do while (associated(this2)) 4376 if (getNodeType(this2)==ELEMENT_NODE & 4377 .and.getNodeName(this2)==getNodeName(this)) then 4378 n = 1 4379 exit 4380 endif 4381 this2 => getNextSibling(this2) 4382 enddo 4383 else 4384 n = n + 1 4385 endif 4386 if (n>0) c2 = "["//n//"]" 4387 ! What name to use: 4388 if (getNamespaceURI(this)/="".and.getPrefix(this)=="") then 4389 ! default namespace; need to do the * trick 4390 ! how many previous siblings? 4391 c2 = "/*"//c2 4392 else 4393 c2 = "/"//getNodeName(this)//c2 4394 endif 4395 c = trim(c2)//c 4396 this => getParentNode(this) 4397 enddo 4398 4399 case (ATTRIBUTE_NODE) 4400 c = trim(getNodePath(getOwnerElement(arg)))//"/@"//getNodeName(arg) 4401 4402 case (TEXT_NODE, CDATA_SECTION_NODE) 4403 ! FIXME this will give wrong answers sometimes if 4404 ! the tree contains entity references 4405 this => getParentNode(arg) 4406 do while (associated(this)) 4407 if (getNodeType(this)==ELEMENT_NODE) exit 4408 this => getParentNode(this) 4409 enddo 4410 if (getNodeType(this)/=ELEMENT_NODE) & 4411 this => getOwnerElement(this) 4412 c = trim(getNodePath(this))//"/text()" 4413 this => getPreviousSibling(arg) 4414 n = 0 4415 do while (associated(this)) 4416 if (getNodeType(this)==TEXT_NODE & 4417 .or.getNodeType(this)==CDATA_SECTION_NODE) n = n + 1 4418 this => getPreviousSibling(this) 4419 enddo 4420 if (n==0) then 4421 this => getNextSibling(arg) 4422 do while (associated(this)) 4423 if (getNodeType(this)==COMMENT_NODE & 4424 .or.getNodeType(this)==CDATA_SECTION_NODE) then 4425 n = 1 4426 exit 4427 endif 4428 this => getNextSibling(this) 4429 enddo 4430 else 4431 n = n + 1 4432 endif 4433 if (n>0) c = trim(c)//"["//n//"]" 4434 4435 case (PROCESSING_INSTRUCTION_NODE) 4436 this => getParentNode(arg) 4437 c = trim(getNodePath(this))//"/processing-instruction("//getNodeName(arg)//")" 4438 this => getPreviousSibling(arg) 4439 n = 0 4440 do while (associated(this)) 4441 if (getNodeType(this)==PROCESSING_INSTRUCTION_NODE & 4442 .and.getNodeName(this)==getNodeName(arg)) n = n + 1 4443 this => getPreviousSibling(this) 4444 enddo 4445 if (n==0) then 4446 this => getNextSibling(arg) 4447 do while (associated(this)) 4448 if (getNodeType(this)==PROCESSING_INSTRUCTION_NODE & 4449 .and.getNodeName(this)==getNodeName(arg)) then 4450 n = 1 4451 exit 4452 endif 4453 this => getNextSibling(this) 4454 enddo 4455 else 4456 n = n + 1 4457 endif 4458 if (n>0) c = trim(c)//"["//n//"]" 4459 4460 case (COMMENT_NODE) 4461 this => getParentNode(arg) 4462 c = trim(getNodePath(this))//"/comment()" 4463 this => getPreviousSibling(arg) 4464 n = 0 4465 do while (associated(this)) 4466 if (getNodeType(this)==COMMENT_NODE) n = n + 1 4467 this => getPreviousSibling(this) 4468 enddo 4469 if (n==0) then 4470 this => getNextSibling(arg) 4471 do while (associated(this)) 4472 if (getNodeType(this)==COMMENT_NODE) then 4473 n = 1 4474 exit 4475 endif 4476 this => getNextSibling(this) 4477 enddo 4478 else 4479 n = n + 1 4480 endif 4481 if (n>0) c = trim(c)//"["//n//"]" 4482 4483 case (DOCUMENT_NODE) 4484 c = "/" 4485 4486 case (XPATH_NAMESPACE_NODE) 4487 this => getOwnerElement(arg) 4488 if (getPrefix(arg)=="") then 4489 c = trim(getNodePath(this))//"/namespace::xmlns" 4490 else 4491 c = trim(getNodePath(this))//"/namespace::"//getPrefix(arg) 4492 endif 4493 ! FIXME namespace nodes are not marked as inDocument correctly 4494 4495 end select 4496 4497 end function getNodePath 4498 4499 subroutine putNodesInDocument(doc, arg) 4500 type(Node), pointer :: doc, arg 4501 type(Node), pointer :: this, treeroot 4502 logical :: doneChildren, doneAttributes 4503 integer :: i_tree 4504 4505 treeroot => arg 4506 4507 i_tree = 0 4508 doneChildren = .false. 4509 doneAttributes = .false. 4510 this => treeroot 4511 do 4512 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 4513 4514 this%inDocument = .true. 4515 call remove_node_nl(doc%docExtras%hangingNodes, this) 4516 4517 else 4518 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 4519 doneAttributes = .true. 4520 else 4521 4522 endif 4523 endif 4524 4525 4526 if (.not.doneChildren) then 4527 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 4528 if (getLength(getAttributes(this))>0) then 4529 this => item(getAttributes(this), 0) 4530 else 4531 doneAttributes = .true. 4532 endif 4533 elseif (hasChildNodes(this)) then 4534 this => getFirstChild(this) 4535 doneChildren = .false. 4536 doneAttributes = .false. 4537 else 4538 doneChildren = .true. 4539 doneAttributes = .false. 4540 endif 4541 4542 else ! if doneChildren 4543 4544 if (associated(this, treeroot)) exit 4545 if (getNodeType(this)==ATTRIBUTE_NODE) then 4546 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 4547 i_tree= i_tree+ 1 4548 this => item(getAttributes(getOwnerElement(this)), i_tree) 4549 doneChildren = .false. 4550 else 4551 i_tree= 0 4552 this => getOwnerElement(this) 4553 doneAttributes = .true. 4554 doneChildren = .false. 4555 endif 4556 elseif (associated(getNextSibling(this))) then 4557 4558 this => getNextSibling(this) 4559 doneChildren = .false. 4560 doneAttributes = .false. 4561 else 4562 this => getParentNode(this) 4563 endif 4564 endif 4565 4566 enddo 4567 4568 4569 4570 4571 end subroutine putNodesInDocument 4572 4573 subroutine removeNodesFromDocument(doc, arg) 4574 type(Node), pointer :: doc, arg 4575 type(Node), pointer :: this, treeroot 4576 logical :: doneChildren, doneAttributes 4577 integer :: i_tree 4578 4579 treeroot => arg 4580 4581 i_tree = 0 4582 doneChildren = .false. 4583 doneAttributes = .false. 4584 this => treeroot 4585 do 4586 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 4587 4588 this%inDocument = .false. 4589 call append_nl(doc%docExtras%hangingNodes, this) 4590 4591 else 4592 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 4593 doneAttributes = .true. 4594 else 4595 4596 endif 4597 endif 4598 4599 4600 if (.not.doneChildren) then 4601 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 4602 if (getLength(getAttributes(this))>0) then 4603 this => item(getAttributes(this), 0) 4604 else 4605 doneAttributes = .true. 4606 endif 4607 elseif (hasChildNodes(this)) then 4608 this => getFirstChild(this) 4609 doneChildren = .false. 4610 doneAttributes = .false. 4611 else 4612 doneChildren = .true. 4613 doneAttributes = .false. 4614 endif 4615 4616 else ! if doneChildren 4617 4618 if (associated(this, treeroot)) exit 4619 if (getNodeType(this)==ATTRIBUTE_NODE) then 4620 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 4621 i_tree= i_tree+ 1 4622 this => item(getAttributes(getOwnerElement(this)), i_tree) 4623 doneChildren = .false. 4624 else 4625 i_tree= 0 4626 this => getOwnerElement(this) 4627 doneAttributes = .true. 4628 doneChildren = .false. 4629 endif 4630 elseif (associated(getNextSibling(this))) then 4631 4632 this => getNextSibling(this) 4633 doneChildren = .false. 4634 doneAttributes = .false. 4635 else 4636 this => getParentNode(this) 4637 endif 4638 endif 4639 4640 enddo 4641 4642 4643 4644 end subroutine removeNodesFromDocument 4645 4646 subroutine setReadOnlyNode(arg, p, deep) 4647 type(Node), pointer :: arg 4648 logical, intent(in) :: p 4649 logical, intent(in) :: deep 4650 4651 type(Node), pointer :: this, treeroot 4652 integer :: i_tree 4653 logical :: doneAttributes, doneChildren 4654 4655 if (deep) then 4656 treeroot => arg 4657 4658 i_tree = 0 4659 doneChildren = .false. 4660 doneAttributes = .false. 4661 this => treeroot 4662 do 4663 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 4664 4665 this%readonly = p 4666 if (this%nodeType==ELEMENT_NODE) & 4667 this%elExtras%attributes%readonly = p 4668 4669 else 4670 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 4671 doneAttributes = .true. 4672 else 4673 4674 endif 4675 endif 4676 4677 4678 if (.not.doneChildren) then 4679 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 4680 if (getLength(getAttributes(this))>0) then 4681 this => item(getAttributes(this), 0) 4682 else 4683 doneAttributes = .true. 4684 endif 4685 elseif (hasChildNodes(this)) then 4686 this => getFirstChild(this) 4687 doneChildren = .false. 4688 doneAttributes = .false. 4689 else 4690 doneChildren = .true. 4691 doneAttributes = .false. 4692 endif 4693 4694 else ! if doneChildren 4695 4696 if (associated(this, treeroot)) exit 4697 if (getNodeType(this)==ATTRIBUTE_NODE) then 4698 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 4699 i_tree= i_tree+ 1 4700 this => item(getAttributes(getOwnerElement(this)), i_tree) 4701 doneChildren = .false. 4702 else 4703 i_tree= 0 4704 this => getOwnerElement(this) 4705 doneAttributes = .true. 4706 doneChildren = .false. 4707 endif 4708 elseif (associated(getNextSibling(this))) then 4709 4710 this => getNextSibling(this) 4711 doneChildren = .false. 4712 doneAttributes = .false. 4713 else 4714 this => getParentNode(this) 4715 endif 4716 endif 4717 4718 enddo 4719 4720 4721 else 4722 arg%readonly = p 4723 if (arg%nodeType==ELEMENT_NODE) & 4724 arg%elExtras%attributes%readonly = p 4725 endif 4726 4727 end subroutine setReadOnlyNode 4728 4729function getreadonly(np, ex)result(c) 4730 type(DOMException), intent(out), optional :: ex 4731 type(Node), pointer :: np 4732 logical :: c 4733 4734 4735 if (.not.associated(np)) then 4736 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 4737 call throw_exception(FoX_NODE_IS_NULL, "getreadonly", ex) 4738 if (present(ex)) then 4739 if (inException(ex)) then 4740 return 4741 endif 4742 endif 4743endif 4744 4745 endif 4746 4747 4748 c = np%readonly 4749 4750 end function getreadonly 4751 4752 4753 4754 4755 function item_nl(list, index, ex)result(np) 4756 type(DOMException), intent(out), optional :: ex 4757 type(NodeList), pointer :: list 4758 integer, intent(in) :: index 4759 type(Node), pointer :: np 4760 4761 if (.not.associated(list)) then 4762 if (getFoX_checks().or.FoX_LIST_IS_NULL<200) then 4763 call throw_exception(FoX_LIST_IS_NULL, "item_nl", ex) 4764 if (present(ex)) then 4765 if (inException(ex)) then 4766 return 4767 endif 4768 endif 4769endif 4770 4771 endif 4772 4773 if (index>=0.and.index<list%length) then 4774 np => list%nodes(index+1)%this 4775 else 4776 np => null() 4777 endif 4778 4779 end function item_nl 4780 4781 subroutine append_nl(list, arg) 4782 type(NodeList), intent(inout) :: list 4783 type(Node), pointer :: arg 4784 4785 type(ListNode), pointer :: temp_nl(:) 4786 integer :: i 4787 4788 if (.not.associated(list%nodes)) then 4789 allocate(list%nodes(1)) 4790 list%nodes(1)%this => arg 4791 list%length = 1 4792 else 4793 temp_nl => list%nodes 4794 allocate(list%nodes(size(temp_nl)+1)) 4795 do i = 1, size(temp_nl) 4796 list%nodes(i)%this => temp_nl(i)%this 4797 enddo 4798 deallocate(temp_nl) 4799 list%nodes(size(list%nodes))%this => arg 4800 list%length = size(list%nodes) 4801 endif 4802 4803 end subroutine append_nl 4804 4805 function pop_nl(list, ex)result(np) 4806 type(DOMException), intent(out), optional :: ex 4807 type(NodeList), pointer :: list 4808 type(Node), pointer :: np 4809 4810 type(ListNode), pointer :: temp_nl(:) 4811 integer :: i 4812 4813 if (list%length==0) then 4814 if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then 4815 call throw_exception(FoX_INTERNAL_ERROR, "pop_nl", ex) 4816 if (present(ex)) then 4817 if (inException(ex)) then 4818 return 4819 endif 4820 endif 4821endif 4822 4823 endif 4824 4825 np => list%nodes(size(list%nodes))%this 4826 4827 if (list%length==1) then 4828 deallocate(list%nodes) 4829 list%length = 0 4830 else 4831 temp_nl => list%nodes 4832 allocate(list%nodes(size(temp_nl)-1)) 4833 do i = 1, size(temp_nl)-1 4834 list%nodes(i)%this => temp_nl(i)%this 4835 enddo 4836 deallocate(temp_nl) 4837 list%length = size(list%nodes) 4838 endif 4839 4840 end function pop_nl 4841 4842 4843 function remove_nl(nl, index, ex)result(np) 4844 type(DOMException), intent(out), optional :: ex 4845 type(NodeList), intent(inout) :: nl 4846 integer, intent(in) :: index 4847 type(Node), pointer :: np 4848 4849 type(ListNode), pointer :: temp_nl(:) 4850 4851 integer :: i 4852 4853 if (index>nl%length) then 4854 if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then 4855 call throw_exception(FoX_INTERNAL_ERROR, "remove_nl", ex) 4856 if (present(ex)) then 4857 if (inException(ex)) then 4858 return 4859 endif 4860 endif 4861endif 4862 4863 endif 4864 4865 np => nl%nodes(index)%this 4866 temp_nl => nl%nodes 4867 allocate(nl%nodes(size(temp_nl)-1)) 4868 nl%length = nl%length - 1 4869 do i = 1, index - 1 4870 nl%nodes(i)%this => temp_nl(i)%this 4871 enddo 4872 do i = index, nl%length 4873 nl%nodes(i)%this => temp_nl(i+1)%this 4874 enddo 4875 deallocate(temp_nl) 4876 4877 end function remove_nl 4878 4879 4880 subroutine remove_node_nl(nl, np) 4881 type(NodeList), intent(inout) :: nl 4882 type(Node), pointer :: np 4883 4884 integer :: i 4885 4886 do i = 1, nl%length 4887 if (associated(nl%nodes(i)%this, np)) exit 4888 enddo 4889 np => remove_nl(nl, i) 4890 4891 end subroutine remove_node_nl 4892 4893 4894 function getLength_nl(nl, ex)result(n) 4895 type(DOMException), intent(out), optional :: ex 4896 type(NodeList), pointer :: nl 4897 integer :: n 4898 4899 if (.not.associated(nl)) then 4900 if (getFoX_checks().or.FoX_LIST_IS_NULL<200) then 4901 call throw_exception(FoX_LIST_IS_NULL, "getLength_nl", ex) 4902 if (present(ex)) then 4903 if (inException(ex)) then 4904 return 4905 endif 4906 endif 4907endif 4908 4909 endif 4910 4911 n = size(nl%nodes) 4912 end function getLength_nl 4913 4914 subroutine destroyNodeList(nl) 4915 type(NodeList), pointer :: nl 4916 4917 if (associated(nl%nodes)) deallocate(nl%nodes) 4918 if (associated(nl%nodeName)) deallocate(nl%nodeName) 4919 if (associated(nl%localName)) deallocate(nl%localName) 4920 if (associated(nl%namespaceURI)) deallocate(nl%namespaceURI) 4921 deallocate(nl) 4922 end subroutine destroyNodeList 4923 4924 subroutine updateNodeLists(doc) 4925 ! When triggered, update all nodelists 4926 type(Node), pointer :: doc 4927 4928 type(NodeList), pointer :: nl, nl_orig 4929 type(NodeListPtr), pointer :: temp_nll(:) 4930 integer :: i, i_t 4931 4932 if (.not.getGCstate(doc)) return 4933 if (.not.doc%docExtras%liveNodeLists) return 4934 if (.not.associated(doc%docExtras%nodelists)) return 4935 4936 ! We point the old list of nodelists to temp_nll, then recalculate 4937 ! them all (which repopulates nodelists) 4938 temp_nll => doc%docExtras%nodelists 4939 i_t = size(temp_nll) 4940 allocate(doc%docExtras%nodelists(0)) 4941 do i = 1, i_t 4942 nl_orig => temp_nll(i)%this 4943 ! 4944 ! Although all nodes should be searched whatever the result, 4945 ! we should only do the appropriate sort of search for this 4946 ! list - according to namespaces or not. 4947 ! 4948 if (associated(nl_orig%nodeName)) then 4949 ! this was made by getElementsByTagName 4950 nl => getElementsByTagName(nl_orig%element, str_vs(nl_orig%nodeName)) 4951 elseif (associated(nl_orig%namespaceURI)) then 4952 ! this was made by getElementsByTagNameNS 4953 nl => getElementsByTagNameNS(nl_orig%element, & 4954 str_vs(nl_orig%localName), str_vs(nl_orig%namespaceURI)) 4955 endif 4956 enddo 4957 ! We dont care about the nodelists weve calculated now 4958 nullify(nl) 4959 4960 deallocate(temp_nll) 4961 4962 end subroutine updateNodeLists 4963 4964 4965 4966 function getNamedItem(map, name, ex)result(np) 4967 type(DOMException), intent(out), optional :: ex 4968 type(NamedNodeMap), pointer :: map 4969 character(len=*), intent(in) :: name 4970 type(Node), pointer :: np 4971 4972 integer :: i 4973 4974 if (.not.associated(map)) then 4975 if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then 4976 call throw_exception(FoX_MAP_IS_NULL, "getNamedItem", ex) 4977 if (present(ex)) then 4978 if (inException(ex)) then 4979 return 4980 endif 4981 endif 4982endif 4983 4984 endif 4985 4986 do i = 1, map%length 4987 if (str_vs(map%nodes(i)%this%nodeName)==name) then 4988 np => map%nodes(i)%this 4989 return 4990 endif 4991 enddo 4992 4993 np => null() 4994 4995 end function getNamedItem 4996 4997 4998 function setNamedItem(map, arg, ex)result(np) 4999 type(DOMException), intent(out), optional :: ex 5000 type(NamedNodeMap), pointer :: map 5001 type(Node), pointer :: arg 5002 type(Node), pointer :: np 5003 5004 integer :: i 5005 5006 if (.not.associated(map)) then 5007 if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then 5008 call throw_exception(FoX_MAP_IS_NULL, "setNamedItem", ex) 5009 if (present(ex)) then 5010 if (inException(ex)) then 5011 return 5012 endif 5013 endif 5014endif 5015 5016 endif 5017 5018 if (.not.associated(arg)) then 5019 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 5020 call throw_exception(FoX_NODE_IS_NULL, "setNamedItem", ex) 5021 if (present(ex)) then 5022 if (inException(ex)) then 5023 return 5024 endif 5025 endif 5026endif 5027 5028 endif 5029 5030 if (map%readonly) then 5031 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 5032 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setNamedItem", ex) 5033 if (present(ex)) then 5034 if (inException(ex)) then 5035 return 5036 endif 5037 endif 5038endif 5039 5040 elseif (map%ownerElement%nodeType==ELEMENT_NODE) then 5041 if (.not.associated(map%ownerElement%ownerDocument, arg%ownerDocument)) then 5042 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 5043 call throw_exception(WRONG_DOCUMENT_ERR, "setNamedItem", ex) 5044 if (present(ex)) then 5045 if (inException(ex)) then 5046 return 5047 endif 5048 endif 5049endif 5050 5051 elseif (getNodeType(arg)/=ATTRIBUTE_NODE) then 5052 !Additional check from DOM 3 5053 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 5054 call throw_exception(HIERARCHY_REQUEST_ERR, "setNamedItem", ex) 5055 if (present(ex)) then 5056 if (inException(ex)) then 5057 return 5058 endif 5059 endif 5060endif 5061 5062 endif 5063 endif 5064 5065 if (getNodeType(arg)==ATTRIBUTE_NODE) then 5066 if (associated(map%ownerElement, getOwnerElement(arg))) then 5067 ! we are looking at literally the same node 5068 np => arg 5069 return 5070 elseif (associated(getOwnerElement(arg))) then 5071 if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then 5072 call throw_exception(INUSE_ATTRIBUTE_ERR, "setNamedItem", ex) 5073 if (present(ex)) then 5074 if (inException(ex)) then 5075 return 5076 endif 5077 endif 5078endif 5079 5080 endif 5081 arg%elExtras%ownerElement => map%ownerElement 5082 endif 5083 5084 do i = 0, getLength(map)-1 5085 np => item(map, i) 5086 if (getNodeName(np)==getNodeName(arg)) then 5087 map%nodes(i+1)%this => arg 5088 exit 5089 endif 5090 enddo 5091 5092 if (i<getLength(map)) then 5093 if (getGCstate(getOwnerDocument(map%ownerElement)).and.np%inDocument) then 5094 call removeNodesFromDocument(getOwnerDocument(map%ownerElement), np) 5095 np%inDocument = .false. 5096 endif 5097 else 5098 ! If not found, insert it at the end of the linked list 5099 np => null() 5100 call append_nnm(map, arg) 5101 endif 5102 5103 if (map%ownerElement%nodeType==ELEMENT_NODE) then 5104 if (getGCstate(getOwnerDocument(map%ownerElement))) then 5105 ! We need to worry about importing this node 5106 if (map%ownerElement%inDocument) then 5107 if (.not.arg%inDocument) & 5108 call putNodesInDocument(getOwnerDocument(map%ownerElement), arg) 5109 else 5110 if (arg%inDocument) & 5111 call removeNodesFromDocument(getOwnerDocument(map%ownerElement), arg) 5112 endif 5113 endif 5114 endif 5115 ! Otherwise we only ever setNNM when building the doc, so we know this 5116 ! does not matter 5117 5118 end function setNamedItem 5119 5120 5121 function removeNamedItem(map, name, ex)result(np) 5122 type(DOMException), intent(out), optional :: ex 5123 type(NamedNodeMap), pointer :: map 5124 character(len=*), intent(in) :: name 5125 type(Node), pointer :: np 5126 5127 type(xml_doc_state), pointer :: xds 5128 type(element_t), pointer :: elem 5129 type(attribute_t), pointer :: att 5130 type(ListNode), pointer :: temp_nl(:) 5131 integer :: i, i2 5132 5133 if (.not.associated(map)) then 5134 if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then 5135 call throw_exception(FoX_MAP_IS_NULL, "removeNamedItem", ex) 5136 if (present(ex)) then 5137 if (inException(ex)) then 5138 return 5139 endif 5140 endif 5141endif 5142 5143 endif 5144 5145 if (map%readonly) then 5146 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 5147 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeNamedItem", ex) 5148 if (present(ex)) then 5149 if (inException(ex)) then 5150 return 5151 endif 5152 endif 5153endif 5154 5155 endif 5156 5157 do i = 0, map%length-1 5158 np => item(map, i) 5159 if (getNodeName(np)==name) then 5160 xds => getXds(getOwnerDocument(map%ownerElement)) 5161 elem => get_element(xds%element_list, getNodeName(map%ownerElement)) 5162 att => get_attribute_declaration(elem, name) 5163 if (associated(att)) then 5164 if (attribute_has_default(att)) then ! there is a default value 5165 ! Well swap the old one out & put a new one in. 5166 ! Do *nothing* about namespace handling at this stage, 5167 ! wait until we are asked for namespace normalization 5168 if (getParameter( & 5169 getDomConfig(getOwnerDocument(map%ownerElement)), & 5170 "namespaces")) then 5171 np => createAttributeNS(getOwnerDocument(map%ownerElement), "", name) 5172 else 5173 np => createAttribute(getOwnerDocument(map%ownerElement), name) 5174 endif 5175 call setValue(np, str_vs(att%default)) 5176 call setSpecified(np, .false.) 5177 np => setNamedItem(map, np) 5178 call setSpecified(np, .true.) 5179 return 5180 endif 5181 endif 5182 ! Otherwise there was no default value, so we just remove the node. 5183 ! Grab this node 5184 if (getNodeType(np)==ATTRIBUTE_NODE) np%elExtras%ownerElement => null() 5185 ! and shrink the node list 5186 temp_nl => map%nodes 5187 allocate(map%nodes(size(temp_nl)-1)) 5188 do i2 = 1, i 5189 map%nodes(i2)%this => temp_nl(i2)%this 5190 enddo 5191 do i2 = i + 2, map%length 5192 map%nodes(i2-1)%this => temp_nl(i2)%this 5193 enddo 5194 map%length = size(map%nodes) 5195 deallocate(temp_nl) 5196 if (np%inDocument.and.getGCstate(getOwnerDocument(map%ownerElement))) & 5197 call removeNodesFromDocument(getOwnerDocument(map%ownerElement), np) 5198 !otherwise we are only going to destroy these nodes anyway, 5199 ! and finish 5200 return 5201 endif 5202 enddo 5203 5204 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 5205 call throw_exception(NOT_FOUND_ERR, "removeNamedItem", ex) 5206 if (present(ex)) then 5207 if (inException(ex)) then 5208 return 5209 endif 5210 endif 5211endif 5212 5213 5214 end function removeNamedItem 5215 5216 5217 function item_nnm(map, index, ex)result(np) 5218 type(DOMException), intent(out), optional :: ex 5219 type(NamedNodeMap), pointer :: map 5220 integer, intent(in) :: index 5221 type(Node), pointer :: np 5222 5223 if (.not.associated(map)) then 5224 if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then 5225 call throw_exception(FoX_MAP_IS_NULL, "item_nnm", ex) 5226 if (present(ex)) then 5227 if (inException(ex)) then 5228 return 5229 endif 5230 endif 5231endif 5232 5233 endif 5234 5235 if (index<0 .or. index>map%length-1) then 5236 np => null() 5237 else 5238 np => map%nodes(index+1)%this 5239 endif 5240 5241 end function item_nnm 5242 5243 function getLength_nnm(map, ex)result(n) 5244 type(DOMException), intent(out), optional :: ex 5245 type(namedNodeMap), pointer :: map 5246 integer :: n 5247 5248 if (.not.associated(map)) then 5249 if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then 5250 call throw_exception(FoX_MAP_IS_NULL, "getLength_nnm", ex) 5251 if (present(ex)) then 5252 if (inException(ex)) then 5253 return 5254 endif 5255 endif 5256endif 5257 5258 endif 5259 5260 n = map%length 5261 5262 end function getLength_nnm 5263 5264 5265 function getNamedItemNS(map, namespaceURI, localName, ex)result(np) 5266 type(DOMException), intent(out), optional :: ex 5267 type(NamedNodeMap), pointer :: map 5268 character(len=*), intent(in) :: namespaceURI 5269 character(len=*), intent(in) :: localName 5270 type(Node), pointer :: np 5271 5272 integer :: i 5273 5274 if (.not.associated(map)) then 5275 if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then 5276 call throw_exception(FoX_MAP_IS_NULL, "getNamedItemNS", ex) 5277 if (present(ex)) then 5278 if (inException(ex)) then 5279 return 5280 endif 5281 endif 5282endif 5283 5284 elseif (map%ownerElement%nodeType/=ELEMENT_NODE) then 5285 np => null() 5286 return 5287 endif 5288 5289 do i = 0, getLength(map) - 1 5290 np => item(map, i) 5291 if (getNamespaceURI(np)==namespaceURI & 5292 .and. getLocalName(np)==localName) then 5293 return 5294 endif 5295 enddo 5296 np => null() 5297 5298 end function getNamedItemNS 5299 5300 5301 function setNamedItemNS(map, arg, ex)result(np) 5302 type(DOMException), intent(out), optional :: ex 5303 type(NamedNodeMap), pointer :: map 5304 type(Node), pointer :: arg 5305 type(Node), pointer :: np 5306 5307 integer :: i 5308 5309 if (.not.associated(map)) then 5310 if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then 5311 call throw_exception(FoX_MAP_IS_NULL, "setNamedItemNS", ex) 5312 if (present(ex)) then 5313 if (inException(ex)) then 5314 return 5315 endif 5316 endif 5317endif 5318 5319 endif 5320 5321 if (.not.associated(arg)) then 5322 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 5323 call throw_exception(FoX_NODE_IS_NULL, "setNamedItemNS", ex) 5324 if (present(ex)) then 5325 if (inException(ex)) then 5326 return 5327 endif 5328 endif 5329endif 5330 5331 endif 5332 5333 if (map%readonly) then 5334 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 5335 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setNamedItemNS", ex) 5336 if (present(ex)) then 5337 if (inException(ex)) then 5338 return 5339 endif 5340 endif 5341endif 5342 5343 elseif (map%ownerElement%nodeType==ELEMENT_NODE) then 5344 if (.not.associated(map%ownerElement%ownerDocument, arg%ownerDocument)) then 5345 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 5346 call throw_exception(WRONG_DOCUMENT_ERR, "setNamedItemNS", ex) 5347 if (present(ex)) then 5348 if (inException(ex)) then 5349 return 5350 endif 5351 endif 5352endif 5353 5354 elseif (getNodeType(arg)/=ATTRIBUTE_NODE) then 5355 !Additional check from DOM 3 5356 if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then 5357 call throw_exception(HIERARCHY_REQUEST_ERR, "setNamedItemNS", ex) 5358 if (present(ex)) then 5359 if (inException(ex)) then 5360 return 5361 endif 5362 endif 5363endif 5364 5365 endif 5366 endif 5367 5368 if (getNodeType(arg)==ATTRIBUTE_NODE) then 5369 if (associated(map%ownerElement, getOwnerElement(arg))) then 5370 ! we are looking at literally the same node, so do nothing else 5371 np => arg 5372 return 5373 elseif (associated(getOwnerElement(arg))) then 5374 if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then 5375 call throw_exception(INUSE_ATTRIBUTE_ERR, "setNamedItemNS", ex) 5376 if (present(ex)) then 5377 if (inException(ex)) then 5378 return 5379 endif 5380 endif 5381endif 5382 5383 endif 5384 arg%elExtras%ownerElement => map%ownerElement 5385 endif 5386 5387 do i = 0, getLength(map) - 1 5388 np => item(map, i) 5389 if ((getLocalName(arg)==getLocalName(np) & 5390 .and.getNamespaceURI(arg)==getNamespaceURI(np)) & 5391 ! Additional case to catch adding of specified attributeNS over 5392 ! default (NS but unspecified URI) attribute 5393 .or.(getNamespaceURI(arg)=="".and.getName(arg)==getName(np))) then 5394 map%nodes(i+1)%this => arg 5395 exit 5396 endif 5397 enddo 5398 5399 if (i<getLength(map)) then 5400 if (getGCstate(getOwnerDocument(map%ownerElement))) then 5401 if (np%inDocument) then 5402 call removeNodesFromDocument(getOwnerDocument(map%ownerElement), np) 5403 arg%inDocument = .false. 5404 endif 5405 endif 5406 else 5407 ! If not found, insert it at the end of the linked list 5408 np => null() 5409 call append_nnm(map, arg) 5410 endif 5411 5412 if (map%ownerElement%nodeType==ELEMENT_NODE) then 5413 if (getGCstate(getOwnerDocument(map%ownerElement))) then 5414 ! We need to worry about importing this node 5415 if (map%ownerElement%inDocument) then 5416 if (.not.arg%inDocument) & 5417 call putNodesInDocument(getOwnerDocument(map%ownerElement), arg) 5418 else 5419 if (arg%inDocument) & 5420 call removeNodesFromDocument(getOwnerDocument(map%ownerElement), arg) 5421 endif 5422 endif 5423 endif 5424 5425 end function setNamedItemNS 5426 5427 5428 function removeNamedItemNS(map, namespaceURI, localName, ex)result(np) 5429 type(DOMException), intent(out), optional :: ex 5430 type(NamedNodeMap), pointer :: map 5431 character(len=*), intent(in) :: namespaceURI 5432 character(len=*), intent(in) :: localName 5433 type(Node), pointer :: np 5434 5435 type(xml_doc_state), pointer :: xds 5436 type(element_t), pointer :: elem 5437 type(attribute_t), pointer :: att 5438 type(ListNode), pointer :: temp_nl(:) 5439 integer :: i, i2 5440 5441 if (.not.associated(map)) then 5442 if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then 5443 call throw_exception(FoX_MAP_IS_NULL, "removeNamedItemNS", ex) 5444 if (present(ex)) then 5445 if (inException(ex)) then 5446 return 5447 endif 5448 endif 5449endif 5450 5451 endif 5452 5453 if (map%readonly) then 5454 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 5455 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeNamedItemNS", ex) 5456 if (present(ex)) then 5457 if (inException(ex)) then 5458 return 5459 endif 5460 endif 5461endif 5462 5463 endif 5464 5465 do i = 0, getLength(map) - 1 5466 np => item(map, i) 5467 if (getNamespaceURI(np)==namespaceURI & 5468 .and. getLocalName(np)==localName) then 5469 ! Grab this node 5470 xds => getXds(getOwnerDocument(map%ownerElement)) 5471 elem => get_element(xds%element_list, getNodeName(map%ownerElement)) 5472 att => get_attribute_declaration(elem, getName(np)) 5473 if (associated(att)) then 5474 if (attribute_has_default(att)) then ! there is a default value 5475 ! Well swap the old one out & put a new one in. 5476 ! Do *nothing* about namespace handling at this stage, 5477 ! wait until we are asked for namespace normalization 5478 np => createAttributeNS(getOwnerDocument(map%ownerElement), getNamespaceURI(np), getName(np)) 5479 call setValue(np, str_vs(att%default)) 5480 call setSpecified(np, .false.) 5481 np => setNamedItemNS(map, np) 5482 call setSpecified(np, .true.) 5483 return 5484 endif 5485 endif 5486 ! Otherwise there was no default value, so we just remove the node. 5487 ! and shrink the node list 5488 if (getNodeType(np)==ATTRIBUTE_NODE) np%elExtras%ownerElement => null() 5489 temp_nl => map%nodes 5490 allocate(map%nodes(size(temp_nl)-1)) 5491 do i2 = 1, i 5492 map%nodes(i2)%this => temp_nl(i2)%this 5493 enddo 5494 do i2 = i + 2, map%length 5495 map%nodes(i2-1)%this => temp_nl(i2)%this 5496 enddo 5497 map%length = size(map%nodes) 5498 deallocate(temp_nl) 5499 if (np%inDocument.and.getGCstate(getOwnerDocument(map%ownerElement))) & 5500 call removeNodesFromDocument(getOwnerDocument(map%ownerElement), np) 5501 !otherwise we are only going to destroy these nodes anyway, 5502 ! and finish 5503 return 5504 endif 5505 enddo 5506 5507 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 5508 call throw_exception(NOT_FOUND_ERR, "removeNamedItemNS", ex) 5509 if (present(ex)) then 5510 if (inException(ex)) then 5511 return 5512 endif 5513 endif 5514endif 5515 5516 5517 end function removeNamedItemNS 5518 5519 5520 subroutine append_nnm(map, arg) 5521 type(namedNodeMap), pointer :: map 5522 type(node), pointer :: arg 5523 5524 type(ListNode), pointer :: temp_nl(:) 5525 integer :: i 5526 5527 if (.not.associated(map%nodes)) then 5528 allocate(map%nodes(1)) 5529 map%nodes(1)%this => arg 5530 map%length = 1 5531 else 5532 temp_nl => map%nodes 5533 allocate(map%nodes(size(temp_nl)+1)) 5534 do i = 1, size(temp_nl) 5535 map%nodes(i)%this => temp_nl(i)%this 5536 enddo 5537 deallocate(temp_nl) 5538 map%nodes(size(map%nodes))%this => arg 5539 map%length = size(map%nodes) 5540 endif 5541 if (getNodeType(arg)==ATTRIBUTE_NODE) arg%elExtras%ownerElement => map%ownerElement 5542 5543 end subroutine append_nnm 5544 5545 5546 subroutine setReadOnlyMap(map, r) 5547 type(namedNodeMap), pointer :: map 5548 logical, intent(in) :: r 5549 5550 map%readonly = r 5551 end subroutine setReadOnlyMap 5552 5553 subroutine destroyNamedNodeMap(map) 5554 type(namedNodeMap), pointer :: map 5555 5556 if (associated(map%nodes)) deallocate(map%nodes) 5557 deallocate(map) 5558 end subroutine destroyNamedNodeMap 5559 5560 5561 5562 function hasFeature(impl, feature, version, ex)result(p) 5563 type(DOMException), intent(out), optional :: ex 5564 type(DOMImplementation), pointer :: impl 5565 character(len=*), intent(in) :: feature 5566 character(len=*), intent(in) :: version 5567 logical :: p 5568 5569 if (.not.associated(impl)) then 5570 if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then 5571 call throw_exception(FoX_IMPL_IS_NULL, "hasFeature", ex) 5572 if (present(ex)) then 5573 if (inException(ex)) then 5574 return 5575 endif 5576 endif 5577endif 5578 5579 endif 5580 5581 if (version=="1.0".or.version=="2.0".or.version=="") then 5582 p = (toLower(feature)=="core".or.toLower(feature)=="xml") 5583 else 5584 p = .false. 5585 endif 5586 5587 end function hasFeature 5588 5589 function createDocumentType(impl, qualifiedName, publicId, systemId, ex)result(dt) 5590 type(DOMException), intent(out), optional :: ex 5591 type(DOMImplementation), pointer :: impl 5592 character(len=*), intent(in) :: qualifiedName 5593 character(len=*), intent(in) :: publicId 5594 character(len=*), intent(in) :: systemId 5595 type(Node), pointer :: dt 5596 5597 type(URI), pointer :: URIref 5598 5599 dt => null() 5600 5601 if (.not.associated(impl)) then 5602 if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then 5603 call throw_exception(FoX_IMPL_IS_NULL, "createDocumentType", ex) 5604 if (present(ex)) then 5605 if (inException(ex)) then 5606 return 5607 endif 5608 endif 5609endif 5610 5611 endif 5612 5613 if (.not.checkName(qualifiedName, XML1_0)) then 5614 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 5615 call throw_exception(INVALID_CHARACTER_ERR, "createDocumentType", ex) 5616 if (present(ex)) then 5617 if (inException(ex)) then 5618 return 5619 endif 5620 endif 5621endif 5622 5623 elseif (.not.checkQName(qualifiedName, XML1_0)) then 5624 if (getFoX_checks().or.NAMESPACE_ERR<200) then 5625 call throw_exception(NAMESPACE_ERR, "createDocumentType", ex) 5626 if (present(ex)) then 5627 if (inException(ex)) then 5628 return 5629 endif 5630 endif 5631endif 5632 5633 elseif (.not.checkPublicId(publicId)) then 5634 if (getFoX_checks().or.FoX_INVALID_PUBLIC_ID<200) then 5635 call throw_exception(FoX_INVALID_PUBLIC_ID, "createDocumentType", ex) 5636 if (present(ex)) then 5637 if (inException(ex)) then 5638 return 5639 endif 5640 endif 5641endif 5642 5643 endif 5644 URIref => parseURI(systemId) 5645 if (.not.associated(URIref)) then 5646 if (getFoX_checks().or.FoX_INVALID_SYSTEM_ID<200) then 5647 call throw_exception(FoX_INVALID_SYSTEM_ID, "createDocumentType", ex) 5648 if (present(ex)) then 5649 if (inException(ex)) then 5650 return 5651 endif 5652 endif 5653endif 5654 5655 endif 5656 call destroyURI(URIref) 5657 5658! Dont use raw null() below or PGI will complain 5659 dt => createNode(dt, DOCUMENT_TYPE_NODE, qualifiedName, "") 5660 allocate(dt%dtdExtras) 5661 dt%readonly = .true. 5662 dt%dtdExtras%publicId => vs_str_alloc(publicId) 5663 dt%dtdExtras%systemId => vs_str_alloc(systemId) 5664 dt%dtdExtras%entities%ownerElement => dt 5665 dt%dtdExtras%notations%ownerElement => dt 5666 5667 dt%ownerDocument => null() 5668 5669 end function createDocumentType 5670 5671 5672 function createDocument(impl, namespaceURI, qualifiedName, docType, ex)result(doc) 5673 type(DOMException), intent(out), optional :: ex 5674 type(DOMImplementation), pointer :: impl 5675 character(len=*), intent(in), optional :: namespaceURI 5676 character(len=*), intent(in), optional :: qualifiedName 5677 type(Node), pointer :: docType 5678 type(Node), pointer :: doc, dt, de 5679 5680 doc => null() 5681 5682 if (.not.associated(impl)) then 5683 if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then 5684 call throw_exception(FoX_IMPL_IS_NULL, "createDocument", ex) 5685 if (present(ex)) then 5686 if (inException(ex)) then 5687 return 5688 endif 5689 endif 5690endif 5691 5692 elseif (associated(docType)) then 5693 if (associated(getOwnerDocument(docType))) then 5694 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 5695 call throw_exception(WRONG_DOCUMENT_ERR, "createDocument", ex) 5696 if (present(ex)) then 5697 if (inException(ex)) then 5698 return 5699 endif 5700 endif 5701endif 5702 5703 endif 5704 endif 5705 5706 if (.not.checkName(qualifiedName, XML1_0)) then 5707 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 5708 call throw_exception(INVALID_CHARACTER_ERR, "createDocument", ex) 5709 if (present(ex)) then 5710 if (inException(ex)) then 5711 return 5712 endif 5713 endif 5714endif 5715 5716 elseif(.not.checkQName(qualifiedName, XML1_0)) then 5717 if (getFoX_checks().or.NAMESPACE_ERR<200) then 5718 call throw_exception(NAMESPACE_ERR, "createDocument", ex) 5719 if (present(ex)) then 5720 if (inException(ex)) then 5721 return 5722 endif 5723 endif 5724endif 5725 5726 elseif (prefixOfQName(qualifiedName)/="".and.namespaceURI=="") then 5727 if (getFoX_checks().or.NAMESPACE_ERR<200) then 5728 call throw_exception(NAMESPACE_ERR, "createDocument", ex) 5729 if (present(ex)) then 5730 if (inException(ex)) then 5731 return 5732 endif 5733 endif 5734endif 5735 5736 elseif (prefixOfQName(qualifiedName)=="xml".neqv.namespaceURI=="http://www.w3.org/XML/1998/namespace") then 5737 if (getFoX_checks().or.NAMESPACE_ERR<200) then 5738 call throw_exception(NAMESPACE_ERR, "createDocument", ex) 5739 if (present(ex)) then 5740 if (inException(ex)) then 5741 return 5742 endif 5743 endif 5744endif 5745 5746 elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then 5747 if (getFoX_checks().or.NAMESPACE_ERR<200) then 5748 call throw_exception(NAMESPACE_ERR, "createDocument", ex) 5749 if (present(ex)) then 5750 if (inException(ex)) then 5751 return 5752 endif 5753 endif 5754endif 5755 5756 elseif (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns") then 5757 if (getFoX_checks().or.NAMESPACE_ERR<200) then 5758 call throw_exception(NAMESPACE_ERR, "createDocument", ex) 5759 if (present(ex)) then 5760 if (inException(ex)) then 5761 return 5762 endif 5763 endif 5764endif 5765 5766 endif 5767 5768! Dont use raw null() below or PGI will complain 5769 doc => createNode(doc, DOCUMENT_NODE, "#document", "") 5770 doc%ownerDocument => doc ! Makes life easier. DOM compliance in getter 5771 doc%inDocument = .true. 5772 5773 allocate(doc%docExtras) 5774 doc%docExtras%implementation => FoX_DOM 5775 allocate(doc%docExtras%nodelists(0)) 5776 allocate(doc%docExtras%xds) 5777 call init_xml_doc_state(doc%docExtras%xds) 5778 allocate(doc%docExtras%xds%documentURI(0)) 5779 allocate(doc%docExtras%domConfig) 5780 5781 if (associated(docType)) then 5782 dt => docType 5783 dt%ownerDocument => doc 5784 doc%docExtras%docType => appendChild(doc, dt, ex) 5785 endif 5786 5787 if (qualifiedName/="") then 5788 ! NB It is impossible to create a non-namespaced document. 5789 ! since createDocument doesnt exist in DOM Core 1 5790 de => createElementNS(doc, namespaceURI, qualifiedName) 5791 de => appendChild(doc, de) 5792 call setDocumentElement(doc, de) 5793 endif 5794 5795 call setGCstate(doc, .true.) 5796 5797 end function createDocument 5798 5799 5800 function createEmptyDocument() result(doc) 5801 type(Node), pointer :: doc 5802 5803! PGI again 5804 doc => null() 5805 doc => createNode(doc, DOCUMENT_NODE, "#document", "") 5806 doc%ownerDocument => doc ! Makes life easier. DOM compliance maintained in getter 5807 doc%inDocument = .true. 5808 5809 allocate(doc%docExtras) 5810 doc%docExtras%implementation => FoX_DOM 5811 allocate(doc%docExtras%nodelists(0)) 5812 allocate(doc%docExtras%xds) 5813 call init_xml_doc_state(doc%docExtras%xds) 5814 5815 end function createEmptyDocument 5816 5817 5818 subroutine destroyDocument(arg, ex) 5819 type(DOMException), intent(out), optional :: ex 5820 type(Node), pointer :: arg 5821 5822 integer :: i 5823 5824 if (.not.associated(arg)) then 5825 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 5826 call throw_exception(FoX_NODE_IS_NULL, "destroyDocument", ex) 5827 if (present(ex)) then 5828 if (inException(ex)) then 5829 return 5830 endif 5831 endif 5832endif 5833 5834 endif 5835 5836 if (arg%nodeType /= DOCUMENT_NODE) then 5837 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 5838 call throw_exception(FoX_INVALID_NODE, "destroyDocument", ex) 5839 if (present(ex)) then 5840 if (inException(ex)) then 5841 return 5842 endif 5843 endif 5844endif 5845 5846 endif 5847 5848! Switch off all GC - since this is GC! 5849 call setGCstate(arg, .false., ex) 5850 if (arg%nodeType/=DOCUMENT_NODE) then 5851 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 5852 call throw_exception(FoX_INVALID_NODE, "destroyDocument", ex) 5853 if (present(ex)) then 5854 if (inException(ex)) then 5855 return 5856 endif 5857 endif 5858endif 5859 5860 endif 5861 5862! Destroy all remaining nodelists 5863 5864 do i = 1, size(arg%docExtras%nodelists) 5865 call destroy(arg%docExtras%nodelists(i)%this) 5866 enddo 5867 deallocate(arg%docExtras%nodelists) 5868 5869 ! Destroy all remaining hanging nodes 5870 do i = 1, arg%docExtras%hangingNodes%length 5871 call destroy(arg%docExtras%hangingNodes%nodes(i)%this) 5872 enddo 5873 if (associated(arg%docExtras%hangingNodes%nodes)) deallocate(arg%docExtras%hangingNodes%nodes) 5874 5875 call destroy_xml_doc_state(arg%docExtras%xds) 5876 if (present(ex)) then 5877 if (inException(ex)) return 5878 endif 5879 if (associated(arg%docExtras%xds)) deallocate(arg%docExtras%xds) 5880 if (associated(arg%docExtras%domConfig)) deallocate(arg%docExtras%domConfig) 5881 if (associated(arg%docExtras)) deallocate(arg%docExtras) 5882 5883 call destroyAllNodesRecursively(arg, except=.true.) 5884 5885 end subroutine destroyDocument 5886 5887 function getFoX_checks() result(FoX_checks) 5888 logical :: FoX_checks 5889 5890 FoX_checks = FoX_DOM%FoX_checks 5891 end function getFoX_checks 5892 5893 subroutine setFoX_checks(FoX_checks) 5894 logical, intent(in) :: FoX_checks 5895 5896 FoX_DOM%FoX_checks = FoX_checks 5897 end subroutine setFoX_checks 5898 5899 5900 5901 5902function getdocType(np, ex)result(c) 5903 type(DOMException), intent(out), optional :: ex 5904 type(Node), pointer :: np 5905 type(Node), pointer :: c 5906 5907 5908 if (.not.associated(np)) then 5909 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 5910 call throw_exception(FoX_NODE_IS_NULL, "getdocType", ex) 5911 if (present(ex)) then 5912 if (inException(ex)) then 5913 return 5914 endif 5915 endif 5916endif 5917 5918 endif 5919 5920 if (getNodeType(np)/=DOCUMENT_NODE .and. & 5921 .true.) then 5922 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 5923 call throw_exception(FoX_INVALID_NODE, "getdocType", ex) 5924 if (present(ex)) then 5925 if (inException(ex)) then 5926 return 5927 endif 5928 endif 5929endif 5930 5931 endif 5932 5933 c => np%docExtras%docType 5934 5935 end function getdocType 5936 5937 5938 subroutine setDocType(arg, np, ex) 5939 type(DOMException), intent(out), optional :: ex 5940 type(Node), pointer :: arg 5941 type(Node), pointer :: np 5942 5943 if (.not.associated(arg)) then 5944 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 5945 call throw_exception(FoX_NODE_IS_NULL, "setDocType", ex) 5946 if (present(ex)) then 5947 if (inException(ex)) then 5948 return 5949 endif 5950 endif 5951endif 5952 5953 endif 5954 5955 if (arg%nodeType/=DOCUMENT_NODE) then 5956 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 5957 call throw_exception(FoX_INVALID_NODE, "setDocType", ex) 5958 if (present(ex)) then 5959 if (inException(ex)) then 5960 return 5961 endif 5962 endif 5963endif 5964 5965 endif 5966 5967 arg%docExtras%docType => np 5968!NB special case in order to set ownerDocument 5969 np%ownerDocument => arg 5970 end subroutine setDocType 5971 5972function getdocumentElement(np, ex)result(c) 5973 type(DOMException), intent(out), optional :: ex 5974 type(Node), pointer :: np 5975 type(Node), pointer :: c 5976 5977 5978 if (.not.associated(np)) then 5979 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 5980 call throw_exception(FoX_NODE_IS_NULL, "getdocumentElement", ex) 5981 if (present(ex)) then 5982 if (inException(ex)) then 5983 return 5984 endif 5985 endif 5986endif 5987 5988 endif 5989 5990 if (getNodeType(np)/=DOCUMENT_NODE .and. & 5991 .true.) then 5992 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 5993 call throw_exception(FoX_INVALID_NODE, "getdocumentElement", ex) 5994 if (present(ex)) then 5995 if (inException(ex)) then 5996 return 5997 endif 5998 endif 5999endif 6000 6001 endif 6002 6003 c => np%docExtras%documentElement 6004 6005 end function getdocumentElement 6006 6007 6008 subroutine setXds(arg, xds, ex) 6009 type(DOMException), intent(out), optional :: ex 6010 type(Node), pointer :: arg 6011 type(xml_doc_state), pointer :: xds 6012 6013 if (.not.associated(arg)) then 6014 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6015 call throw_exception(FoX_NODE_IS_NULL, "setXds", ex) 6016 if (present(ex)) then 6017 if (inException(ex)) then 6018 return 6019 endif 6020 endif 6021endif 6022 6023 endif 6024 6025 if (arg%nodeType/=DOCUMENT_NODE) then 6026 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6027 call throw_exception(FoX_INVALID_NODE, "setXds", ex) 6028 if (present(ex)) then 6029 if (inException(ex)) then 6030 return 6031 endif 6032 endif 6033endif 6034 6035 endif 6036!NB special case in order to destroy_xml_doc_state etc 6037 call destroy_xml_doc_state(arg%docExtras%xds) 6038 deallocate(arg%docExtras%xds) 6039 arg%docExtras%xds => xds 6040 6041 end subroutine setXds 6042 6043 function getImplementation(arg, ex)result(imp) 6044 type(DOMException), intent(out), optional :: ex 6045 type(Node), pointer, optional :: arg 6046 type(DOMImplementation), pointer :: imp 6047 6048 ! According to the testsuite, you get to call 6049 ! getImplementation with no args. Dont know 6050 ! where they get that from ... 6051 if (present(arg)) then 6052 if (.not.associated(arg)) then 6053 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6054 call throw_exception(FoX_NODE_IS_NULL, "getImplementation", ex) 6055 if (present(ex)) then 6056 if (inException(ex)) then 6057 return 6058 endif 6059 endif 6060endif 6061 6062 endif 6063 6064 if (arg%nodeType/=DOCUMENT_NODE) then 6065 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6066 call throw_exception(FoX_INVALID_NODE, "getImplementation", ex) 6067 if (present(ex)) then 6068 if (inException(ex)) then 6069 return 6070 endif 6071 endif 6072endif 6073 6074 endif 6075 6076 imp => arg%docExtras%implementation 6077 else 6078 imp => FoX_DOM 6079 endif 6080 end function getImplementation 6081 6082 6083 subroutine setDocumentElement(arg, np, ex) 6084 type(DOMException), intent(out), optional :: ex 6085 ! Only for use by FoX, not exported through FoX_DOM interface 6086 type(Node), pointer :: arg 6087 type(Node), pointer :: np 6088 6089 if (.not.associated(arg)) then 6090 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6091 call throw_exception(FoX_NODE_IS_NULL, "setDocumentElement", ex) 6092 if (present(ex)) then 6093 if (inException(ex)) then 6094 return 6095 endif 6096 endif 6097endif 6098 6099 endif 6100 6101!NB special case due to additional error conditions: 6102 6103 if (arg%nodeType/=DOCUMENT_NODE) then 6104 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6105 call throw_exception(FoX_INVALID_NODE, "setDocumentElement", ex) 6106 if (present(ex)) then 6107 if (inException(ex)) then 6108 return 6109 endif 6110 endif 6111endif 6112 6113 elseif (np%nodeType/=ELEMENT_NODE) then 6114 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6115 call throw_exception(FoX_INVALID_NODE, "setDocumentElement", ex) 6116 if (present(ex)) then 6117 if (inException(ex)) then 6118 return 6119 endif 6120 endif 6121endif 6122 6123 elseif (.not.associated(np%ownerDocument, arg)) then 6124 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 6125 call throw_exception(WRONG_DOCUMENT_ERR, "setDocumentElement", ex) 6126 if (present(ex)) then 6127 if (inException(ex)) then 6128 return 6129 endif 6130 endif 6131endif 6132 6133 endif 6134 6135 arg%docExtras%documentElement => np 6136 6137 end subroutine setDocumentElement 6138 6139 ! Methods 6140 6141 function createElement(arg, tagName, ex)result(np) 6142 type(DOMException), intent(out), optional :: ex 6143 type(Node), pointer :: arg 6144 character(len=*), intent(in) :: tagName 6145 type(Node), pointer :: np 6146 6147 type(xml_doc_state), pointer :: xds 6148 type(element_t), pointer :: elem 6149 type(attribute_t), pointer :: att 6150 logical :: defaults_ 6151 integer :: i 6152 6153 if (.not.associated(arg)) then 6154 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6155 call throw_exception(FoX_NODE_IS_NULL, "createElement", ex) 6156 if (present(ex)) then 6157 if (inException(ex)) then 6158 return 6159 endif 6160 endif 6161endif 6162 6163 endif 6164 6165 if (arg%nodeType/=DOCUMENT_NODE) then 6166 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6167 call throw_exception(FoX_INVALID_NODE, "createElement", ex) 6168 if (present(ex)) then 6169 if (inException(ex)) then 6170 return 6171 endif 6172 endif 6173endif 6174 6175 elseif (.not.checkName(tagName, getXmlVersionEnum(arg))) then 6176 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 6177 call throw_exception(INVALID_CHARACTER_ERR, "createElement", ex) 6178 if (present(ex)) then 6179 if (inException(ex)) then 6180 return 6181 endif 6182 endif 6183endif 6184 6185 endif 6186 6187 6188 np => createNode(arg, ELEMENT_NODE, tagName, "") 6189 allocate(np%elExtras) 6190 np%elExtras%dom1 = .true. 6191 np%elExtras%attributes%ownerElement => np 6192 allocate(np%elExtras%namespaceURI(0)) 6193 allocate(np%elExtras%prefix(0)) 6194 allocate(np%elExtras%localname(0)) 6195 allocate(np%elExtras%namespaceNodes%nodes(0)) 6196 6197 np%elExtras%attributes%ownerElement => np 6198 6199 if (getGCstate(arg)) then 6200 np%inDocument = .false. 6201 call append(arg%docExtras%hangingnodes, np) 6202 ! We only add default attributes if we are *not* building the doc 6203 xds => getXds(arg) 6204 elem => get_element(xds%element_list, tagName) 6205 if (associated(elem)) then 6206 do i = 1, get_attlist_size(elem) 6207 att => get_attribute_declaration(elem, i) 6208 if (attribute_has_default(att)) then 6209 ! Since this is a non-namespaced function, we create 6210 ! a non-namespaced attribute ... 6211 call setAttribute(np, str_vs(att%name), str_vs(att%default)) 6212 endif 6213 enddo 6214 endif 6215 else 6216 np%inDocument = .true. 6217 endif 6218 6219 end function createElement 6220 6221 function createEmptyElement(arg, tagName, ex)result(np) 6222 type(DOMException), intent(out), optional :: ex 6223 type(Node), pointer :: arg 6224 character(len=*), intent(in) :: tagName 6225 type(Node), pointer :: np 6226 6227! NO CHECKS ! 6228 6229 np => createNode(arg, ELEMENT_NODE, tagName, "") 6230 allocate(np%elExtras) 6231 np%elExtras%dom1 = .true. 6232 np%elExtras%attributes%ownerElement => np 6233 allocate(np%elExtras%namespaceURI(0)) 6234 allocate(np%elExtras%prefix(0)) 6235 allocate(np%elExtras%localname(0)) 6236 allocate(np%elExtras%namespaceNodes%nodes(0)) 6237 6238 np%elExtras%attributes%ownerElement => np 6239 6240 if (getGCstate(arg)) then 6241 call append(arg%docExtras%hangingnodes, np) 6242 np%inDocument = .false. 6243 else 6244 np%inDocument = .true. 6245 endif 6246 end function createEmptyElement 6247 6248 function createDocumentFragment(arg, ex)result(np) 6249 type(DOMException), intent(out), optional :: ex 6250 type(Node), pointer :: arg 6251 type(Node), pointer :: np 6252 6253 if (.not.associated(arg)) then 6254 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6255 call throw_exception(FoX_NODE_IS_NULL, "createDocumentFragment", ex) 6256 if (present(ex)) then 6257 if (inException(ex)) then 6258 return 6259 endif 6260 endif 6261endif 6262 6263 endif 6264 6265 if (arg%nodeType/=DOCUMENT_NODE) then 6266 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6267 call throw_exception(FoX_INVALID_NODE, "createDocumentFragment", ex) 6268 if (present(ex)) then 6269 if (inException(ex)) then 6270 return 6271 endif 6272 endif 6273endif 6274 6275 endif 6276 6277 np => createNode(arg, DOCUMENT_FRAGMENT_NODE, "#document-fragment", "") 6278 if (getGCstate(arg)) then 6279 np%inDocument = .false. 6280 call append(arg%docExtras%hangingnodes, np) 6281 else 6282 np%inDocument = .true. 6283 endif 6284 6285 end function createDocumentFragment 6286 6287 function createTextNode(arg, data, ex)result(np) 6288 type(DOMException), intent(out), optional :: ex 6289 type(Node), pointer :: arg 6290 character(len=*), intent(in) :: data 6291 type(Node), pointer :: np 6292 6293 if (.not.associated(arg)) then 6294 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6295 call throw_exception(FoX_NODE_IS_NULL, "createTextNode", ex) 6296 if (present(ex)) then 6297 if (inException(ex)) then 6298 return 6299 endif 6300 endif 6301endif 6302 6303 endif 6304 6305 if (arg%nodeType/=DOCUMENT_NODE) then 6306 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6307 call throw_exception(FoX_INVALID_NODE, "createTextNode", ex) 6308 if (present(ex)) then 6309 if (inException(ex)) then 6310 return 6311 endif 6312 endif 6313endif 6314 6315 elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then 6316 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 6317 call throw_exception(FoX_INVALID_CHARACTER, "createTextNode", ex) 6318 if (present(ex)) then 6319 if (inException(ex)) then 6320 return 6321 endif 6322 endif 6323endif 6324 6325 endif 6326 6327 np => createNode(arg, TEXT_NODE, "#text", data) 6328 np%textContentLength = len(data) 6329 6330 if (getGCstate(arg)) then 6331 np%inDocument = .false. 6332 call append(arg%docExtras%hangingnodes, np) 6333 else 6334 np%inDocument = .true. 6335 endif 6336 6337 end function createTextNode 6338 6339 function createComment(arg, data, ex)result(np) 6340 type(DOMException), intent(out), optional :: ex 6341 type(Node), pointer :: arg 6342 character(len=*), intent(in) :: data 6343 type(Node), pointer :: np 6344 6345 if (.not.associated(arg)) then 6346 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6347 call throw_exception(FoX_NODE_IS_NULL, "createComment", ex) 6348 if (present(ex)) then 6349 if (inException(ex)) then 6350 return 6351 endif 6352 endif 6353endif 6354 6355 endif 6356 6357 if (arg%nodeType/=DOCUMENT_NODE) then 6358 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6359 call throw_exception(FoX_INVALID_NODE, "createComment", ex) 6360 if (present(ex)) then 6361 if (inException(ex)) then 6362 return 6363 endif 6364 endif 6365endif 6366 6367 elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then 6368 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 6369 call throw_exception(FoX_INVALID_CHARACTER, "createComment", ex) 6370 if (present(ex)) then 6371 if (inException(ex)) then 6372 return 6373 endif 6374 endif 6375endif 6376 6377 elseif (index(data,"--")>0) then 6378 if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then 6379 call throw_exception(FoX_INVALID_COMMENT, "createComment", ex) 6380 if (present(ex)) then 6381 if (inException(ex)) then 6382 return 6383 endif 6384 endif 6385endif 6386 6387 endif 6388 6389 np => createNode(arg, COMMENT_NODE, "#comment", data) 6390 np%textContentLength = len(data) 6391 6392 if (getGCstate(arg)) then 6393 np%inDocument = .false. 6394 call append(arg%docExtras%hangingnodes, np) 6395 else 6396 np%inDocument = .true. 6397 endif 6398 6399 end function createComment 6400 6401 function createCdataSection(arg, data, ex)result(np) 6402 type(DOMException), intent(out), optional :: ex 6403 type(Node), pointer :: arg 6404 character(len=*), intent(in) :: data 6405 type(Node), pointer :: np 6406 6407 if (.not.associated(arg)) then 6408 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6409 call throw_exception(FoX_NODE_IS_NULL, "createCdataSection", ex) 6410 if (present(ex)) then 6411 if (inException(ex)) then 6412 return 6413 endif 6414 endif 6415endif 6416 6417 endif 6418 6419 if (arg%nodeType/=DOCUMENT_NODE) then 6420 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6421 call throw_exception(FoX_INVALID_NODE, "createCdataSection", ex) 6422 if (present(ex)) then 6423 if (inException(ex)) then 6424 return 6425 endif 6426 endif 6427endif 6428 6429 elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then 6430 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 6431 call throw_exception(FoX_INVALID_CHARACTER, "createCdataSection", ex) 6432 if (present(ex)) then 6433 if (inException(ex)) then 6434 return 6435 endif 6436 endif 6437endif 6438 6439 elseif (index(data,"]]>")>0) then 6440 if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then 6441 call throw_exception(FoX_INVALID_CDATA_SECTION, "createCdataSection", ex) 6442 if (present(ex)) then 6443 if (inException(ex)) then 6444 return 6445 endif 6446 endif 6447endif 6448 6449 endif 6450 6451 np => createNode(arg, CDATA_SECTION_NODE, "#cdata-section", data) 6452 np%textContentLength = len(data) 6453 6454 if (getGCstate(arg)) then 6455 np%inDocument = .false. 6456 call append(arg%docExtras%hangingnodes, np) 6457 else 6458 np%inDocument = .true. 6459 endif 6460 6461 end function createCdataSection 6462 6463 function createProcessingInstruction(arg, target, data, ex)result(np) 6464 type(DOMException), intent(out), optional :: ex 6465 type(Node), pointer :: arg 6466 character(len=*), intent(in) :: target 6467 character(len=*), intent(in) :: data 6468 type(Node), pointer :: np 6469 6470 if (.not.associated(arg)) then 6471 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6472 call throw_exception(FoX_NODE_IS_NULL, "createProcessingInstruction", ex) 6473 if (present(ex)) then 6474 if (inException(ex)) then 6475 return 6476 endif 6477 endif 6478endif 6479 6480 endif 6481 6482 if (arg%nodeType/=DOCUMENT_NODE) then 6483 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6484 call throw_exception(FoX_INVALID_NODE, "createProcessingInstruction", ex) 6485 if (present(ex)) then 6486 if (inException(ex)) then 6487 return 6488 endif 6489 endif 6490endif 6491 6492 elseif (.not.checkName(target, getXmlVersionEnum(arg))) then 6493 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 6494 call throw_exception(INVALID_CHARACTER_ERR, "createProcessingInstruction", ex) 6495 if (present(ex)) then 6496 if (inException(ex)) then 6497 return 6498 endif 6499 endif 6500endif 6501 6502 elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then 6503 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 6504 call throw_exception(FoX_INVALID_CHARACTER, "createProcessingInstruction", ex) 6505 if (present(ex)) then 6506 if (inException(ex)) then 6507 return 6508 endif 6509 endif 6510endif 6511 6512 elseif (index(data,"?>")>0) then 6513 if (getFoX_checks().or.FoX_INVALID_PI_DATA<200) then 6514 call throw_exception(FoX_INVALID_PI_DATA, "createProcessingInstruction", ex) 6515 if (present(ex)) then 6516 if (inException(ex)) then 6517 return 6518 endif 6519 endif 6520endif 6521 6522 endif 6523 6524 np => createNode(arg, PROCESSING_INSTRUCTION_NODE, target, data) 6525 np%textContentLength = len(data) 6526 6527 if (getGCstate(arg)) then 6528 np%inDocument = .false. 6529 call append(arg%docExtras%hangingnodes, np) 6530 else 6531 np%inDocument = .true. 6532 endif 6533 6534 end function createProcessingInstruction 6535 6536 function createAttribute(arg, name, ex)result(np) 6537 type(DOMException), intent(out), optional :: ex 6538 type(Node), pointer :: arg 6539 character(len=*), intent(in) :: name 6540 type(Node), pointer :: np 6541 6542 if (.not.associated(arg)) then 6543 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6544 call throw_exception(FoX_NODE_IS_NULL, "createAttribute", ex) 6545 if (present(ex)) then 6546 if (inException(ex)) then 6547 return 6548 endif 6549 endif 6550endif 6551 6552 endif 6553 6554 if (arg%nodeType/=DOCUMENT_NODE) then 6555 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6556 call throw_exception(FoX_INVALID_NODE, "createAttribute", ex) 6557 if (present(ex)) then 6558 if (inException(ex)) then 6559 return 6560 endif 6561 endif 6562endif 6563 6564 elseif (.not.checkName(name, getXmlVersionEnum(arg))) then 6565 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 6566 call throw_exception(INVALID_CHARACTER_ERR, "createAttribute", ex) 6567 if (present(ex)) then 6568 if (inException(ex)) then 6569 return 6570 endif 6571 endif 6572endif 6573 6574 endif 6575 6576 np => createNode(arg, ATTRIBUTE_NODE, name, "") 6577 allocate(np%elExtras) 6578 np%elExtras%dom1 = .true. 6579 allocate(np%elExtras%namespaceURI(0)) 6580 allocate(np%elExtras%prefix(0)) 6581 allocate(np%elExtras%localname(0)) 6582 6583 if (getGCstate(arg)) then 6584 np%inDocument = .false. 6585 call append(arg%docExtras%hangingnodes, np) 6586 else 6587 np%inDocument = .true. 6588 endif 6589 6590 end function createAttribute 6591 6592 6593 recursive function createEntityReference(arg, name, ex)result(np) 6594 type(DOMException), intent(out), optional :: ex 6595 ! Needs to be recursive in case of entity-references within each other. 6596 type(Node), pointer :: arg 6597 character(len=*), intent(in) :: name 6598 type(Node), pointer :: np 6599 6600 type(Node), pointer :: ent, newNode 6601 integer :: i 6602 logical :: brokenNS 6603 6604 if (.not.associated(arg)) then 6605 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6606 call throw_exception(FoX_NODE_IS_NULL, "createEntityReference", ex) 6607 if (present(ex)) then 6608 if (inException(ex)) then 6609 return 6610 endif 6611 endif 6612endif 6613 6614 endif 6615 if (arg%nodeType/=DOCUMENT_NODE) then 6616 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6617 call throw_exception(FoX_INVALID_NODE, "createEntityReference", ex) 6618 if (present(ex)) then 6619 if (inException(ex)) then 6620 return 6621 endif 6622 endif 6623endif 6624 6625 elseif (.not.checkName(name, getXmlVersionEnum(arg))) then 6626 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 6627 call throw_exception(INVALID_CHARACTER_ERR, "createEntityReference", ex) 6628 if (present(ex)) then 6629 if (inException(ex)) then 6630 return 6631 endif 6632 endif 6633endif 6634 6635 endif 6636 6637 if (getXmlStandalone(arg).and..not.associated(getDocType(arg))) then 6638 if (getFoX_checks().or.FoX_NO_SUCH_ENTITY<200) then 6639 call throw_exception(FoX_NO_SUCH_ENTITY, "createEntityReference", ex) 6640 if (present(ex)) then 6641 if (inException(ex)) then 6642 return 6643 endif 6644 endif 6645endif 6646 6647 endif 6648 6649 np => createNode(arg, ENTITY_REFERENCE_NODE, name, "") 6650 if (getGCstate(arg)) then ! otherwise the parser will fill these nodes in itself 6651 if (associated(getDocType(arg))) then 6652 ent => getNamedItem(getEntities(getDocType(arg)), name) 6653 if (associated(ent)) then 6654 if (getIllFormed(ent)) then 6655 if (getFoX_checks().or.FoX_INVALID_ENTITY<200) then 6656 call throw_exception(FoX_INVALID_ENTITY, "createEntityReference", ex) 6657 if (present(ex)) then 6658 if (inException(ex)) then 6659 return 6660 endif 6661 endif 6662endif 6663 6664 endif 6665 brokenNS = arg%docExtras%brokenNS 6666 arg%docExtras%brokenNS = .true. ! We need to not worry about NS errors for a bit 6667 do i = 0, getLength(getChildNodes(ent)) - 1 6668 newNode => appendChild(np, cloneNode(item(getChildNodes(ent), i), .true., ex)) 6669 ! No namespace calcs here - wait for a namespace normalization 6670 call setReadOnlyNode(newNode, .true., .true.) 6671 enddo 6672 arg%docExtras%brokenNS = brokenNS ! FIXME also for all new default attributes 6673 elseif (getXmlStandalone(arg)) then 6674 if (getFoX_checks().or.FoX_NO_SUCH_ENTITY<200) then 6675 call throw_exception(FoX_NO_SUCH_ENTITY, "createEntityReference", ex) 6676 if (present(ex)) then 6677 if (inException(ex)) then 6678 6679 if (associated(np)) deallocate(np) 6680 return 6681 endif 6682 endif 6683endif 6684 6685 endif 6686 endif 6687 endif 6688 6689 call setReadOnlyNode(np, .true., .false.) 6690 6691 if (getGCstate(arg)) then 6692 np%inDocument = .false. 6693 call append_nl(arg%docExtras%hangingNodes, np) 6694 ! All child nodes were created outside the document by cloneNode above 6695 else 6696 np%inDocument = .true. 6697 endif 6698 6699 end function createEntityReference 6700 6701 function createEmptyEntityReference(arg, name, ex)result(np) 6702 type(DOMException), intent(out), optional :: ex 6703 type(Node), pointer :: arg 6704 character(len=*), intent(in) :: name 6705 type(Node), pointer :: np 6706 6707 if (.not.associated(arg)) then 6708 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6709 call throw_exception(FoX_NODE_IS_NULL, "createEmptyEntityReference", ex) 6710 if (present(ex)) then 6711 if (inException(ex)) then 6712 return 6713 endif 6714 endif 6715endif 6716 6717 endif 6718 6719 if (arg%nodeType/=DOCUMENT_NODE) then 6720 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6721 call throw_exception(FoX_INVALID_NODE, "createEmptyEntityReference", ex) 6722 if (present(ex)) then 6723 if (inException(ex)) then 6724 return 6725 endif 6726 endif 6727endif 6728 6729 elseif (.not.checkName(name, getXmlVersionEnum(arg))) then 6730 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 6731 call throw_exception(INVALID_CHARACTER_ERR, "createEmptyEntityReference", ex) 6732 if (present(ex)) then 6733 if (inException(ex)) then 6734 return 6735 endif 6736 endif 6737endif 6738 6739 endif 6740 6741 np => createNode(arg, ENTITY_REFERENCE_NODE, name, "") 6742 if (getGCstate(arg)) then 6743 np%inDocument = .false. 6744 call append(arg%docExtras%hangingnodes, np) 6745 else 6746 np%inDocument = .true. 6747 endif 6748 6749 end function createEmptyEntityReference 6750 6751 function getElementsByTagName(doc, tagName, name, ex)result(list) 6752 type(DOMException), intent(out), optional :: ex 6753 type(Node), pointer :: doc 6754 character(len=*), intent(in), optional :: tagName, name 6755 type(NodeList), pointer :: list 6756 6757 type(NodeListPtr), pointer :: nll(:), temp_nll(:) 6758 type(Node), pointer :: arg, this, treeroot 6759 logical :: doneChildren, doneAttributes, allElements 6760 integer :: i, i_tree 6761 6762 if (.not.associated(doc)) then 6763 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6764 call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagName", ex) 6765 if (present(ex)) then 6766 if (inException(ex)) then 6767 return 6768 endif 6769 endif 6770endif 6771 6772 endif 6773 6774 if (doc%nodeType==DOCUMENT_NODE) then 6775 if (present(name).or..not.present(tagName)) then 6776 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6777 call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) 6778 if (present(ex)) then 6779 if (inException(ex)) then 6780 return 6781 endif 6782 endif 6783endif 6784 6785 endif 6786 elseif (doc%nodeType==ELEMENT_NODE) then 6787 if (present(name).or..not.present(tagName)) then 6788 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6789 call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) 6790 if (present(ex)) then 6791 if (inException(ex)) then 6792 return 6793 endif 6794 endif 6795endif 6796 6797 endif 6798 else 6799 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6800 call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) 6801 if (present(ex)) then 6802 if (inException(ex)) then 6803 return 6804 endif 6805 endif 6806endif 6807 6808 endif 6809 6810 if (doc%nodeType==DOCUMENT_NODE) then 6811 arg => getDocumentElement(doc) 6812 else 6813 arg => doc 6814 endif 6815 6816 allocate(list) 6817 allocate(list%nodes(0)) 6818 list%element => doc 6819 if (present(name)) list%nodeName => vs_str_alloc(name) 6820 if (present(tagName)) list%nodeName => vs_str_alloc(tagName) 6821 6822 allElements = (str_vs(list%nodeName)=="*") 6823 6824 if (doc%nodeType==DOCUMENT_NODE) then 6825 nll => doc%docExtras%nodelists 6826 elseif (doc%nodeType==ELEMENT_NODE) then 6827 nll => doc%ownerDocument%docExtras%nodelists 6828 endif 6829 allocate(temp_nll(size(nll)+1)) 6830 do i = 1, size(nll) 6831 temp_nll(i)%this => nll(i)%this 6832 enddo 6833 temp_nll(i)%this => list 6834 deallocate(nll) 6835 if (doc%nodeType==DOCUMENT_NODE) then 6836 doc%docExtras%nodelists => temp_nll 6837 elseif (doc%nodeType==ELEMENT_NODE) then 6838 doc%ownerDocument%docExtras%nodelists => temp_nll 6839 endif 6840 6841 treeroot => arg 6842 6843 i_tree = 0 6844 doneChildren = .false. 6845 doneAttributes = .false. 6846 this => treeroot 6847 do 6848 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 6849 if (this%nodeType==ELEMENT_NODE) then 6850 if ((allElements .or. str_vs(this%nodeName)==tagName) & 6851 .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & 6852 call append(list, this) 6853 doneAttributes = .true. 6854 endif 6855 6856 else 6857 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 6858 doneAttributes = .true. 6859 else 6860 6861 endif 6862 endif 6863 6864 6865 if (.not.doneChildren) then 6866 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 6867 if (getLength(getAttributes(this))>0) then 6868 this => item(getAttributes(this), 0) 6869 else 6870 doneAttributes = .true. 6871 endif 6872 elseif (hasChildNodes(this)) then 6873 this => getFirstChild(this) 6874 doneChildren = .false. 6875 doneAttributes = .false. 6876 else 6877 doneChildren = .true. 6878 doneAttributes = .false. 6879 endif 6880 6881 else ! if doneChildren 6882 6883 if (associated(this, treeroot)) exit 6884 if (getNodeType(this)==ATTRIBUTE_NODE) then 6885 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 6886 i_tree= i_tree+ 1 6887 this => item(getAttributes(getOwnerElement(this)), i_tree) 6888 doneChildren = .false. 6889 else 6890 i_tree= 0 6891 this => getOwnerElement(this) 6892 doneAttributes = .true. 6893 doneChildren = .false. 6894 endif 6895 elseif (associated(getNextSibling(this))) then 6896 6897 this => getNextSibling(this) 6898 doneChildren = .false. 6899 doneAttributes = .false. 6900 else 6901 this => getParentNode(this) 6902 endif 6903 endif 6904 6905 enddo 6906 6907 6908 6909 end function getElementsByTagName 6910 6911 function importNode(doc , arg, deep , ex)result(np) 6912 type(DOMException), intent(out), optional :: ex 6913 type(Node), pointer :: doc 6914 type(Node), pointer :: arg 6915 logical, intent(in) :: deep 6916 type(Node), pointer :: np 6917 6918 type(Node), pointer :: this, thatParent, new, treeroot 6919 type(xml_doc_state), pointer :: xds 6920 type(element_t), pointer :: elem 6921 type(attribute_t), pointer :: att 6922 logical :: doneAttributes, doneChildren, brokenNS 6923 integer :: i_tree 6924 6925 if (.not.associated(doc).or..not.associated(arg)) then 6926 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 6927 call throw_exception(FoX_NODE_IS_NULL, "importNode", ex) 6928 if (present(ex)) then 6929 if (inException(ex)) then 6930 return 6931 endif 6932 endif 6933endif 6934 6935 endif 6936 6937 if (getNodeType(doc)/=DOCUMENT_NODE) then 6938 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 6939 call throw_exception(FoX_INVALID_NODE, "importNode", ex) 6940 if (present(ex)) then 6941 if (inException(ex)) then 6942 return 6943 endif 6944 endif 6945endif 6946 6947 elseif (getNodeType(arg)==DOCUMENT_NODE .or. & 6948 getNodeType(arg)==DOCUMENT_TYPE_NODE) then 6949 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 6950 call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) 6951 if (present(ex)) then 6952 if (inException(ex)) then 6953 return 6954 endif 6955 endif 6956endif 6957 6958 endif 6959 brokenNS = doc%docExtras%brokenNS 6960 doc%docExtras%brokenNS = .true. ! We need to do stupid NS things 6961 xds => getXds(doc) 6962 thatParent => null() 6963 treeroot => arg 6964 6965 i_tree = 0 6966 doneChildren = .false. 6967 doneAttributes = .false. 6968 this => treeroot 6969 do 6970 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 6971 6972 6973 new => null() 6974 select case (getNodeType(this, ex)) 6975 case (ELEMENT_NODE) 6976 if (.not.doneAttributes) then 6977 ! We dont create an empty node - we insist on having all default 6978 ! properties created. 6979 if (getParameter(getDomConfig(doc, ex), "namespaces", ex)) then 6980 new => createElementNS(doc, getNamespaceURI(this, ex), getTagName(this, ex), ex) 6981 else 6982 new => createElement(doc, getTagName(this, ex), ex) 6983 endif 6984 endif 6985 case (ATTRIBUTE_NODE) 6986 if (associated(this, arg).or.getSpecified(this, ex)) then 6987 ! We are importing just this attribute node 6988 ! or this was an explicitly specified attribute; either 6989 ! way, we import it as is, and it remains specified. 6990 if (getParameter(getDomConfig(doc), "namespaces")) then 6991 new => createAttributeNS(doc, getNamespaceURI(this, ex), getName(this, ex), ex) 6992 else 6993 new => createAttribute(doc, getName(this), ex) 6994 endif 6995 call setSpecified(new, .true.) 6996 else 6997 ! This is an attribute being imported as part of a hierarchy, 6998 ! but its only here by default. Is there a default attribute 6999 ! of this name in the new document? 7000 elem => get_element(xds%element_list, & 7001 getTagName(getOwnerElement(this))) 7002 att => get_attribute_declaration(elem, getName(this)) 7003 if (attribute_has_default(att)) then 7004 ! Create the new default: 7005 if (getParameter(getDomConfig(doc, ex), "namespaces", ex)) then 7006 ! We create a namespaced attribute. Of course, its 7007 ! namespaceURI remains empty for the moment unless we know it ... 7008 if (prefixOfQName(getName(this, ex))=="xml") then 7009 new => createAttributeNS(doc, & 7010 "http://www.w3.org/XML/1998/namespace", & 7011 getName(this, ex), ex) 7012 elseif (getName(this, ex)=="xmlns" & 7013 .or. prefixOfQName(getName(this, ex))=="xmlns") then 7014 new => createAttributeNS(doc, & 7015 "http://www.w3.org/2000/xmlns/", & 7016 getName(this, ex), ex) 7017 else 7018 ! Wait for namespace fixup ... 7019 new => createAttributeNS(doc, "", & 7020 getName(this, ex), ex) 7021 endif 7022 else 7023 new => createAttribute(doc, getName(this, ex), ex) 7024 endif 7025 call setValue(new, str_vs(att%default), ex) 7026 call setSpecified(new, .false.) 7027 endif 7028 ! In any case, we dont want to copy the children of this node. 7029 doneChildren=.true. 7030 endif 7031 case (TEXT_NODE) 7032 new => createTextNode(doc, getData(this, ex), ex) 7033 case (CDATA_SECTION_NODE) 7034 new => createCDataSection(doc, getData(this, ex), ex) 7035 case (ENTITY_REFERENCE_NODE) 7036 new => createEntityReference(doc, getNodeName(this, ex), ex) 7037 ! This will automatically populate the entity reference if doc defines it, so no children needed 7038 doneChildren = .true. 7039 case (ENTITY_NODE) 7040 new => createEntity(doc, getNodeName(this, ex), & 7041 getPublicId(this, ex), getSystemId(this, ex), & 7042 getNotationName(this, ex), ex) 7043 case (PROCESSING_INSTRUCTION_NODE) 7044 new => createProcessingInstruction(doc, & 7045 getTarget(this, ex), getData(this, ex), ex) 7046 case (COMMENT_NODE) 7047 new => createComment(doc, getData(this, ex), ex) 7048 case (DOCUMENT_NODE) 7049 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 7050 call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) 7051 if (present(ex)) then 7052 if (inException(ex)) then 7053 return 7054 endif 7055 endif 7056endif 7057 7058 case (DOCUMENT_TYPE_NODE) 7059 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 7060 call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) 7061 if (present(ex)) then 7062 if (inException(ex)) then 7063 return 7064 endif 7065 endif 7066endif 7067 7068 case (DOCUMENT_FRAGMENT_NODE) 7069 new => createDocumentFragment(doc, ex) 7070 case (NOTATION_NODE) 7071 new => createNotation(doc, getNodeName(this, ex), & 7072 getPublicId(this, ex), getSystemId(this, ex), ex) 7073 end select 7074 7075 if (.not.associated(thatParent)) then 7076 thatParent => new 7077 elseif (associated(new)) then 7078 if (getNodeType(this, ex)==ATTRIBUTE_NODE) then 7079 new => setAttributeNode(thatParent, new, ex) 7080 else 7081 new => appendChild(thatParent, new, ex) 7082 endif 7083 endif 7084 7085 if (.not.deep) then 7086 if (getNodeType(arg, ex)==ATTRIBUTE_NODE & 7087 .or.getNodeType(arg, ex)==ELEMENT_NODE) then 7088 continue 7089 else 7090 exit 7091 endif 7092 endif 7093 7094 else 7095 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 7096 doneAttributes = .true. 7097 else 7098 7099 endif 7100 endif 7101 7102 7103 if (.not.doneChildren) then 7104 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 7105 if (getLength(getAttributes(this))>0) then 7106 if (.not.associated(this, treeroot)) thatParent => getLastChild(thatParent) 7107 this => item(getAttributes(this), 0) 7108 else 7109 if (.not.deep) exit 7110 doneAttributes = .true. 7111 endif 7112 elseif (hasChildNodes(this)) then 7113 if (getNodeType(this)==ELEMENT_NODE.and..not.deep) exit 7114 if (.not.associated(this, treeroot)) then 7115 if (getNodeType(this)==ATTRIBUTE_NODE) then 7116 thatParent => item(getAttributes(thatParent), i_tree) 7117 else 7118 thatParent => getLastChild(thatParent) 7119 endif 7120 endif 7121 this => getFirstChild(this) 7122 doneChildren = .false. 7123 doneAttributes = .false. 7124 else 7125 doneChildren = .true. 7126 doneAttributes = .false. 7127 endif 7128 7129 else ! if doneChildren 7130 7131 if (associated(this, treeroot)) exit 7132 if (getNodeType(this)==ATTRIBUTE_NODE) then 7133 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 7134 i_tree= i_tree+ 1 7135 this => item(getAttributes(getOwnerElement(this)), i_tree) 7136 doneChildren = .false. 7137 else 7138 i_tree= 0 7139 if (associated(getParentNode(thatParent))) thatParent => getParentNode(thatParent) 7140 this => getOwnerElement(this) 7141 doneAttributes = .true. 7142 doneChildren = .false. 7143 endif 7144 elseif (associated(getNextSibling(this))) then 7145 7146 this => getNextSibling(this) 7147 doneChildren = .false. 7148 doneAttributes = .false. 7149 else 7150 this => getParentNode(this) 7151 if (.not.associated(this, treeroot)) then 7152 if (getNodeType(this)==ATTRIBUTE_NODE) then 7153 thatParent => getOwnerElement(thatParent) 7154 else 7155 thatParent => getParentNode(thatParent) 7156 endif 7157 endif 7158 endif 7159 endif 7160 7161 enddo 7162 7163 7164 7165 np => thatParent 7166 doc%docExtras%brokenNS = brokenNS 7167! call namespaceFixup(np) 7168 7169 end function importNode 7170 7171 function createElementNS(arg, namespaceURI, qualifiedName, ex)result(np) 7172 type(DOMException), intent(out), optional :: ex 7173 type(Node), pointer :: arg 7174 character(len=*), intent(in) :: namespaceURI, qualifiedName 7175 type(Node), pointer :: np 7176 7177 type(xml_doc_state), pointer :: xds 7178 type(element_t), pointer :: elem 7179 type(attribute_t), pointer :: att 7180 integer :: i 7181 logical :: brokenNS 7182 type(URI), pointer :: URIref 7183 7184 if (.not.associated(arg)) then 7185 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7186 call throw_exception(FoX_NODE_IS_NULL, "createElementNS", ex) 7187 if (present(ex)) then 7188 if (inException(ex)) then 7189 return 7190 endif 7191 endif 7192endif 7193 7194 endif 7195 7196 if (arg%nodeType/=DOCUMENT_NODE) then 7197 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7198 call throw_exception(FoX_INVALID_NODE, "createElementNS", ex) 7199 if (present(ex)) then 7200 if (inException(ex)) then 7201 return 7202 endif 7203 endif 7204endif 7205 7206 elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then 7207 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 7208 call throw_exception(INVALID_CHARACTER_ERR, "createElementNS", ex) 7209 if (present(ex)) then 7210 if (inException(ex)) then 7211 return 7212 endif 7213 endif 7214endif 7215 7216 elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then 7217 if (getFoX_checks().or.NAMESPACE_ERR<200) then 7218 call throw_exception(NAMESPACE_ERR, "createElementNS", ex) 7219 if (present(ex)) then 7220 if (inException(ex)) then 7221 return 7222 endif 7223 endif 7224endif 7225 7226 elseif (prefixOfQName(qualifiedName)/="" & 7227 .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then 7228 if (getFoX_checks().or.NAMESPACE_ERR<200) then 7229 call throw_exception(NAMESPACE_ERR, "createElementNS", ex) 7230 if (present(ex)) then 7231 if (inException(ex)) then 7232 return 7233 endif 7234 endif 7235endif 7236 7237 elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & 7238 prefixOfQName(qualifiedName)=="xml") then 7239 if (getFoX_checks().or.NAMESPACE_ERR<200) then 7240 call throw_exception(NAMESPACE_ERR, "createElementNS", ex) 7241 if (present(ex)) then 7242 if (inException(ex)) then 7243 return 7244 endif 7245 endif 7246endif 7247 7248 elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then 7249 if (getFoX_checks().or.NAMESPACE_ERR<200) then 7250 call throw_exception(NAMESPACE_ERR, "createElementNS", ex) 7251 if (present(ex)) then 7252 if (inException(ex)) then 7253 return 7254 endif 7255 endif 7256endif 7257 7258 endif 7259 7260 URIref => parseURI(namespaceURI) 7261 if (.not.associated(URIref)) then 7262 if (getFoX_checks().or.FoX_INVALID_URI<200) then 7263 call throw_exception(FoX_INVALID_URI, "createElementNS", ex) 7264 if (present(ex)) then 7265 if (inException(ex)) then 7266 return 7267 endif 7268 endif 7269endif 7270 7271 endif 7272 call destroyURI(URIref) 7273 7274 np => createNode(arg, ELEMENT_NODE, qualifiedName, "") 7275 allocate(np%elExtras) 7276 np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) 7277 np%elExtras%prefix => vs_str_alloc(prefixOfQName(qualifiedname)) 7278 np%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) 7279 allocate(np%elExtras%namespaceNodes%nodes(0)) 7280 7281 np%elExtras%attributes%ownerElement => np 7282 if (getGCstate(arg)) then 7283 np%inDocument = .false. 7284 call append(arg%docExtras%hangingnodes, np) 7285 ! We only add default attributes if we are *not* building the doc 7286 xds => getXds(arg) 7287 elem => get_element(xds%element_list, qualifiedName) 7288 if (associated(elem)) then 7289 do i = 1, get_attlist_size(elem) 7290 att => get_attribute_declaration(elem, i) 7291 if (attribute_has_default(att)) then 7292 ! Since this is a namespaced function, we create a namespaced 7293 ! attribute. Of course, its namespaceURI remains empty 7294 ! for the moment unless we know it ... 7295 if (prefixOfQName(str_vs(att%name))=="xml") then 7296 call setAttributeNS(np, & 7297 "http://www.w3.org/XML/1998/namespace", & 7298 str_vs(att%name), str_vs(att%default), ex) 7299 elseif (str_vs(att%name)=="xmlns" & 7300 .or. prefixOfQName(str_vs(att%name))=="xmlns") then 7301 call setAttributeNS(np, & 7302 "http://www.w3.org/2000/xmlns/", & 7303 str_vs(att%name), str_vs(att%default), ex) 7304 else 7305 ! Wait for namespace fixup ... 7306 brokenNS = arg%docExtras%brokenNS 7307 arg%docExtras%brokenNS = .true. 7308 call setAttributeNS(np, "", str_vs(att%name), & 7309 str_vs(att%default), ex) 7310 arg%docExtras%brokenNS = brokenNS 7311 endif 7312 endif 7313 enddo 7314 endif 7315 else 7316 np%inDocument = .true. 7317 endif 7318 7319 end function createElementNS 7320 7321 function createEmptyElementNS(arg, namespaceURI, qualifiedName, ex)result(np) 7322 type(DOMException), intent(out), optional :: ex 7323 type(Node), pointer :: arg 7324 character(len=*), intent(in) :: namespaceURI, qualifiedName 7325 type(Node), pointer :: np 7326 7327! NO CHECKS ! 7328 7329 np => createNode(arg, ELEMENT_NODE, qualifiedName, "") 7330 allocate(np%elExtras) 7331 np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) 7332 np%elExtras%prefix => vs_str_alloc(prefixOfQName(qualifiedname)) 7333 np%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) 7334 allocate(np%elExtras%namespaceNodes%nodes(0)) 7335 7336 np%elExtras%attributes%ownerElement => np 7337 7338 if (getGCstate(arg)) then 7339 call append(arg%docExtras%hangingnodes, np) 7340 np%inDocument = .false. 7341 else 7342 np%inDocument = .true. 7343 endif 7344 end function createEmptyElementNS 7345 7346 function createAttributeNS(arg, namespaceURI, qualifiedname, ex)result(np) 7347 type(DOMException), intent(out), optional :: ex 7348 type(Node), pointer :: arg 7349 character(len=*), intent(in) :: namespaceURI, qualifiedName 7350 type(Node), pointer :: np 7351 7352 type(URI), pointer :: URIref 7353 7354 if (.not.associated(arg)) then 7355 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7356 call throw_exception(FoX_NODE_IS_NULL, "createAttributeNS", ex) 7357 if (present(ex)) then 7358 if (inException(ex)) then 7359 return 7360 endif 7361 endif 7362endif 7363 7364 endif 7365 7366 if (arg%nodeType/=DOCUMENT_NODE) then 7367 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7368 call throw_exception(FoX_INVALID_NODE, "createAttributeNS", ex) 7369 if (present(ex)) then 7370 if (inException(ex)) then 7371 return 7372 endif 7373 endif 7374endif 7375 7376 elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then 7377 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 7378 call throw_exception(INVALID_CHARACTER_ERR, "createAttributeNS", ex) 7379 if (present(ex)) then 7380 if (inException(ex)) then 7381 return 7382 endif 7383 endif 7384endif 7385 7386 elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then 7387 if (getFoX_checks().or.NAMESPACE_ERR<200) then 7388 call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) 7389 if (present(ex)) then 7390 if (inException(ex)) then 7391 return 7392 endif 7393 endif 7394endif 7395 7396 elseif (prefixOfQName(qualifiedName)/="" & 7397 .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then 7398 if (getFoX_checks().or.NAMESPACE_ERR<200) then 7399 call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) 7400 if (present(ex)) then 7401 if (inException(ex)) then 7402 return 7403 endif 7404 endif 7405endif 7406 7407 elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & 7408 prefixOfQName(qualifiedName)=="xml") then 7409 if (getFoX_checks().or.NAMESPACE_ERR<200) then 7410 call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) 7411 if (present(ex)) then 7412 if (inException(ex)) then 7413 return 7414 endif 7415 endif 7416endif 7417 7418 elseif (namespaceURI=="http://www.w3.org/2000/xmlns/" .neqv. & 7419 (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns")) then 7420 if (getFoX_checks().or.NAMESPACE_ERR<200) then 7421 call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) 7422 if (present(ex)) then 7423 if (inException(ex)) then 7424 return 7425 endif 7426 endif 7427endif 7428 7429 endif 7430 7431 URIref => parseURI(namespaceURI) 7432 if (.not.associated(URIref)) then 7433 if (getFoX_checks().or.FoX_INVALID_URI<200) then 7434 call throw_exception(FoX_INVALID_URI, "createAttributeNS", ex) 7435 if (present(ex)) then 7436 if (inException(ex)) then 7437 return 7438 endif 7439 endif 7440endif 7441 7442 endif 7443 call destroyURI(URIref) 7444 7445 7446 np => createNode(arg, ATTRIBUTE_NODE, qualifiedName, "") 7447 allocate(np%elExtras) 7448 np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) 7449 np%elExtras%localname => vs_str_alloc(localPartofQName(qualifiedname)) 7450 np%elExtras%prefix => vs_str_alloc(PrefixofQName(qualifiedname)) 7451 7452 if (getGCstate(arg)) then 7453 np%inDocument = .false. 7454 call append(arg%docExtras%hangingnodes, np) 7455 else 7456 np%inDocument = .true. 7457 endif 7458 7459 end function createAttributeNS 7460 7461 function getElementsByTagNameNS(doc, namespaceURI, localName, ex)result(list) 7462 type(DOMException), intent(out), optional :: ex 7463 type(Node), pointer :: doc 7464 character(len=*), intent(in) :: namespaceURI, localName 7465 type(NodeList), pointer :: list 7466 7467 type(NodeListPtr), pointer :: nll(:), temp_nll(:) 7468 type(Node), pointer :: this, arg, treeroot 7469 logical :: doneChildren, doneAttributes, allLocalNames, allNameSpaces 7470 integer :: i, i_tree 7471 7472 if (.not.associated(doc)) then 7473 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7474 call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagNameNS", ex) 7475 if (present(ex)) then 7476 if (inException(ex)) then 7477 return 7478 endif 7479 endif 7480endif 7481 7482 endif 7483 7484 if (doc%nodeType/=DOCUMENT_NODE.and.doc%nodeType/=ELEMENT_NODE) then 7485 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7486 call throw_exception(FoX_INVALID_NODE, "getElementsByTagNameNS", ex) 7487 if (present(ex)) then 7488 if (inException(ex)) then 7489 return 7490 endif 7491 endif 7492endif 7493 7494 endif 7495 7496 allNamespaces = (namespaceURI=="*") 7497 allLocalNames = (localName=="*") 7498 7499 if (doc%nodeType==DOCUMENT_NODE) then 7500 arg => getDocumentElement(doc) 7501 else 7502 arg => doc 7503 endif 7504 7505 allocate(list) 7506 allocate(list%nodes(0)) 7507 list%element => doc 7508 list%localName => vs_str_alloc(localName) 7509 list%namespaceURI => vs_str_alloc(namespaceURI) 7510 7511 if (doc%nodeType==DOCUMENT_NODE) then 7512 nll => doc%docExtras%nodelists 7513 elseif (doc%nodeType==ELEMENT_NODE) then 7514 nll => doc%ownerDocument%docExtras%nodelists 7515 endif 7516 allocate(temp_nll(size(nll)+1)) 7517 do i = 1, size(nll) 7518 temp_nll(i)%this => nll(i)%this 7519 enddo 7520 temp_nll(i)%this => list 7521 deallocate(nll) 7522 if (doc%nodeType==DOCUMENT_NODE) then 7523 doc%docExtras%nodelists => temp_nll 7524 elseif (doc%nodeType==ELEMENT_NODE) then 7525 doc%ownerDocument%docExtras%nodelists => temp_nll 7526 endif 7527 7528 treeroot => arg 7529 7530 i_tree = 0 7531 doneChildren = .false. 7532 doneAttributes = .false. 7533 this => treeroot 7534 do 7535 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 7536 7537 if (getNodeType(this)==ELEMENT_NODE) then 7538 if (getNamespaceURI(this)/="") then 7539 if ((allNameSpaces .or. getNameSpaceURI(this)==namespaceURI) & 7540 .and. (allLocalNames .or. getLocalName(this)==localName) & 7541 .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & 7542 call append(list, this) 7543 else 7544 if ((allNameSpaces .or. namespaceURI=="") & 7545 .and. (allLocalNames .or. getNodeName(this)==localName) & 7546 .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & 7547 call append(list, this) 7548 endif 7549 doneAttributes = .true. ! Never search attributes 7550 endif 7551 7552 else 7553 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 7554 doneAttributes = .true. 7555 else 7556 7557 endif 7558 endif 7559 7560 7561 if (.not.doneChildren) then 7562 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 7563 if (getLength(getAttributes(this))>0) then 7564 this => item(getAttributes(this), 0) 7565 else 7566 doneAttributes = .true. 7567 endif 7568 elseif (hasChildNodes(this)) then 7569 this => getFirstChild(this) 7570 doneChildren = .false. 7571 doneAttributes = .false. 7572 else 7573 doneChildren = .true. 7574 doneAttributes = .false. 7575 endif 7576 7577 else ! if doneChildren 7578 7579 if (associated(this, treeroot)) exit 7580 if (getNodeType(this)==ATTRIBUTE_NODE) then 7581 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 7582 i_tree= i_tree+ 1 7583 this => item(getAttributes(getOwnerElement(this)), i_tree) 7584 doneChildren = .false. 7585 else 7586 i_tree= 0 7587 this => getOwnerElement(this) 7588 doneAttributes = .true. 7589 doneChildren = .false. 7590 endif 7591 elseif (associated(getNextSibling(this))) then 7592 7593 this => getNextSibling(this) 7594 doneChildren = .false. 7595 doneAttributes = .false. 7596 else 7597 this => getParentNode(this) 7598 endif 7599 endif 7600 7601 enddo 7602 7603 7604 7605 end function getElementsByTagNameNS 7606 7607 7608 function getElementById(arg, elementId, ex)result(np) 7609 type(DOMException), intent(out), optional :: ex 7610 type(Node), pointer :: arg 7611 character(len=*), intent(in) :: elementId 7612 type(Node), pointer :: np 7613 7614 type(Node), pointer :: this, treeroot 7615 integer :: i_tree 7616 logical :: doneChildren, doneAttributes 7617 7618 if (.not.associated(arg)) then 7619 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7620 call throw_exception(FoX_NODE_IS_NULL, "getElementById", ex) 7621 if (present(ex)) then 7622 if (inException(ex)) then 7623 return 7624 endif 7625 endif 7626endif 7627 7628 endif 7629 7630 if (arg%nodeType/=DOCUMENT_NODE) then 7631 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7632 call throw_exception(FoX_INVALID_NODE, "getElementById", ex) 7633 if (present(ex)) then 7634 if (inException(ex)) then 7635 return 7636 endif 7637 endif 7638endif 7639 7640 endif 7641 7642 np => null() 7643 treeroot => getDocumentElement(arg) 7644 7645 i_tree = 0 7646 doneChildren = .false. 7647 doneAttributes = .false. 7648 this => treeroot 7649 do 7650 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 7651 if (this%nodeType==ATTRIBUTE_NODE) then 7652 if (getIsId(this).and.getValue(this)==elementId) then 7653 np => getOwnerElement(this) 7654 return 7655 endif 7656 endif 7657 7658 else 7659 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 7660 doneAttributes = .true. 7661 else 7662 7663 endif 7664 endif 7665 7666 7667 if (.not.doneChildren) then 7668 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 7669 if (getLength(getAttributes(this))>0) then 7670 this => item(getAttributes(this), 0) 7671 else 7672 doneAttributes = .true. 7673 endif 7674 elseif (hasChildNodes(this)) then 7675 this => getFirstChild(this) 7676 doneChildren = .false. 7677 doneAttributes = .false. 7678 else 7679 doneChildren = .true. 7680 doneAttributes = .false. 7681 endif 7682 7683 else ! if doneChildren 7684 7685 if (associated(this, treeroot)) exit 7686 if (getNodeType(this)==ATTRIBUTE_NODE) then 7687 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 7688 i_tree= i_tree+ 1 7689 this => item(getAttributes(getOwnerElement(this)), i_tree) 7690 doneChildren = .false. 7691 else 7692 i_tree= 0 7693 this => getOwnerElement(this) 7694 doneAttributes = .true. 7695 doneChildren = .false. 7696 endif 7697 elseif (associated(getNextSibling(this))) then 7698 7699 this => getNextSibling(this) 7700 doneChildren = .false. 7701 doneAttributes = .false. 7702 else 7703 this => getParentNode(this) 7704 endif 7705 endif 7706 7707 enddo 7708 7709 7710 7711 end function getElementById 7712 7713function getxmlStandalone(np, ex)result(c) 7714 type(DOMException), intent(out), optional :: ex 7715 type(Node), pointer :: np 7716 logical :: c 7717 7718 7719 if (.not.associated(np)) then 7720 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7721 call throw_exception(FoX_NODE_IS_NULL, "getxmlStandalone", ex) 7722 if (present(ex)) then 7723 if (inException(ex)) then 7724 return 7725 endif 7726 endif 7727endif 7728 7729 endif 7730 7731 if (getNodeType(np)/=DOCUMENT_NODE .and. & 7732 .true.) then 7733 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7734 call throw_exception(FoX_INVALID_NODE, "getxmlStandalone", ex) 7735 if (present(ex)) then 7736 if (inException(ex)) then 7737 return 7738 endif 7739 endif 7740endif 7741 7742 endif 7743 7744 c = np%docExtras%xds%standalone 7745 7746 end function getxmlStandalone 7747 7748subroutine setxmlStandalone(np, c, ex) 7749 type(DOMException), intent(out), optional :: ex 7750 type(Node), pointer :: np 7751 logical :: c 7752 7753 7754 if (.not.associated(np)) then 7755 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7756 call throw_exception(FoX_NODE_IS_NULL, "setxmlStandalone", ex) 7757 if (present(ex)) then 7758 if (inException(ex)) then 7759 return 7760 endif 7761 endif 7762endif 7763 7764 endif 7765 7766 if (getNodeType(np)/=DOCUMENT_NODE .and. & 7767 .true.) then 7768 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7769 call throw_exception(FoX_INVALID_NODE, "setxmlStandalone", ex) 7770 if (present(ex)) then 7771 if (inException(ex)) then 7772 return 7773 endif 7774 endif 7775endif 7776 7777 endif 7778 7779 np%docExtras%xds%standalone = c 7780 7781 end subroutine setxmlStandalone 7782 7783! FIXME additional check on setting - do we have any undefined entrefs present? 7784 7785 function getXmlVersion(arg, ex)result(s) 7786 type(DOMException), intent(out), optional :: ex 7787 type(Node), pointer :: arg 7788 character(len=3) :: s 7789 7790 if (.not.associated(arg)) then 7791 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7792 call throw_exception(FoX_NODE_IS_NULL, "getXmlVersion", ex) 7793 if (present(ex)) then 7794 if (inException(ex)) then 7795 return 7796 endif 7797 endif 7798endif 7799 7800 endif 7801 7802 if (arg%nodeType/=DOCUMENT_NODE & 7803 .and.arg%nodeType/=ENTITY_NODE) then 7804 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7805 call throw_exception(FoX_INVALID_NODE, "getXmlVersion", ex) 7806 if (present(ex)) then 7807 if (inException(ex)) then 7808 return 7809 endif 7810 endif 7811endif 7812 7813 endif 7814 7815 if (getXmlVersionEnum(arg)==XML1_0) then 7816 s = "1.0" 7817 elseif (getXmlVersionEnum(arg)==XML1_1) then 7818 s = "1.1" 7819 else 7820 s = "XXX" 7821 endif 7822 7823 end function getXmlVersion 7824 7825 subroutine setXmlVersion(arg, s, ex) 7826 type(DOMException), intent(out), optional :: ex 7827 type(Node), pointer :: arg 7828 character(len=*) :: s 7829 7830 if (.not.associated(arg)) then 7831 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7832 call throw_exception(FoX_NODE_IS_NULL, "setXmlVersion", ex) 7833 if (present(ex)) then 7834 if (inException(ex)) then 7835 return 7836 endif 7837 endif 7838endif 7839 7840 endif 7841 7842 if (arg%nodeType/=DOCUMENT_NODE) then 7843 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7844 call throw_exception(FoX_INVALID_NODE, "setXmlVersion", ex) 7845 if (present(ex)) then 7846 if (inException(ex)) then 7847 return 7848 endif 7849 endif 7850endif 7851 7852 endif 7853 7854 if (s=="1.0") then 7855 arg%docExtras%xds%xml_version = XML1_0 7856 elseif (s=="1.1") then 7857 arg%docExtras%xds%xml_version = XML1_1 7858 else 7859 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 7860 call throw_exception(NOT_SUPPORTED_ERR, "setXmlVersion", ex) 7861 if (present(ex)) then 7862 if (inException(ex)) then 7863 return 7864 endif 7865 endif 7866endif 7867 7868 endif 7869 7870 end subroutine setXmlVersion 7871 7872 pure function getXmlEncoding_len(arg, p) result(n) 7873 type(Node), pointer :: arg 7874 logical, intent(in) :: p 7875 integer :: n 7876 7877 n = 0 7878 if (.not.p) return 7879 if (arg%nodeType==DOCUMENT_NODE) & 7880 n = size(arg%docExtras%xds%encoding) 7881 end function getXmlEncoding_len 7882 7883 function getXmlEncoding(arg, ex)result(s) 7884 type(DOMException), intent(out), optional :: ex 7885 type(Node), pointer :: arg 7886#ifdef RESTRICTED_ASSOCIATED_BUG 7887 character(len=getXmlEncoding_len(arg, .true.)) :: s 7888#else 7889 character(len=getXmlEncoding_len(arg, associated(arg))) :: s 7890#endif 7891 7892 if (.not.associated(arg)) then 7893 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7894 call throw_exception(FoX_NODE_IS_NULL, "getXmlEncoding", ex) 7895 if (present(ex)) then 7896 if (inException(ex)) then 7897 return 7898 endif 7899 endif 7900endif 7901 7902 endif 7903 7904 if (arg%nodeType==DOCUMENT_NODE) then 7905 s = str_vs(arg%docExtras%xds%encoding) 7906 elseif (arg%nodeType==ENTITY_NODE) then 7907 s = "" !FIXME revisit when we have working external entities 7908 else 7909 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7910 call throw_exception(FoX_INVALID_NODE, "getXmlEncoding", ex) 7911 if (present(ex)) then 7912 if (inException(ex)) then 7913 return 7914 endif 7915 endif 7916endif 7917 7918 endif 7919 7920 end function getXmlEncoding 7921 7922 pure function getInputEncoding_len(arg, p) result(n) 7923 type(Node), pointer :: arg 7924 logical, intent(in) :: p 7925 integer :: n 7926 7927 n = 0 7928 if (.not.p) return 7929 if (arg%nodeType==DOCUMENT_NODE) & 7930 n = size(arg%docExtras%xds%inputEncoding) 7931 end function getInputEncoding_len 7932 7933 function getInputEncoding(arg, ex)result(s) 7934 type(DOMException), intent(out), optional :: ex 7935 type(Node), pointer :: arg 7936#ifdef RESTRICTED_ASSOCIATED_BUG 7937 character(len=getInputEncoding_len(arg, .true.)) :: s 7938#else 7939 character(len=getInputEncoding_len(arg, associated(arg))) :: s 7940#endif 7941 7942 if (.not.associated(arg)) then 7943 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7944 call throw_exception(FoX_NODE_IS_NULL, "getInputEncoding", ex) 7945 if (present(ex)) then 7946 if (inException(ex)) then 7947 return 7948 endif 7949 endif 7950endif 7951 7952 endif 7953 7954 if (arg%nodeType==DOCUMENT_NODE) then 7955 s = str_vs(arg%docExtras%xds%inputEncoding) 7956 elseif (arg%nodeType==ENTITY_NODE) then 7957 s = "" !FIXME revisit when we have working external entities 7958 else 7959 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 7960 call throw_exception(FoX_INVALID_NODE, "getInputEncoding", ex) 7961 if (present(ex)) then 7962 if (inException(ex)) then 7963 return 7964 endif 7965 endif 7966endif 7967 7968 endif 7969 7970 end function getInputEncoding 7971 7972 7973 pure function getdocumentURI_len(np, p) result(n) 7974 type(Node), intent(in) :: np 7975 logical, intent(in) :: p 7976 integer :: n 7977 7978 if (p .and. ( & 7979 np%nodeType==DOCUMENT_NODE .or. & 7980 .false.)) then 7981 n = size(np%docExtras%xds%documentURI) 7982 else 7983 n = 0 7984 endif 7985 end function getdocumentURI_len 7986function getdocumentURI(np, ex)result(c) 7987 type(DOMException), intent(out), optional :: ex 7988 type(Node), pointer :: np 7989#ifdef RESTRICTED_ASSOCIATED_BUG 7990 character(len=getdocumentURI_len(np, .true.)) :: c 7991#else 7992 character(len=getdocumentURI_len(np, associated(np))) :: c 7993#endif 7994 7995 7996 if (.not.associated(np)) then 7997 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 7998 call throw_exception(FoX_NODE_IS_NULL, "getdocumentURI", ex) 7999 if (present(ex)) then 8000 if (inException(ex)) then 8001 return 8002 endif 8003 endif 8004endif 8005 8006 endif 8007 8008 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8009 .true.) then 8010 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8011 call throw_exception(FoX_INVALID_NODE, "getdocumentURI", ex) 8012 if (present(ex)) then 8013 if (inException(ex)) then 8014 return 8015 endif 8016 endif 8017endif 8018 8019 endif 8020 8021 c = str_vs(np%docExtras%xds%documentURI) 8022 8023 end function getdocumentURI 8024 8025subroutine setdocumentURI(np, c, ex) 8026 type(DOMException), intent(out), optional :: ex 8027 type(Node), pointer :: np 8028 character(len=*) :: c 8029 8030 8031 if (.not.associated(np)) then 8032 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8033 call throw_exception(FoX_NODE_IS_NULL, "setdocumentURI", ex) 8034 if (present(ex)) then 8035 if (inException(ex)) then 8036 return 8037 endif 8038 endif 8039endif 8040 8041 endif 8042 8043 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8044 .true.) then 8045 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8046 call throw_exception(FoX_INVALID_NODE, "setdocumentURI", ex) 8047 if (present(ex)) then 8048 if (inException(ex)) then 8049 return 8050 endif 8051 endif 8052endif 8053 8054 endif 8055 8056 if (associated(np%docExtras%xds%documentURI)) deallocate(np%docExtras%xds%documentURI) 8057 np%docExtras%xds%documentURI => vs_str_alloc(c) 8058 8059 end subroutine setdocumentURI 8060 8061 8062function getstrictErrorChecking(np, ex)result(c) 8063 type(DOMException), intent(out), optional :: ex 8064 type(Node), pointer :: np 8065 logical :: c 8066 8067 8068 if (.not.associated(np)) then 8069 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8070 call throw_exception(FoX_NODE_IS_NULL, "getstrictErrorChecking", ex) 8071 if (present(ex)) then 8072 if (inException(ex)) then 8073 return 8074 endif 8075 endif 8076endif 8077 8078 endif 8079 8080 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8081 .true.) then 8082 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8083 call throw_exception(FoX_INVALID_NODE, "getstrictErrorChecking", ex) 8084 if (present(ex)) then 8085 if (inException(ex)) then 8086 return 8087 endif 8088 endif 8089endif 8090 8091 endif 8092 8093 c = np%docExtras%strictErrorChecking 8094 8095 end function getstrictErrorChecking 8096 8097subroutine setstrictErrorChecking(np, c, ex) 8098 type(DOMException), intent(out), optional :: ex 8099 type(Node), pointer :: np 8100 logical :: c 8101 8102 8103 if (.not.associated(np)) then 8104 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8105 call throw_exception(FoX_NODE_IS_NULL, "setstrictErrorChecking", ex) 8106 if (present(ex)) then 8107 if (inException(ex)) then 8108 return 8109 endif 8110 endif 8111endif 8112 8113 endif 8114 8115 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8116 .true.) then 8117 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8118 call throw_exception(FoX_INVALID_NODE, "setstrictErrorChecking", ex) 8119 if (present(ex)) then 8120 if (inException(ex)) then 8121 return 8122 endif 8123 endif 8124endif 8125 8126 endif 8127 8128 np%docExtras%strictErrorChecking = c 8129 8130 end subroutine setstrictErrorChecking 8131 8132 8133 function adoptNode(doc , arg , ex)result(np) 8134 type(DOMException), intent(out), optional :: ex 8135 type(Node), pointer :: doc 8136 type(Node), pointer :: arg 8137 type(Node), pointer :: np 8138 8139 type(Node), pointer :: this, thatParent, new, treeroot, parent, dead 8140 type(xml_doc_state), pointer :: xds 8141 type(element_t), pointer :: elem 8142 type(attribute_t), pointer :: att 8143 logical :: doneAttributes, doneChildren, brokenNS 8144 integer :: i_tree 8145 8146 if (.not.associated(doc).or..not.associated(arg)) then 8147 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8148 call throw_exception(FoX_NODE_IS_NULL, "adoptNode", ex) 8149 if (present(ex)) then 8150 if (inException(ex)) then 8151 return 8152 endif 8153 endif 8154endif 8155 8156 endif 8157 8158 if (getNodeType(doc)/=DOCUMENT_NODE) then 8159 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8160 call throw_exception(FoX_INVALID_NODE, "adoptNode", ex) 8161 if (present(ex)) then 8162 if (inException(ex)) then 8163 return 8164 endif 8165 endif 8166endif 8167 8168 elseif (getNodeType(arg)==DOCUMENT_NODE .or. & 8169 getNodeType(arg)==DOCUMENT_TYPE_NODE .or. & 8170 getNodeType(arg)==NOTATION_NODE .or. & 8171 getNodeType(arg)==ENTITY_NODE) then 8172 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 8173 call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) 8174 if (present(ex)) then 8175 if (inException(ex)) then 8176 return 8177 endif 8178 endif 8179endif 8180 8181 elseif (getReadonly(arg)) then 8182 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 8183 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "adoptNode", ex) 8184 if (present(ex)) then 8185 if (inException(ex)) then 8186 return 8187 endif 8188 endif 8189endif 8190 8191 endif 8192 brokenNS = doc%docExtras%brokenNS 8193 doc%docExtras%brokenNS = .true. ! We need to do stupid NS things 8194 xds => getXds(doc) 8195 8196 if (associated(getParentNode(arg))) then 8197 np => removeChild(getParentNode(arg), arg) 8198 else 8199 np => arg 8200 endif 8201 8202 if (associated(arg, getOwnerDocument(arg))) return 8203 8204 thatParent => null() 8205 treeroot => np 8206 8207 i_tree = 0 8208 doneChildren = .false. 8209 doneAttributes = .false. 8210 this => treeroot 8211 do 8212 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 8213 8214 8215 select case (getNodeType(this)) 8216 case (ELEMENT_NODE) 8217 if (.not.doneAttributes) call setOwnerDocument(this, doc) 8218 case (ATTRIBUTE_NODE) 8219 if (associated(this, arg).or.getSpecified(this)) then 8220 ! We are importing just this attribute node 8221 ! or this was an explicitly specified attribute; either 8222 ! way, we import it as is, and it becomes/remains specified. 8223 call setOwnerDocument(this, doc) 8224 call setSpecified(this, .true.) 8225 else 8226 ! This is an attribute being imported as part of a hierarchy, 8227 ! but its only here by default. Is there a default attribute 8228 ! of this name in the new document? 8229 elem => get_element(xds%element_list, & 8230 getTagName(getOwnerElement(this))) 8231 att => get_attribute_declaration(elem, getName(this)) 8232 if (attribute_has_default(att)) then 8233 ! Create the new default: 8234 if (getParameter(getDomConfig(doc), "namespaces")) then 8235 ! We create a namespaced attribute. Of course, its 8236 ! namespaceURI remains empty for the moment unless we know it ... 8237 if (prefixOfQName(getName(this))=="xml") then 8238 new => createAttributeNS(np, & 8239 "http://www.w3.org/XML/1998/namespace", & 8240 getName(this)) 8241 elseif (getName(this)=="xmlns" & 8242 .or. prefixOfQName(getName(this))=="xmlns") then 8243 new => createAttributeNS(np, & 8244 "http://www.w3.org/2000/xmlns/", & 8245 getName(this)) 8246 else 8247 ! Wait for namespace fixup ... 8248 new => createAttributeNS(np, "", & 8249 getName(this)) 8250 endif 8251 else 8252 new => createAttribute(doc, getName(this)) 8253 endif 8254 call setValue(new, str_vs(att%default)) 8255 call setSpecified(new, .false.) 8256 ! In any case, we dont want to copy the children of this node. 8257 doneChildren = .true. 8258 dead => setAttributeNode(getOwnerElement(this), new) 8259 this => new 8260 call destroyAllNodesRecursively(dead) 8261 endif 8262 ! Otherwise no attribute here, so go back to previous node 8263 dead => this 8264 if (i_tree==0) then 8265 this => getOwnerElement(this) 8266 else 8267 i_tree = i_tree - 1 8268 this => item(getAttributes(getOwnerElement(this)), i_tree) 8269 doneChildren = .true. 8270 endif 8271 call removeAttribute(getOwnerElement(dead), getNodeName(dead)) 8272 endif 8273 case (ENTITY_REFERENCE_NODE) 8274 new => createEntityReference(doc, getNodeName(this)) 8275 ! This will automatically populate the entity reference if doc defines it, so no children needed 8276 parent => getParentNode(this) 8277 if (associated(parent)) then 8278 dead => replaceChild(parent, new, this) 8279 this => new 8280 call destroyAllNodesRecursively(dead) 8281 endif 8282 doneChildren = .true. 8283 case (ENTITY_NODE) 8284 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 8285 call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) 8286 if (present(ex)) then 8287 if (inException(ex)) then 8288 return 8289 endif 8290 endif 8291endif 8292 8293 case (DOCUMENT_NODE) 8294 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 8295 call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) 8296 if (present(ex)) then 8297 if (inException(ex)) then 8298 return 8299 endif 8300 endif 8301endif 8302 8303 case (DOCUMENT_TYPE_NODE) 8304 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 8305 call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) 8306 if (present(ex)) then 8307 if (inException(ex)) then 8308 return 8309 endif 8310 endif 8311endif 8312 8313 case (NOTATION_NODE) 8314 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 8315 call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) 8316 if (present(ex)) then 8317 if (inException(ex)) then 8318 return 8319 endif 8320 endif 8321endif 8322 8323 case default 8324 call setOwnerDocument(this, doc) 8325 end select 8326 8327 8328 else 8329 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 8330 doneAttributes = .true. 8331 else 8332 8333 endif 8334 endif 8335 8336 8337 if (.not.doneChildren) then 8338 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 8339 if (getLength(getAttributes(this))>0) then 8340 this => item(getAttributes(this), 0) 8341 else 8342 doneAttributes = .true. 8343 endif 8344 elseif (hasChildNodes(this)) then 8345 this => getFirstChild(this) 8346 doneChildren = .false. 8347 doneAttributes = .false. 8348 else 8349 doneChildren = .true. 8350 doneAttributes = .false. 8351 endif 8352 8353 else ! if doneChildren 8354 8355 if (associated(this, treeroot)) exit 8356 if (getNodeType(this)==ATTRIBUTE_NODE) then 8357 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 8358 i_tree= i_tree+ 1 8359 this => item(getAttributes(getOwnerElement(this)), i_tree) 8360 doneChildren = .false. 8361 else 8362 i_tree= 0 8363 this => getOwnerElement(this) 8364 doneAttributes = .true. 8365 doneChildren = .false. 8366 endif 8367 elseif (associated(getNextSibling(this))) then 8368 8369 this => getNextSibling(this) 8370 doneChildren = .false. 8371 doneAttributes = .false. 8372 else 8373 this => getParentNode(this) 8374 endif 8375 endif 8376 8377 enddo 8378 8379 8380 8381 doc%docExtras%brokenNS = brokenNS 8382! call namespaceFixup(np) 8383 8384 end function adoptNode 8385 8386function getdomConfig(np, ex)result(c) 8387 type(DOMException), intent(out), optional :: ex 8388 type(Node), pointer :: np 8389 type(DOMConfiguration), pointer :: c 8390 8391 8392 if (.not.associated(np)) then 8393 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8394 call throw_exception(FoX_NODE_IS_NULL, "getdomConfig", ex) 8395 if (present(ex)) then 8396 if (inException(ex)) then 8397 return 8398 endif 8399 endif 8400endif 8401 8402 endif 8403 8404 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8405 .true.) then 8406 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8407 call throw_exception(FoX_INVALID_NODE, "getdomConfig", ex) 8408 if (present(ex)) then 8409 if (inException(ex)) then 8410 return 8411 endif 8412 endif 8413endif 8414 8415 endif 8416 8417 c => np%docExtras%domConfig 8418 8419 end function getdomConfig 8420 8421subroutine setdomConfig(np, c, ex) 8422 type(DOMException), intent(out), optional :: ex 8423 type(Node), pointer :: np 8424 type(DOMConfiguration), pointer :: c 8425 8426 8427 if (.not.associated(np)) then 8428 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8429 call throw_exception(FoX_NODE_IS_NULL, "setdomConfig", ex) 8430 if (present(ex)) then 8431 if (inException(ex)) then 8432 return 8433 endif 8434 endif 8435endif 8436 8437 endif 8438 8439 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8440 .true.) then 8441 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8442 call throw_exception(FoX_INVALID_NODE, "setdomConfig", ex) 8443 if (present(ex)) then 8444 if (inException(ex)) then 8445 return 8446 endif 8447 endif 8448endif 8449 8450 endif 8451 8452 np%docExtras%domConfig => c 8453 8454 end subroutine setdomConfig 8455 8456 8457 8458 function renameNode(arg, n, namespaceURI, qualifiedName, ex)result(np) 8459 type(DOMException), intent(out), optional :: ex 8460 type(Node), pointer :: arg 8461 type(Node), pointer :: n 8462 character(len=*), intent(in) :: namespaceURI 8463 character(len=*), intent(in) :: qualifiedName 8464 type(Node), pointer :: np 8465 8466 type(Node), pointer :: attNode 8467 integer :: i 8468 logical :: brokenNS 8469 type(element_t), pointer :: elem 8470 type(attribute_t), pointer :: att 8471 type(xml_doc_state), pointer :: xds 8472 type(URI), pointer :: URIref 8473 8474 if (.not.associated(arg).or..not.associated(n)) then 8475 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8476 call throw_exception(FoX_NODE_IS_NULL, "renameNode", ex) 8477 if (present(ex)) then 8478 if (inException(ex)) then 8479 return 8480 endif 8481 endif 8482endif 8483 8484 endif 8485 8486 if (getNodeType(arg)/=DOCUMENT_NODE) then 8487 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8488 call throw_exception(FoX_INVALID_NODE, "renameNode", ex) 8489 if (present(ex)) then 8490 if (inException(ex)) then 8491 return 8492 endif 8493 endif 8494endif 8495 8496 elseif (.not.associated(getOwnerDocument(n), target=arg)) then 8497 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 8498 call throw_exception(WRONG_DOCUMENT_ERR, "renameNode", ex) 8499 if (present(ex)) then 8500 if (inException(ex)) then 8501 return 8502 endif 8503 endif 8504endif 8505 8506 elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then 8507 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 8508 call throw_exception(INVALID_CHARACTER_ERR, "renameNode", ex) 8509 if (present(ex)) then 8510 if (inException(ex)) then 8511 return 8512 endif 8513 endif 8514endif 8515 8516 elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then 8517 if (getFoX_checks().or.NAMESPACE_ERR<200) then 8518 call throw_exception(NAMESPACE_ERR, "renameNode", ex) 8519 if (present(ex)) then 8520 if (inException(ex)) then 8521 return 8522 endif 8523 endif 8524endif 8525 8526 elseif (prefixOfQName(qualifiedName)/="" & 8527 .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then 8528 if (getFoX_checks().or.NAMESPACE_ERR<200) then 8529 call throw_exception(NAMESPACE_ERR, "renameNode", ex) 8530 if (present(ex)) then 8531 if (inException(ex)) then 8532 return 8533 endif 8534 endif 8535endif 8536 8537 elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & 8538 prefixOfQName(qualifiedName)=="xml") then 8539 if (getFoX_checks().or.NAMESPACE_ERR<200) then 8540 call throw_exception(NAMESPACE_ERR, "renameNode", ex) 8541 if (present(ex)) then 8542 if (inException(ex)) then 8543 return 8544 endif 8545 endif 8546endif 8547 8548 elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then 8549 if (getFoX_checks().or.NAMESPACE_ERR<200) then 8550 call throw_exception(NAMESPACE_ERR, "renameNode", ex) 8551 if (present(ex)) then 8552 if (inException(ex)) then 8553 return 8554 endif 8555 endif 8556endif 8557 8558 endif 8559 8560 URIref => parseURI(namespaceURI) 8561 if (.not.associated(URIref)) then 8562 if (getFoX_checks().or.FoX_INVALID_URI<200) then 8563 call throw_exception(FoX_INVALID_URI, "renameNode", ex) 8564 if (present(ex)) then 8565 if (inException(ex)) then 8566 return 8567 endif 8568 endif 8569endif 8570 8571 endif 8572 call destroyURI(URIref) 8573 8574! FIXME what if this is called on a Level 1 node 8575! FIXME what if this is called on a read-only node 8576! FIXME what if this is called on an attribute whose specified=fals 8577 select case(getNodeType(n)) 8578 case (ELEMENT_NODE, ATTRIBUTE_NODE) 8579 deallocate(n%nodeName) 8580 n%nodeName => vs_str_alloc(qualifiedName) 8581 deallocate(n%elExtras%namespaceURI) 8582 n%elExtras%namespaceURI => vs_str_alloc(namespaceURI) 8583 deallocate(n%elExtras%localName) 8584 n%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) 8585 case default 8586 if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then 8587 call throw_exception(NOT_SUPPORTED_ERR, "renameNode", ex) 8588 if (present(ex)) then 8589 if (inException(ex)) then 8590 return 8591 endif 8592 endif 8593endif 8594 8595 end select 8596 8597 if (getNodeType(n)==ELEMENT_NODE) then 8598 i = 0 8599 do while (i<getLength(getAttributes(n))) 8600 attNode => item(getAttributes(n), i) 8601 if (.not.getSpecified(attNode)) then 8602 attNode => removeAttributeNode(n, attNode) 8603 call destroyNode(attNode) 8604 else 8605 i = i + 1 8606 endif 8607 enddo 8608 xds => getXds(arg) 8609 elem => get_element(xds%element_list, qualifiedName) 8610 if (associated(elem)) then 8611 do i = 1, get_attlist_size(elem) 8612 att => get_attribute_declaration(elem, i) 8613 if (attribute_has_default(att)) then 8614 ! Since this is a namespaced function, we create a namespaced 8615 ! attribute. Of course, its namespaceURI remains empty 8616 ! for the moment unless we know it ... 8617 if (prefixOfQName(str_vs(att%name))=="xml") then 8618 call setAttributeNS(np, & 8619 "http://www.w3.org/XML/1998/namespace", & 8620 str_vs(att%name), str_vs(att%default)) 8621 elseif (str_vs(att%name)=="xmlns" & 8622 .or. prefixOfQName(str_vs(att%name))=="xmlns") then 8623 call setAttributeNS(np, & 8624 "http://www.w3.org/2000/xmlns/", & 8625 str_vs(att%name), str_vs(att%default)) 8626 else 8627 ! Wait for namespace fixup ... 8628 brokenNS = arg%docExtras%brokenNS 8629 arg%docExtras%brokenNS = .true. 8630 call setAttributeNS(np, "", str_vs(att%name), & 8631 str_vs(att%default)) 8632 arg%docExtras%brokenNS = brokenNS 8633 endif 8634 endif 8635 enddo 8636 endif 8637 endif 8638 8639 np => n 8640 8641 end function renameNode 8642 8643 ! Internal function, not part of API 8644 8645 function createNamespaceNode(arg, prefix, URI, specified, ex)result(np) 8646 type(DOMException), intent(out), optional :: ex 8647 type(Node), pointer :: arg 8648 character(len=*), intent(in) :: prefix 8649 character(len=*), intent(in) :: URI 8650 logical, intent(in) :: specified 8651 type(Node), pointer :: np 8652 8653 if (.not.associated(arg)) then 8654 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8655 call throw_exception(FoX_NODE_IS_NULL, "createNamespaceNode", ex) 8656 if (present(ex)) then 8657 if (inException(ex)) then 8658 return 8659 endif 8660 endif 8661endif 8662 8663 endif 8664 8665 if (arg%nodeType/=DOCUMENT_NODE) then 8666 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8667 call throw_exception(FoX_INVALID_NODE, "createNamespaceNode", ex) 8668 if (present(ex)) then 8669 if (inException(ex)) then 8670 return 8671 endif 8672 endif 8673endif 8674 8675 endif 8676 8677 np => createNode(arg, XPATH_NAMESPACE_NODE, "#namespace", URI) 8678 allocate(np%elExtras) 8679 np%elExtras%prefix => vs_str_alloc(prefix) 8680 np%elExtras%namespaceURI => vs_str_alloc(URI) 8681 np%elExtras%specified = specified 8682 8683 end function createNamespaceNode 8684 8685 function createEntity(arg, name, publicId, systemId, notationName, ex)result(np) 8686 type(DOMException), intent(out), optional :: ex 8687 type(Node), pointer :: arg 8688 character(len=*), intent(in) :: name 8689 character(len=*), intent(in) :: publicId 8690 character(len=*), intent(in) :: systemId 8691 character(len=*), intent(in) :: notationName 8692 type(Node), pointer :: np 8693 8694 if (.not.associated(arg)) then 8695 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8696 call throw_exception(FoX_NODE_IS_NULL, "createEntity", ex) 8697 if (present(ex)) then 8698 if (inException(ex)) then 8699 return 8700 endif 8701 endif 8702endif 8703 8704 endif 8705 8706 if (arg%nodeType/=DOCUMENT_NODE) then 8707 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8708 call throw_exception(FoX_INVALID_NODE, "createEntity", ex) 8709 if (present(ex)) then 8710 if (inException(ex)) then 8711 return 8712 endif 8713 endif 8714endif 8715 8716 endif 8717 8718 np => createNode(arg, ENTITY_NODE, name, "") 8719 allocate(np%dtdExtras) 8720 np%dtdExtras%publicId => vs_str_alloc(publicId) 8721 np%dtdExtras%systemId => vs_str_alloc(systemId) 8722 np%dtdExtras%notationName => vs_str_alloc(notationName) 8723 8724 if (getGCstate(arg)) then 8725 np%inDocument = .false. 8726 call append(arg%docExtras%hangingnodes, np) 8727 else 8728 np%inDocument = .true. 8729 endif 8730 8731 end function createEntity 8732 8733 function createNotation(arg, name, publicId, systemId, ex)result(np) 8734 type(DOMException), intent(out), optional :: ex 8735 type(Node), pointer :: arg 8736 character(len=*), intent(in) :: name 8737 character(len=*), intent(in) :: publicId 8738 character(len=*), intent(in) :: systemId 8739 type(Node), pointer :: np 8740 8741 if (.not.associated(arg)) then 8742 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8743 call throw_exception(FoX_NODE_IS_NULL, "createNotation", ex) 8744 if (present(ex)) then 8745 if (inException(ex)) then 8746 return 8747 endif 8748 endif 8749endif 8750 8751 endif 8752 8753 if (arg%nodeType/=DOCUMENT_NODE) then 8754 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8755 call throw_exception(FoX_INVALID_NODE, "createNotation", ex) 8756 if (present(ex)) then 8757 if (inException(ex)) then 8758 return 8759 endif 8760 endif 8761endif 8762 8763 endif 8764 8765 np => createNode(arg, NOTATION_NODE, name, "") 8766 allocate(np%dtdExtras) 8767 np%dtdExtras%publicId => vs_str_alloc(publicId) 8768 np%dtdExtras%systemId => vs_str_alloc(systemId) 8769 8770 if (getGCstate(arg)) then 8771 np%inDocument = .false. 8772 call append(arg%docExtras%hangingnodes, np) 8773 else 8774 np%inDocument = .true. 8775 endif 8776 8777 end function createNotation 8778 8779 function getXmlVersionEnum(arg, ex)result(n) 8780 type(DOMException), intent(out), optional :: ex 8781 type(Node), pointer :: arg 8782 integer :: n 8783 8784 if (.not.associated(arg)) then 8785 if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then 8786 call throw_exception(FoX_INTERNAL_ERROR, "getXmlVersionEnum", ex) 8787 if (present(ex)) then 8788 if (inException(ex)) then 8789 return 8790 endif 8791 endif 8792endif 8793 8794 endif 8795 8796 n = arg%docExtras%xds%xml_version 8797 8798 end function getXmlVersionEnum 8799 8800 function getXds(arg, ex)result(xds) 8801 type(DOMException), intent(out), optional :: ex 8802 type(Node), pointer :: arg 8803 type(xml_doc_state), pointer :: xds 8804 8805 if (.not.associated(arg)) then 8806 if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then 8807 call throw_exception(FoX_INTERNAL_ERROR, "getXds", ex) 8808 if (present(ex)) then 8809 if (inException(ex)) then 8810 return 8811 endif 8812 endif 8813endif 8814 8815 endif 8816 8817 xds => arg%docExtras%xds 8818 8819 end function getXds 8820 8821 8822function getGCstate(np, ex)result(c) 8823 type(DOMException), intent(out), optional :: ex 8824 type(Node), pointer :: np 8825 logical :: c 8826 8827 8828 if (.not.associated(np)) then 8829 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8830 call throw_exception(FoX_NODE_IS_NULL, "getGCstate", ex) 8831 if (present(ex)) then 8832 if (inException(ex)) then 8833 return 8834 endif 8835 endif 8836endif 8837 8838 endif 8839 8840 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8841 .true.) then 8842 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8843 call throw_exception(FoX_INVALID_NODE, "getGCstate", ex) 8844 if (present(ex)) then 8845 if (inException(ex)) then 8846 return 8847 endif 8848 endif 8849endif 8850 8851 endif 8852 8853 c = np%docExtras%xds%building 8854 8855 end function getGCstate 8856 8857subroutine setGCstate(np, c, ex) 8858 type(DOMException), intent(out), optional :: ex 8859 type(Node), pointer :: np 8860 logical :: c 8861 8862 8863 if (.not.associated(np)) then 8864 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8865 call throw_exception(FoX_NODE_IS_NULL, "setGCstate", ex) 8866 if (present(ex)) then 8867 if (inException(ex)) then 8868 return 8869 endif 8870 endif 8871endif 8872 8873 endif 8874 8875 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8876 .true.) then 8877 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8878 call throw_exception(FoX_INVALID_NODE, "setGCstate", ex) 8879 if (present(ex)) then 8880 if (inException(ex)) then 8881 return 8882 endif 8883 endif 8884endif 8885 8886 endif 8887 8888 np%docExtras%xds%building = c 8889 8890 end subroutine setGCstate 8891 8892 8893function getliveNodeLists(np, ex)result(c) 8894 type(DOMException), intent(out), optional :: ex 8895 type(Node), pointer :: np 8896 logical :: c 8897 8898 8899 if (.not.associated(np)) then 8900 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8901 call throw_exception(FoX_NODE_IS_NULL, "getliveNodeLists", ex) 8902 if (present(ex)) then 8903 if (inException(ex)) then 8904 return 8905 endif 8906 endif 8907endif 8908 8909 endif 8910 8911 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8912 .true.) then 8913 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8914 call throw_exception(FoX_INVALID_NODE, "getliveNodeLists", ex) 8915 if (present(ex)) then 8916 if (inException(ex)) then 8917 return 8918 endif 8919 endif 8920endif 8921 8922 endif 8923 8924 c = np%docExtras%liveNodeLists 8925 8926 end function getliveNodeLists 8927 8928subroutine setliveNodeLists(np, c, ex) 8929 type(DOMException), intent(out), optional :: ex 8930 type(Node), pointer :: np 8931 logical :: c 8932 8933 8934 if (.not.associated(np)) then 8935 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8936 call throw_exception(FoX_NODE_IS_NULL, "setliveNodeLists", ex) 8937 if (present(ex)) then 8938 if (inException(ex)) then 8939 return 8940 endif 8941 endif 8942endif 8943 8944 endif 8945 8946 if (getNodeType(np)/=DOCUMENT_NODE .and. & 8947 .true.) then 8948 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8949 call throw_exception(FoX_INVALID_NODE, "setliveNodeLists", ex) 8950 if (present(ex)) then 8951 if (inException(ex)) then 8952 return 8953 endif 8954 endif 8955endif 8956 8957 endif 8958 8959 np%docExtras%liveNodeLists = c 8960 8961 end subroutine setliveNodeLists 8962 8963 8964 8965 8966! function getName(docType) result(c) See m_dom_common 8967 8968 function getEntities(arg, ex)result(nnp) 8969 type(DOMException), intent(out), optional :: ex 8970 type(Node), pointer :: arg 8971 type(NamedNodeMap), pointer :: nnp 8972 8973 if (.not.associated(arg)) then 8974 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 8975 call throw_exception(FoX_NODE_IS_NULL, "getEntities", ex) 8976 if (present(ex)) then 8977 if (inException(ex)) then 8978 return 8979 endif 8980 endif 8981endif 8982 8983 endif 8984 8985 if (arg%nodeType/=DOCUMENT_TYPE_NODE) then 8986 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 8987 call throw_exception(FoX_INVALID_NODE, "getEntities", ex) 8988 if (present(ex)) then 8989 if (inException(ex)) then 8990 return 8991 endif 8992 endif 8993endif 8994 8995 endif 8996 8997 nnp => arg%dtdExtras%entities 8998 end function getEntities 8999 9000 function getNotations(arg, ex)result(nnp) 9001 type(DOMException), intent(out), optional :: ex 9002 type(Node), pointer :: arg 9003 type(NamedNodeMap), pointer :: nnp 9004 9005 if (.not.associated(arg)) then 9006 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9007 call throw_exception(FoX_NODE_IS_NULL, "getNotations", ex) 9008 if (present(ex)) then 9009 if (inException(ex)) then 9010 return 9011 endif 9012 endif 9013endif 9014 9015 endif 9016 9017 if (arg%nodeType/=DOCUMENT_TYPE_NODE) then 9018 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9019 call throw_exception(FoX_INVALID_NODE, "getNotations", ex) 9020 if (present(ex)) then 9021 if (inException(ex)) then 9022 return 9023 endif 9024 endif 9025endif 9026 9027 endif 9028 9029 nnp => arg%dtdExtras%notations 9030 end function getNotations 9031 9032 9033! function getPublicId(docType) result(c) See m_dom_common 9034 9035 9036! function getSystemId(docType) result(c) See m_dom_common 9037 9038 pure function getInternalSubset_len(arg, p) result(n) 9039 type(Node), pointer :: arg 9040 logical, intent(in) :: p 9041 integer :: n 9042 9043 n = 0 9044 if (p) then 9045 if (associated(arg%ownerDocument)) then 9046 if (associated(arg%ownerDocument%docExtras%xds%intSubset)) then 9047 n = size(arg%ownerDocument%docExtras%xds%intSubset) 9048 endif 9049 endif 9050 endif 9051 end function getInternalSubset_len 9052 9053 function getInternalSubset(arg, ex)result(s) 9054 type(DOMException), intent(out), optional :: ex 9055 type(Node), pointer :: arg 9056#ifdef RESTRICTED_ASSOCIATED_BUG 9057 character(len=getInternalSubset_len(arg, .true.)) :: s 9058#else 9059 character(len=getInternalSubset_len(arg, associated(arg))) :: s 9060#endif 9061 9062 if (.not.associated(arg)) then 9063 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9064 call throw_exception(FoX_NODE_IS_NULL, "getInternalSubset", ex) 9065 if (present(ex)) then 9066 if (inException(ex)) then 9067 return 9068 endif 9069 endif 9070endif 9071 9072 endif 9073 9074 if (arg%nodeType/=DOCUMENT_TYPE_NODE) then 9075 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9076 call throw_exception(FoX_INVALID_NODE, "getInternalSubset", ex) 9077 if (present(ex)) then 9078 if (inException(ex)) then 9079 return 9080 endif 9081 endif 9082endif 9083 9084 endif 9085 9086 if (len(s)>0) then 9087 s = str_vs(arg%ownerDocument%docExtras%xds%intSubset) 9088 else 9089 s = "" 9090 endif 9091 end function getInternalSubset 9092 9093 9094 9095 9096 pure function gettagName_len(np, p) result(n) 9097 type(Node), intent(in) :: np 9098 logical, intent(in) :: p 9099 integer :: n 9100 9101 if (p .and. ( & 9102 np%nodeType==ELEMENT_NODE .or. & 9103 .false.)) then 9104 n = size(np%nodeName) 9105 else 9106 n = 0 9107 endif 9108 end function gettagName_len 9109function gettagName(np, ex)result(c) 9110 type(DOMException), intent(out), optional :: ex 9111 type(Node), pointer :: np 9112#ifdef RESTRICTED_ASSOCIATED_BUG 9113 character(len=gettagName_len(np, .true.)) :: c 9114#else 9115 character(len=gettagName_len(np, associated(np))) :: c 9116#endif 9117 9118 9119 if (.not.associated(np)) then 9120 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9121 call throw_exception(FoX_NODE_IS_NULL, "gettagName", ex) 9122 if (present(ex)) then 9123 if (inException(ex)) then 9124 return 9125 endif 9126 endif 9127endif 9128 9129 endif 9130 9131 if (getNodeType(np)/=ELEMENT_NODE .and. & 9132 .true.) then 9133 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9134 call throw_exception(FoX_INVALID_NODE, "gettagName", ex) 9135 if (present(ex)) then 9136 if (inException(ex)) then 9137 return 9138 endif 9139 endif 9140endif 9141 9142 endif 9143 9144 c = str_vs(np%nodeName) 9145 9146 end function gettagName 9147 9148 9149 pure function getAttribute_len(arg, p, name) result(n) 9150 type(Node), intent(in) :: arg 9151 logical, intent(in) :: p 9152 character(len=*), intent(in) :: name 9153 integer :: n 9154 9155 integer :: i 9156 9157 n = 0 9158 if (.not.p) return 9159 if (arg%nodeType/=ELEMENT_NODE) return 9160 9161 do i = 1, arg%elExtras%attributes%length 9162 if (str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==name) then 9163 n = getTextContent_len(arg%elExtras%attributes%nodes(i)%this, .true.) 9164 exit 9165 endif 9166 enddo 9167 9168 end function getAttribute_len 9169 9170 function getAttribute(arg, name, ex)result(c) 9171 type(DOMException), intent(out), optional :: ex 9172 type(Node), pointer :: arg 9173 character(len=*), intent(in) :: name 9174#ifdef RESTRICTED_ASSOCIATED_BUG 9175 character(len=getAttribute_len(arg, .true., name)) :: c 9176#else 9177 character(len=getAttribute_len(arg, associated(arg), name)) :: c 9178#endif 9179 9180 integer :: i 9181 9182 if (.not.associated(arg)) then 9183 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9184 call throw_exception(FoX_NODE_IS_NULL, "getAttribute", ex) 9185 if (present(ex)) then 9186 if (inException(ex)) then 9187 return 9188 endif 9189 endif 9190endif 9191 9192 endif 9193 9194 if (getNodeType(arg) /= ELEMENT_NODE) then 9195 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9196 call throw_exception(FoX_INVALID_NODE, "getAttribute", ex) 9197 if (present(ex)) then 9198 if (inException(ex)) then 9199 return 9200 endif 9201 endif 9202endif 9203 9204 endif 9205 9206 if (len(c)>0) then 9207 do i = 1, arg%elExtras%attributes%length 9208 if (str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==name) then 9209 c = getTextContent(arg%elExtras%attributes%nodes(i)%this) 9210 exit 9211 endif 9212 enddo 9213 else 9214 c = "" 9215 endif 9216 9217 end function getAttribute 9218 9219 9220 subroutine setAttribute(arg, name, value, ex) 9221 type(DOMException), intent(out), optional :: ex 9222 type(Node), pointer :: arg 9223 character(len=*), intent(in) :: name 9224 character(len=*), intent(in) :: value 9225 9226 type(Node), pointer :: nn, dummy 9227 logical :: quickFix 9228 9229 if (.not.associated(arg)) then 9230 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9231 call throw_exception(FoX_NODE_IS_NULL, "setAttribute", ex) 9232 if (present(ex)) then 9233 if (inException(ex)) then 9234 return 9235 endif 9236 endif 9237endif 9238 9239 endif 9240 9241 if (getNodetype(arg)/=ELEMENT_NODE) then 9242 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9243 call throw_exception(FoX_INVALID_NODE, "setAttribute", ex) 9244 if (present(ex)) then 9245 if (inException(ex)) then 9246 return 9247 endif 9248 endif 9249endif 9250 9251 elseif (arg%readonly) then 9252 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 9253 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttribute", ex) 9254 if (present(ex)) then 9255 if (inException(ex)) then 9256 return 9257 endif 9258 endif 9259endif 9260 9261 elseif (.not.checkName(name, getXmlVersionEnum(getOwnerDocument(arg)))) then 9262 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 9263 call throw_exception(INVALID_CHARACTER_ERR, "setAttribute", ex) 9264 if (present(ex)) then 9265 if (inException(ex)) then 9266 return 9267 endif 9268 endif 9269endif 9270 9271 elseif (.not.checkChars(value, getXmlVersionEnum(getOwnerDocument(arg)))) then 9272 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 9273 call throw_exception(FoX_INVALID_CHARACTER, "setAttribute", ex) 9274 if (present(ex)) then 9275 if (inException(ex)) then 9276 return 9277 endif 9278 endif 9279endif 9280 9281 endif 9282 9283 quickFix = getGCstate(getOwnerDocument(arg)) & 9284 .and. arg%inDocument 9285 9286 if (quickFix) call setGCstate(getOwnerDocument(arg), .false.) 9287 ! then the created attribute is going straight into the document, 9288 ! so dont faff with hanging-node lists. 9289 9290 nn => createAttribute(arg%ownerDocument, name) 9291 call setValue(nn, value) 9292 dummy => setNamedItem(getAttributes(arg), nn) 9293 if (associated(dummy)) then 9294 if (getGCstate(getOwnerDocument(arg)).and..not.dummy%inDocument) & 9295 call putNodesInDocument(getOwnerDocument(arg), dummy) 9296 ! ... so that dummy & children are removed from hangingNodes list. 9297 call destroyAllNodesRecursively(dummy) 9298 endif 9299 9300 if (quickFix) call setGCstate(getOwnerDocument(arg), .true.) 9301 9302 end subroutine setAttribute 9303 9304 9305 subroutine removeAttribute(arg, name, ex) 9306 type(DOMException), intent(out), optional :: ex 9307 type(Node), pointer :: arg 9308 character(len=*), intent(in) :: name 9309 9310 type(DOMException) :: ex2 9311 type(Node), pointer :: dummy 9312 integer :: e 9313 9314 if (.not.associated(arg)) then 9315 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9316 call throw_exception(FoX_NODE_IS_NULL, "removeAttribute", ex) 9317 if (present(ex)) then 9318 if (inException(ex)) then 9319 return 9320 endif 9321 endif 9322endif 9323 9324 endif 9325 9326 if (getNodetype(arg)/=ELEMENT_NODE) then 9327 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9328 call throw_exception(FoX_INVALID_NODE, "removeAttribute", ex) 9329 if (present(ex)) then 9330 if (inException(ex)) then 9331 return 9332 endif 9333 endif 9334endif 9335 9336 elseif (arg%readonly) then 9337 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 9338 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeAttribute", ex) 9339 if (present(ex)) then 9340 if (inException(ex)) then 9341 return 9342 endif 9343 endif 9344endif 9345 9346 endif 9347 9348 if (arg%inDocument) & 9349 call setGCstate(getOwnerDocument(arg), .false.) 9350 9351 dummy => removeNamedItem(getAttributes(arg), name, ex2) 9352 ! removeNamedItem took care of any default attributes 9353 if (inException(ex2)) then 9354 e = getExceptionCode(ex2) 9355 if (e/=NOT_FOUND_ERR) then 9356 if (getFoX_checks().or.e<200) then 9357 call throw_exception(e, "removeAttribute", ex) 9358 if (present(ex)) then 9359 if (inException(ex)) then 9360 return 9361 endif 9362 endif 9363endif 9364 9365 endif 9366 else 9367 if (.not.arg%inDocument) then 9368 ! dummy was not in the doc, so was on hangingNode list. 9369 ! To remove it from the list: 9370 call putNodesInDocument(arg%ownerDocument, dummy) 9371 endif 9372 call destroyAllNodesRecursively(dummy) 9373 endif 9374 9375 if (arg%inDocument) & 9376 call setGCstate(arg%ownerDocument, .true.) 9377 9378 end subroutine removeAttribute 9379 9380 9381 function getAttributeNode(arg, name, ex)result(attr) 9382 type(DOMException), intent(out), optional :: ex 9383 type(Node), pointer :: arg 9384 character(len=*), intent(in) :: name 9385 type(Node), pointer :: attr 9386 9387 if (.not.associated(arg)) then 9388 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9389 call throw_exception(FoX_NODE_IS_NULL, "getAttributeNode", ex) 9390 if (present(ex)) then 9391 if (inException(ex)) then 9392 return 9393 endif 9394 endif 9395endif 9396 9397 endif 9398 9399 if (arg%nodeType /= ELEMENT_NODE) then 9400 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9401 call throw_exception(FoX_INVALID_NODE, "getAttributeNode", ex) 9402 if (present(ex)) then 9403 if (inException(ex)) then 9404 return 9405 endif 9406 endif 9407endif 9408 9409 endif 9410 9411 attr => getNamedItem(getAttributes(arg), name) 9412 9413 end function getAttributeNode 9414 9415 9416 function setAttributeNode(arg, newattr, ex)result(attr) 9417 type(DOMException), intent(out), optional :: ex 9418 type(Node), pointer :: arg 9419 type(Node), pointer :: newattr 9420 type(Node), pointer :: attr 9421 type(Node), pointer :: dummy 9422 9423 if (.not.associated(arg)) then 9424 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9425 call throw_exception(FoX_NODE_IS_NULL, "setAttributeNode", ex) 9426 if (present(ex)) then 9427 if (inException(ex)) then 9428 return 9429 endif 9430 endif 9431endif 9432 9433 endif 9434 9435 if (arg%nodeType /= ELEMENT_NODE) then 9436 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9437 call throw_exception(FoX_INVALID_NODE, "setAttributeNode", ex) 9438 if (present(ex)) then 9439 if (inException(ex)) then 9440 return 9441 endif 9442 endif 9443endif 9444 9445 elseif (.not.associated(arg%ownerDocument, newattr%ownerDocument)) then 9446 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 9447 call throw_exception(WRONG_DOCUMENT_ERR, "setAttributeNode", ex) 9448 if (present(ex)) then 9449 if (inException(ex)) then 9450 return 9451 endif 9452 endif 9453endif 9454 9455 elseif (arg%readonly) then 9456 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 9457 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNode", ex) 9458 if (present(ex)) then 9459 if (inException(ex)) then 9460 return 9461 endif 9462 endif 9463endif 9464 9465 endif 9466 9467 if (associated(getOwnerElement(newattr), arg)) then 9468 attr => newattr 9469 return 9470 ! Nothing to do, this attribute is already in this element 9471 elseif (associated(getOwnerElement(newattr))) then 9472 if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then 9473 call throw_exception(INUSE_ATTRIBUTE_ERR, "setAttributeNode", ex) 9474 if (present(ex)) then 9475 if (inException(ex)) then 9476 return 9477 endif 9478 endif 9479endif 9480 9481 endif 9482 9483 ! this checks if attribute exists already 9484 ! It also does any adding/removing of hangingnodes 9485 ! and sets ownerElement appropriately 9486 dummy => setNamedItem(getAttributes(arg), newattr, ex) 9487 attr => dummy 9488 9489 end function setAttributeNode 9490 9491 9492 function removeAttributeNode(arg, oldattr, ex)result(attr) 9493 type(DOMException), intent(out), optional :: ex 9494 type(Node), pointer :: arg 9495 type(Node), pointer :: oldattr 9496 type(Node), pointer :: attr 9497 9498 if (.not.associated(arg)) then 9499 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9500 call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNode", ex) 9501 if (present(ex)) then 9502 if (inException(ex)) then 9503 return 9504 endif 9505 endif 9506endif 9507 9508 endif 9509 9510 if (arg%nodeType /= ELEMENT_NODE) then 9511 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9512 call throw_exception(FoX_INVALID_NODE, "removeAttributeNode", ex) 9513 if (present(ex)) then 9514 if (inException(ex)) then 9515 return 9516 endif 9517 endif 9518endif 9519 9520 endif 9521 9522 if (.not.associated(arg, getOwnerElement(oldattr))) then 9523 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 9524 call throw_exception(NOT_FOUND_ERR, "removeAttributeNode", ex) 9525 if (present(ex)) then 9526 if (inException(ex)) then 9527 return 9528 endif 9529 endif 9530endif 9531 9532 endif 9533 9534 attr => removeNamedItem(getAttributes(arg), & 9535 getNodeName(oldattr), ex) 9536 9537 end function removeAttributeNode 9538 9539 9540! function getElementsByTagName - see m_dom_document 9541 9542 9543 pure function getAttributesNS_len(arg, p, localname, namespaceURI) result(n) 9544 type(Node), intent(in) :: arg 9545 logical, intent(in) :: p 9546 character(len=*), intent(in) :: localname 9547 character(len=*), intent(in) :: namespaceURI 9548 integer :: n 9549 9550 integer :: i 9551 9552 n = 0 9553 if (.not.p) return 9554 if (arg%nodeType/=ELEMENT_NODE) return 9555 9556 do i = 1, arg%elExtras%attributes%length 9557 if ((str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%localName)==localname & 9558 .and. str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) & 9559 .or. (namespaceURI=="".and.str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==localname)) then 9560 n = getTextContent_len(arg%elExtras%attributes%nodes(i)%this, .true.) 9561 exit 9562 endif 9563 enddo 9564 9565 end function getAttributesNS_len 9566 9567 function getAttributeNS(arg, namespaceURI, localName, ex)result(c) 9568 type(DOMException), intent(out), optional :: ex 9569 type(Node), pointer :: arg 9570 character(len=*), intent(in) :: namespaceURI 9571 character(len=*), intent(in) :: localName 9572#ifdef RESTRICTED_ASSOCIATED_BUG 9573 character(len=getAttributesNS_len(arg, .true., localname, namespaceURI)) :: c 9574#else 9575 character(len=getAttributesNS_len(arg, associated(arg), localname, namespaceURI)) :: c 9576#endif 9577 9578 integer :: i 9579 9580 if (.not.associated(arg)) then 9581 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9582 call throw_exception(FoX_NODE_IS_NULL, "getAttributeNS", ex) 9583 if (present(ex)) then 9584 if (inException(ex)) then 9585 return 9586 endif 9587 endif 9588endif 9589 9590 endif 9591 9592 if (arg%nodeType /= ELEMENT_NODE) then 9593 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9594 call throw_exception(FoX_INVALID_NODE, "getAttributeNS", ex) 9595 if (present(ex)) then 9596 if (inException(ex)) then 9597 return 9598 endif 9599 endif 9600endif 9601 9602 endif 9603 9604 if (len(c)>0) then 9605 do i = 1, arg%elExtras%attributes%length 9606 if ((str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%localName)==localname & 9607 .and. str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) & 9608 .or. (namespaceURI=="".and.str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==localname)) then 9609 c = getTextContent(arg%elExtras%attributes%nodes(i)%this) 9610 exit 9611 endif 9612 enddo 9613 else 9614 c = "" 9615 endif 9616 9617 end function getAttributeNS 9618 9619 9620 subroutine setAttributeNS(arg, namespaceURI, qualifiedname, value, ex) 9621 type(DOMException), intent(out), optional :: ex 9622 type(Node), pointer :: arg 9623 character(len=*), intent(in) :: namespaceURI 9624 character(len=*), intent(in) :: qualifiedName 9625 character(len=*), intent(in) :: value 9626 9627 type(Node), pointer :: nn, dummy 9628 logical :: quickfix 9629 9630 if (.not.associated(arg)) then 9631 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9632 call throw_exception(FoX_NODE_IS_NULL, "setAttributeNS", ex) 9633 if (present(ex)) then 9634 if (inException(ex)) then 9635 return 9636 endif 9637 endif 9638endif 9639 9640 endif 9641 9642 if (arg%nodeType /= ELEMENT_NODE) then 9643 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9644 call throw_exception(FoX_INVALID_NODE, "setAttributeNS", ex) 9645 if (present(ex)) then 9646 if (inException(ex)) then 9647 return 9648 endif 9649 endif 9650endif 9651 9652 elseif (arg%readonly) then 9653 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 9654 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNS", ex) 9655 if (present(ex)) then 9656 if (inException(ex)) then 9657 return 9658 endif 9659 endif 9660endif 9661 9662 elseif (.not.checkName(qualifiedname, getXmlVersionEnum(getOwnerDocument(arg)))) then 9663 if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then 9664 call throw_exception(INVALID_CHARACTER_ERR, "setAttributeNS", ex) 9665 if (present(ex)) then 9666 if (inException(ex)) then 9667 return 9668 endif 9669 endif 9670endif 9671 9672 endif 9673 if (.not.arg%ownerDocument%docExtras%brokenNS) then 9674 if (.not.checkQName(qualifiedname, getXmlVersionEnum(getOwnerDocument(arg)))) then 9675 if (getFoX_checks().or.NAMESPACE_ERR<200) then 9676 call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) 9677 if (present(ex)) then 9678 if (inException(ex)) then 9679 return 9680 endif 9681 endif 9682endif 9683 9684 elseif (prefixOfQName(qualifiedName)/="" & 9685 .and. namespaceURI=="") then 9686 if (getFoX_checks().or.NAMESPACE_ERR<200) then 9687 call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) 9688 if (present(ex)) then 9689 if (inException(ex)) then 9690 return 9691 endif 9692 endif 9693endif 9694 9695 elseif (prefixOfQName(qualifiedName)=="xml" .neqv. & 9696 namespaceURI=="http://www.w3.org/XML/1998/namespace") then 9697 if (getFoX_checks().or.NAMESPACE_ERR<200) then 9698 call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) 9699 if (present(ex)) then 9700 if (inException(ex)) then 9701 return 9702 endif 9703 endif 9704endif 9705 9706 elseif (namespaceURI=="http://www.w3.org/2000/xmlns/" .neqv. & 9707 (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns")) then 9708 if (getFoX_checks().or.NAMESPACE_ERR<200) then 9709 call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) 9710 if (present(ex)) then 9711 if (inException(ex)) then 9712 return 9713 endif 9714 endif 9715endif 9716 9717 endif 9718 endif 9719 9720! FIXME what if namespace is undeclared? Throw an error *only* if FoX_errors is 9721! on, otherwise its taken care of by namespace fixup on serialization 9722 9723 quickFix = getGCstate(getOwnerDocument(arg)) & 9724 .and. arg%inDocument 9725 9726 if (quickFix) call setGCstate(getOwnerDocument(arg), .false.) 9727 ! then the created attribute is going straight into the document, 9728 ! so dont faff with hanging-node lists. 9729 9730 nn => createAttributeNS(arg%ownerDocument, namespaceURI, qualifiedname) 9731 call setValue(nn, value) 9732 dummy => setNamedItemNS(getAttributes(arg), nn) 9733 9734 if (associated(dummy)) then 9735 if (getGCstate(getOwnerDocument(arg)).and..not.dummy%inDocument) & 9736 call putNodesInDocument(getOwnerDocument(arg), dummy) 9737 ! ... so that dummy & children are removed from hangingNodes list. 9738 call destroyAllNodesRecursively(dummy) 9739 endif 9740 9741 if (quickFix) call setGCstate(getOwnerDocument(arg), .true.) 9742 9743 end subroutine setAttributeNS 9744 9745 9746 subroutine removeAttributeNS(arg, namespaceURI, localName, ex) 9747 type(DOMException), intent(out), optional :: ex 9748 type(Node), pointer :: arg 9749 character(len=*), intent(in) :: namespaceURI 9750 character(len=*), intent(in) :: localName 9751 9752 type(DOMException) :: ex2 9753 type(Node), pointer :: dummy 9754 integer :: e 9755 9756 if (.not.associated(arg)) then 9757 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9758 call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNS", ex) 9759 if (present(ex)) then 9760 if (inException(ex)) then 9761 return 9762 endif 9763 endif 9764endif 9765 9766 endif 9767 9768 if (arg%nodeType /= ELEMENT_NODE) then 9769 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9770 call throw_exception(FoX_INVALID_NODE, "removeAttributeNS", ex) 9771 if (present(ex)) then 9772 if (inException(ex)) then 9773 return 9774 endif 9775 endif 9776endif 9777 9778 elseif (arg%readonly) then 9779 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 9780 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeAttributeNS", ex) 9781 if (present(ex)) then 9782 if (inException(ex)) then 9783 return 9784 endif 9785 endif 9786endif 9787 9788 endif 9789 9790 if (arg%inDocument) & 9791 call setGCstate(getOwnerDocument(arg), .false.) 9792 ! So we dont add the removed nodes to the hanging node list 9793 9794 dummy => removeNamedItemNS(getAttributes(arg), namespaceURI, localName, ex2) 9795 ! removeNamedItemNS took care of any default attributes 9796 if (inException(ex2)) then 9797 e = getExceptionCode(ex2) 9798 if (e/=NOT_FOUND_ERR) then 9799 if (getFoX_checks().or.e<200) then 9800 call throw_exception(e, "removeAttributeNS", ex) 9801 if (present(ex)) then 9802 if (inException(ex)) then 9803 return 9804 endif 9805 endif 9806endif 9807 9808 endif 9809 else 9810 if (.not.arg%inDocument) then 9811 ! dummy was not in the doc, so was already on hangingNode list. 9812 ! To remove it from the list: 9813 call putNodesInDocument(arg%ownerDocument, dummy) 9814 endif 9815 call destroyAllNodesRecursively(dummy) 9816 endif 9817 9818 if (arg%inDocument) & 9819 call setGCstate(arg%ownerDocument, .true.) 9820 9821 end subroutine removeAttributeNS 9822 9823 9824 function getAttributeNodeNS(arg, namespaceURI, localName, ex)result(attr) 9825 type(DOMException), intent(out), optional :: ex 9826 type(Node), pointer :: arg 9827 character(len=*), intent(in) :: namespaceURI 9828 character(len=*), intent(in) :: localName 9829 type(Node), pointer :: attr 9830 9831 if (.not.associated(arg)) then 9832 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9833 call throw_exception(FoX_NODE_IS_NULL, "getAttributeNodeNS", ex) 9834 if (present(ex)) then 9835 if (inException(ex)) then 9836 return 9837 endif 9838 endif 9839endif 9840 9841 endif 9842 9843 if (arg%nodeType /= ELEMENT_NODE) then 9844 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9845 call throw_exception(FoX_INVALID_NODE, "getAttributeNodeNS", ex) 9846 if (present(ex)) then 9847 if (inException(ex)) then 9848 return 9849 endif 9850 endif 9851endif 9852 9853 endif 9854 9855 attr => null() ! as per specs, if not found 9856 attr => getNamedItemNS(getAttributes(arg), namespaceURI, localname) 9857 end function getAttributeNodeNS 9858 9859 9860 function setAttributeNodeNS(arg, newattr, ex)result(attr) 9861 type(DOMException), intent(out), optional :: ex 9862 type(Node), pointer :: arg 9863 type(Node), pointer :: newattr 9864 type(Node), pointer :: attr 9865 type(Node), pointer :: dummy 9866 9867 if (.not.associated(arg)) then 9868 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9869 call throw_exception(FoX_NODE_IS_NULL, "setAttributeNodeNS", ex) 9870 if (present(ex)) then 9871 if (inException(ex)) then 9872 return 9873 endif 9874 endif 9875endif 9876 9877 endif 9878 9879 if (arg%nodeType /= ELEMENT_NODE) then 9880 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9881 call throw_exception(FoX_INVALID_NODE, "setAttributeNodeNS", ex) 9882 if (present(ex)) then 9883 if (inException(ex)) then 9884 return 9885 endif 9886 endif 9887endif 9888 9889 elseif (.not.associated(arg%ownerDocument, newattr%ownerDocument)) then 9890 if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then 9891 call throw_exception(WRONG_DOCUMENT_ERR, "setAttributeNodeNS", ex) 9892 if (present(ex)) then 9893 if (inException(ex)) then 9894 return 9895 endif 9896 endif 9897endif 9898 9899 elseif (arg%readonly) then 9900 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 9901 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNodeNS", ex) 9902 if (present(ex)) then 9903 if (inException(ex)) then 9904 return 9905 endif 9906 endif 9907endif 9908 9909 endif 9910 9911 if (associated(getOwnerElement(newattr), arg)) then 9912 attr => newattr 9913 return 9914 ! Nothing to do, this attribute is already in this element 9915 elseif (associated(getOwnerElement(newattr))) then 9916 if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then 9917 call throw_exception(INUSE_ATTRIBUTE_ERR, "setAttributeNodeNS", ex) 9918 if (present(ex)) then 9919 if (inException(ex)) then 9920 return 9921 endif 9922 endif 9923endif 9924 9925 endif 9926 9927 ! this checks if attribute exists already 9928 ! It also does any adding/removing of hangingnodes 9929 ! and sets ownerElement appropriately 9930 dummy => setNamedItemNS(getAttributes(arg), newattr, ex) 9931 attr => dummy 9932 9933 end function setAttributeNodeNS 9934 9935 9936 function removeAttributeNodeNS(arg, oldattr, ex)result(attr) 9937 type(DOMException), intent(out), optional :: ex 9938 type(Node), pointer :: arg 9939 type(Node), pointer :: oldattr 9940 type(Node), pointer :: attr 9941 9942 if (.not.associated(arg)) then 9943 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9944 call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNodeNS", ex) 9945 if (present(ex)) then 9946 if (inException(ex)) then 9947 return 9948 endif 9949 endif 9950endif 9951 9952 endif 9953 9954 if (arg%nodeType /= ELEMENT_NODE) then 9955 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 9956 call throw_exception(FoX_INVALID_NODE, "removeAttributeNodeNS", ex) 9957 if (present(ex)) then 9958 if (inException(ex)) then 9959 return 9960 endif 9961 endif 9962endif 9963 9964 endif 9965 9966 if (.not.associated(arg, getOwnerElement(oldattr))) then 9967 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 9968 call throw_exception(NOT_FOUND_ERR, "removeAttributeNodeNS", ex) 9969 if (present(ex)) then 9970 if (inException(ex)) then 9971 return 9972 endif 9973 endif 9974endif 9975 9976 endif 9977 9978 attr => removeNamedItemNS(getAttributes(arg), & 9979 getNamespaceURI(oldattr), getLocalName(oldattr), ex) 9980 9981 end function removeAttributeNodeNS 9982 9983 9984! function getElementsByTagNameNS - see m_dom_document 9985 9986 9987 function hasAttribute(arg, name, ex)result(p) 9988 type(DOMException), intent(out), optional :: ex 9989 type(Node), pointer :: arg 9990 character(len=*), intent(in) :: name 9991 logical :: p 9992 9993 integer :: i 9994 type(Node), pointer :: attr 9995 9996 if (.not.associated(arg)) then 9997 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 9998 call throw_exception(FoX_NODE_IS_NULL, "hasAttribute", ex) 9999 if (present(ex)) then 10000 if (inException(ex)) then 10001 return 10002 endif 10003 endif 10004endif 10005 10006 endif 10007 10008 if (arg%nodeType /= ELEMENT_NODE) then 10009 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10010 call throw_exception(FoX_INVALID_NODE, "hasAttribute", ex) 10011 if (present(ex)) then 10012 if (inException(ex)) then 10013 return 10014 endif 10015 endif 10016endif 10017 10018 endif 10019 10020 p = .false. 10021 do i = 0, getLength(getAttributes(arg)) - 1 10022 attr => item(getAttributes(arg), i) 10023 if (getNodeName(attr)==name) then 10024 p = .true. 10025 exit 10026 endif 10027 enddo 10028 10029 end function hasAttribute 10030 10031 10032 function hasAttributeNS(arg, namespaceURI, localName, ex)result(p) 10033 type(DOMException), intent(out), optional :: ex 10034 type(Node), pointer :: arg 10035 character(len=*), intent(in) :: namespaceURI 10036 character(len=*), intent(in) :: localName 10037 logical :: p 10038 10039 integer :: i 10040 type(Node), pointer :: attr 10041 10042 if (.not.associated(arg)) then 10043 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10044 call throw_exception(FoX_NODE_IS_NULL, "hasAttributeNS", ex) 10045 if (present(ex)) then 10046 if (inException(ex)) then 10047 return 10048 endif 10049 endif 10050endif 10051 10052 endif 10053 10054 if (arg%nodeType /= ELEMENT_NODE) then 10055 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10056 call throw_exception(FoX_INVALID_NODE, "hasAttributeNS", ex) 10057 if (present(ex)) then 10058 if (inException(ex)) then 10059 return 10060 endif 10061 endif 10062endif 10063 10064 endif 10065 10066 p = .false. 10067 do i = 0, getLength(getAttributes(arg))-1 10068 attr => item(getAttributes(arg), i) 10069 if (getNamespaceURI(attr)==namespaceURI & 10070 .and. getLocalName(attr)==localName) then 10071 p = .true. 10072 exit 10073 endif 10074 enddo 10075 10076 end function hasAttributeNS 10077 10078 subroutine setIdAttribute(arg, name, isId, ex) 10079 type(DOMException), intent(out), optional :: ex 10080 type(Node), pointer :: arg 10081 character(len=*), intent(in) :: name 10082 logical, intent(in) :: isId 10083 10084 type(Node), pointer :: np 10085 10086 if (arg%readonly) then 10087 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 10088 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttribute", ex) 10089 if (present(ex)) then 10090 if (inException(ex)) then 10091 return 10092 endif 10093 endif 10094endif 10095 10096 endif 10097 10098 np => getAttributeNode(arg, name) 10099 if (associated(np)) then 10100 call setIsId(np, isId) 10101 else 10102 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 10103 call throw_exception(NOT_FOUND_ERR, "setIdAttribute", ex) 10104 if (present(ex)) then 10105 if (inException(ex)) then 10106 return 10107 endif 10108 endif 10109endif 10110 10111 endif 10112 10113 end subroutine setIdAttribute 10114 10115 subroutine setIdAttributeNS(arg, namespaceURI, localname, isId, ex) 10116 type(DOMException), intent(out), optional :: ex 10117 type(Node), pointer :: arg 10118 character(len=*), intent(in) :: namespaceURI 10119 character(len=*), intent(in) :: localName 10120 logical, intent(in) :: isId 10121 10122 type(Node), pointer :: np 10123 10124 if (arg%readonly) then 10125 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 10126 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttributeNS", ex) 10127 if (present(ex)) then 10128 if (inException(ex)) then 10129 return 10130 endif 10131 endif 10132endif 10133 10134 endif 10135 10136 np => getAttributeNodeNS(arg, namespaceURI, localname) 10137 if (associated(np)) then 10138 call setIsId(np, isId) 10139 else 10140 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 10141 call throw_exception(NOT_FOUND_ERR, "setIdAttributeNS", ex) 10142 if (present(ex)) then 10143 if (inException(ex)) then 10144 return 10145 endif 10146 endif 10147endif 10148 10149 endif 10150 10151 end subroutine setIdAttributeNS 10152 10153 subroutine setIdAttributeNode(arg, idAttr, isId, ex) 10154 type(DOMException), intent(out), optional :: ex 10155 type(Node), pointer :: arg 10156 type(Node), pointer :: idAttr 10157 logical, intent(in) :: isId 10158 10159 if (arg%readonly) then 10160 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 10161 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttributeNode", ex) 10162 if (present(ex)) then 10163 if (inException(ex)) then 10164 return 10165 endif 10166 endif 10167endif 10168 10169 elseif (.not.associated(arg, getOwnerElement(idAttr))) then 10170 if (getFoX_checks().or.NOT_FOUND_ERR<200) then 10171 call throw_exception(NOT_FOUND_ERR, "setIdAttributeNode", ex) 10172 if (present(ex)) then 10173 if (inException(ex)) then 10174 return 10175 endif 10176 endif 10177endif 10178 10179 endif 10180 10181 call setIsId(idAttr, isId) 10182 10183 end subroutine setIdAttributeNode 10184 10185 10186 10187 ! function getName(attribute) result(c) See m_dom_common 10188 10189! NB All functions manipulating attributes play with the nodelist 10190! directly rather than through helper functions. 10191! This is so that getValue_length can be pure, and the nodeList 10192! can be explicitly kept up to dat. 10193 10194function getspecified(np, ex)result(c) 10195 type(DOMException), intent(out), optional :: ex 10196 type(Node), pointer :: np 10197 logical :: c 10198 10199 10200 if (.not.associated(np)) then 10201 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10202 call throw_exception(FoX_NODE_IS_NULL, "getspecified", ex) 10203 if (present(ex)) then 10204 if (inException(ex)) then 10205 return 10206 endif 10207 endif 10208endif 10209 10210 endif 10211 10212 if (getNodeType(np)/=ATTRIBUTE_NODE .and. & 10213 .true.) then 10214 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10215 call throw_exception(FoX_INVALID_NODE, "getspecified", ex) 10216 if (present(ex)) then 10217 if (inException(ex)) then 10218 return 10219 endif 10220 endif 10221endif 10222 10223 endif 10224 10225 c = np%elExtras%specified 10226 10227 end function getspecified 10228 10229 10230subroutine setspecified(np, c, ex) 10231 type(DOMException), intent(out), optional :: ex 10232 type(Node), pointer :: np 10233 logical :: c 10234 10235 10236 if (.not.associated(np)) then 10237 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10238 call throw_exception(FoX_NODE_IS_NULL, "setspecified", ex) 10239 if (present(ex)) then 10240 if (inException(ex)) then 10241 return 10242 endif 10243 endif 10244endif 10245 10246 endif 10247 10248 if (getNodeType(np)/=ATTRIBUTE_NODE .and. & 10249 .true.) then 10250 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10251 call throw_exception(FoX_INVALID_NODE, "setspecified", ex) 10252 if (present(ex)) then 10253 if (inException(ex)) then 10254 return 10255 endif 10256 endif 10257endif 10258 10259 endif 10260 10261 np%elExtras%specified = c 10262 10263 end subroutine setspecified 10264 10265 10266function getisId_DOM(np, ex)result(c) 10267 type(DOMException), intent(out), optional :: ex 10268 type(Node), pointer :: np 10269 logical :: c 10270 10271 10272 if (.not.associated(np)) then 10273 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10274 call throw_exception(FoX_NODE_IS_NULL, "getisId_DOM", ex) 10275 if (present(ex)) then 10276 if (inException(ex)) then 10277 return 10278 endif 10279 endif 10280endif 10281 10282 endif 10283 10284 if (getNodeType(np)/=ATTRIBUTE_NODE .and. & 10285 .true.) then 10286 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10287 call throw_exception(FoX_INVALID_NODE, "getisId_DOM", ex) 10288 if (present(ex)) then 10289 if (inException(ex)) then 10290 return 10291 endif 10292 endif 10293endif 10294 10295 endif 10296 10297 c = np%elExtras%isId 10298 10299 end function getisId_DOM 10300 10301 10302subroutine setisId_DOM(np, c, ex) 10303 type(DOMException), intent(out), optional :: ex 10304 type(Node), pointer :: np 10305 logical :: c 10306 10307 10308 if (.not.associated(np)) then 10309 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10310 call throw_exception(FoX_NODE_IS_NULL, "setisId_DOM", ex) 10311 if (present(ex)) then 10312 if (inException(ex)) then 10313 return 10314 endif 10315 endif 10316endif 10317 10318 endif 10319 10320 if (getNodeType(np)/=ATTRIBUTE_NODE .and. & 10321 .true.) then 10322 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10323 call throw_exception(FoX_INVALID_NODE, "setisId_DOM", ex) 10324 if (present(ex)) then 10325 if (inException(ex)) then 10326 return 10327 endif 10328 endif 10329endif 10330 10331 endif 10332 10333 np%elExtras%isId = c 10334 10335 end subroutine setisId_DOM 10336 10337 10338function getownerElement(np, ex)result(c) 10339 type(DOMException), intent(out), optional :: ex 10340 type(Node), pointer :: np 10341 type(Node), pointer :: c 10342 10343 10344 if (.not.associated(np)) then 10345 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10346 call throw_exception(FoX_NODE_IS_NULL, "getownerElement", ex) 10347 if (present(ex)) then 10348 if (inException(ex)) then 10349 return 10350 endif 10351 endif 10352endif 10353 10354 endif 10355 10356 if (getNodeType(np)/=ATTRIBUTE_NODE .and. & 10357 .true.) then 10358 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10359 call throw_exception(FoX_INVALID_NODE, "getownerElement", ex) 10360 if (present(ex)) then 10361 if (inException(ex)) then 10362 return 10363 endif 10364 endif 10365endif 10366 10367 endif 10368 10369 c => np%elExtras%ownerElement 10370 10371 end function getownerElement 10372 10373 10374 function getValue_DOM(arg, ex)result(c) 10375 type(DOMException), intent(out), optional :: ex 10376 type(Node), pointer :: arg 10377#ifdef RESTRICTED_ASSOCIATED_BUG 10378 character(len=getTextContent_len(arg, .true.)) :: c 10379#else 10380 character(len=getTextContent_len(arg, associated(arg))) :: c 10381#endif 10382 10383 if (.not.associated(arg)) then 10384 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10385 call throw_exception(FoX_NODE_IS_NULL, "getValue_DOM", ex) 10386 if (present(ex)) then 10387 if (inException(ex)) then 10388 return 10389 endif 10390 endif 10391endif 10392 10393 endif 10394 10395 if (getNodeType(arg)/=ATTRIBUTE_NODE) then 10396 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10397 call throw_exception(FoX_INVALID_NODE, "getValue_DOM", ex) 10398 if (present(ex)) then 10399 if (inException(ex)) then 10400 return 10401 endif 10402 endif 10403endif 10404 10405 endif 10406 10407 c = getTextContent(arg, ex) 10408 10409 end function getValue_DOM 10410 10411 subroutine setValue(arg, value, ex) 10412 type(DOMException), intent(out), optional :: ex 10413 type(Node), pointer :: arg 10414 character(len=*), intent(in) :: value 10415 10416 if (.not.associated(arg)) then 10417 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10418 call throw_exception(FoX_NODE_IS_NULL, "setValue", ex) 10419 if (present(ex)) then 10420 if (inException(ex)) then 10421 return 10422 endif 10423 endif 10424endif 10425 10426 endif 10427 10428 if (getNodeType(arg)/=ATTRIBUTE_NODE) then 10429 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10430 call throw_exception(FoX_INVALID_NODE, "setValue", ex) 10431 if (present(ex)) then 10432 if (inException(ex)) then 10433 return 10434 endif 10435 endif 10436endif 10437 10438 endif 10439 10440 call setTextContent(arg, value, ex) 10441 10442 end subroutine setValue 10443 10444 10445 10446 pure function isCharData(nodeType) result(p) 10447 integer, intent(in) :: nodeType 10448 logical :: p 10449 10450 p = (nodeType == TEXT_NODE .or. & 10451 nodeType == COMMENT_NODE .or. & 10452 nodeType == CDATA_SECTION_NODE) 10453 end function isCharData 10454 10455 10456 function getLength_characterdata(arg, ex)result(n) 10457 type(DOMException), intent(out), optional :: ex 10458 type(Node), pointer :: arg 10459 integer :: n 10460 10461 if (.not.associated(arg)) then 10462 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10463 call throw_exception(FoX_NODE_IS_NULL, "getLength_characterdata", ex) 10464 if (present(ex)) then 10465 if (inException(ex)) then 10466 return 10467 endif 10468 endif 10469endif 10470 10471 endif 10472 10473 if (.not.isCharData(arg%nodeType)) then 10474 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10475 call throw_exception(FoX_INVALID_NODE, "getLength_characterdata", ex) 10476 if (present(ex)) then 10477 if (inException(ex)) then 10478 return 10479 endif 10480 endif 10481endif 10482 10483 endif 10484 10485 n = size(arg%nodeValue) 10486 10487 end function getLength_characterdata 10488 10489 10490 function subStringData(arg, offset, count, ex)result(c) 10491 type(DOMException), intent(out), optional :: ex 10492 type(Node), pointer :: arg 10493 integer, intent(in) :: offset 10494 integer, intent(in) :: count 10495 character(len=count) :: c 10496 10497 if (.not.associated(arg)) then 10498 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10499 call throw_exception(FoX_NODE_IS_NULL, "subStringData", ex) 10500 if (present(ex)) then 10501 if (inException(ex)) then 10502 return 10503 endif 10504 endif 10505endif 10506 10507 endif 10508 10509 if (.not.isCharData(arg%nodeType)) then 10510 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10511 call throw_exception(FoX_INVALID_NODE, "subStringData", ex) 10512 if (present(ex)) then 10513 if (inException(ex)) then 10514 return 10515 endif 10516 endif 10517endif 10518 10519 elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then 10520 if (getFoX_checks().or.INDEX_SIZE_ERR<200) then 10521 call throw_exception(INDEX_SIZE_ERR, "subStringData", ex) 10522 if (present(ex)) then 10523 if (inException(ex)) then 10524 return 10525 endif 10526 endif 10527endif 10528 10529 endif 10530 10531 if (offset+count>size(arg%nodeValue)) then 10532 c = str_vs(arg%nodeValue(offset+1:)) 10533 else 10534 c = str_vs(arg%nodeValue(offset+1:offset+count)) 10535 endif 10536 10537 end function subStringData 10538 10539 10540 subroutine appendData(arg, data, ex) 10541 type(DOMException), intent(out), optional :: ex 10542 type(Node), pointer :: arg 10543 character(len=*), intent(in) :: data 10544 10545 character, pointer :: tmp(:) 10546 10547 if (.not.associated(arg)) then 10548 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10549 call throw_exception(FoX_NODE_IS_NULL, "appendData", ex) 10550 if (present(ex)) then 10551 if (inException(ex)) then 10552 return 10553 endif 10554 endif 10555endif 10556 10557 endif 10558 10559 if (.not.isCharData(arg%nodeType)) then 10560 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10561 call throw_exception(FoX_INVALID_NODE, "appendData", ex) 10562 if (present(ex)) then 10563 if (inException(ex)) then 10564 return 10565 endif 10566 endif 10567endif 10568 10569 elseif (arg%readonly) then 10570 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 10571 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "appendData", ex) 10572 if (present(ex)) then 10573 if (inException(ex)) then 10574 return 10575 endif 10576 endif 10577endif 10578 10579 endif 10580 10581 if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then 10582 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 10583 call throw_exception(FoX_INVALID_CHARACTER, "appendData", ex) 10584 if (present(ex)) then 10585 if (inException(ex)) then 10586 return 10587 endif 10588 endif 10589endif 10590 10591 endif 10592 10593 tmp => arg%nodeValue 10594 arg%nodeValue => vs_str_alloc(str_vs(tmp)//data) 10595 deallocate(tmp) 10596 10597 ! We have to do these checks *after* appending data in case offending string 10598 ! spans old & new data 10599 if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then 10600 if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then 10601 call throw_exception(FoX_INVALID_COMMENT, "appendData", ex) 10602 if (present(ex)) then 10603 if (inException(ex)) then 10604 return 10605 endif 10606 endif 10607endif 10608 10609 elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then 10610 if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then 10611 call throw_exception(FoX_INVALID_CDATA_SECTION, "appendData", ex) 10612 if (present(ex)) then 10613 if (inException(ex)) then 10614 return 10615 endif 10616 endif 10617endif 10618 10619 endif 10620 10621 ! And propagate length upwards ... 10622 if (getNodeType(arg)/=COMMENT_NODE) & 10623 call updateTextContentLength(arg, len(data)) 10624 10625 end subroutine appendData 10626 10627 10628 subroutine insertData(arg, offset, data, ex) 10629 type(DOMException), intent(out), optional :: ex 10630 type(Node), pointer :: arg 10631 integer, intent(in) :: offset 10632 character(len=*), intent(in) :: data 10633 10634 character, pointer :: tmp(:) 10635 10636 if (.not.associated(arg)) then 10637 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10638 call throw_exception(FoX_NODE_IS_NULL, "insertData", ex) 10639 if (present(ex)) then 10640 if (inException(ex)) then 10641 return 10642 endif 10643 endif 10644endif 10645 10646 endif 10647 10648 if (.not.isCharData(arg%nodeType)) then 10649 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10650 call throw_exception(FoX_INVALID_NODE, "insertData", ex) 10651 if (present(ex)) then 10652 if (inException(ex)) then 10653 return 10654 endif 10655 endif 10656endif 10657 10658 elseif (arg%readonly) then 10659 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 10660 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "insertData", ex) 10661 if (present(ex)) then 10662 if (inException(ex)) then 10663 return 10664 endif 10665 endif 10666endif 10667 10668 elseif (offset<0.or.offset>size(arg%nodeValue)) then 10669 if (getFoX_checks().or.INDEX_SIZE_ERR<200) then 10670 call throw_exception(INDEX_SIZE_ERR, "insertData", ex) 10671 if (present(ex)) then 10672 if (inException(ex)) then 10673 return 10674 endif 10675 endif 10676endif 10677 10678 endif 10679 10680 if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then 10681 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 10682 call throw_exception(FoX_INVALID_CHARACTER, "insertData", ex) 10683 if (present(ex)) then 10684 if (inException(ex)) then 10685 return 10686 endif 10687 endif 10688endif 10689 10690 endif 10691 10692 tmp => arg%nodeValue 10693 arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data//str_vs(tmp(offset+1:))) 10694 deallocate(tmp) 10695 10696 ! We have to do these checks *after* appending data in case offending string 10697 ! spans old & new data 10698 if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then 10699 if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then 10700 call throw_exception(FoX_INVALID_COMMENT, "insertData", ex) 10701 if (present(ex)) then 10702 if (inException(ex)) then 10703 return 10704 endif 10705 endif 10706endif 10707 10708 elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then 10709 if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then 10710 call throw_exception(FoX_INVALID_CDATA_SECTION, "insertData", ex) 10711 if (present(ex)) then 10712 if (inException(ex)) then 10713 return 10714 endif 10715 endif 10716endif 10717 10718 endif 10719 10720 ! And propagate length upwards ... 10721 if (getNodeType(arg)/=COMMENT_NODE) & 10722 call updateTextContentLength(arg, len(data)) 10723 10724 end subroutine insertData 10725 10726 10727 subroutine deleteData(arg, offset, count, ex) 10728 type(DOMException), intent(out), optional :: ex 10729 type(Node), pointer :: arg 10730 integer, intent(in) :: offset 10731 integer, intent(in) :: count 10732 10733 character, pointer :: tmp(:) 10734 integer :: n 10735 10736 if (.not.associated(arg)) then 10737 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10738 call throw_exception(FoX_NODE_IS_NULL, "deleteData", ex) 10739 if (present(ex)) then 10740 if (inException(ex)) then 10741 return 10742 endif 10743 endif 10744endif 10745 10746 endif 10747 10748 if (.not.isCharData(arg%nodeType)) then 10749 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10750 call throw_exception(FoX_INVALID_NODE, "deleteData", ex) 10751 if (present(ex)) then 10752 if (inException(ex)) then 10753 return 10754 endif 10755 endif 10756endif 10757 10758 elseif (arg%readonly) then 10759 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 10760 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "deleteData", ex) 10761 if (present(ex)) then 10762 if (inException(ex)) then 10763 return 10764 endif 10765 endif 10766endif 10767 10768 elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then 10769 if (getFoX_checks().or.INDEX_SIZE_ERR<200) then 10770 call throw_exception(INDEX_SIZE_ERR, "deleteData", ex) 10771 if (present(ex)) then 10772 if (inException(ex)) then 10773 return 10774 endif 10775 endif 10776endif 10777 10778 endif 10779 10780 if (offset+count>size(arg%nodeValue)) then 10781 n = size(arg%nodeValue)-offset 10782 else 10783 n = count 10784 endif 10785 10786 tmp => arg%nodeValue 10787 arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//str_vs(tmp(offset+count+1:))) 10788 deallocate(tmp) 10789 10790 ! And propagate length upwards ... 10791 if (getNodeType(arg)/=COMMENT_NODE) & 10792 call updateTextContentLength(arg, -n) 10793 10794 end subroutine deleteData 10795 10796 10797 subroutine replaceData(arg, offset, count, data, ex) 10798 type(DOMException), intent(out), optional :: ex 10799 type(Node), pointer :: arg 10800 integer, intent(in) :: offset 10801 integer, intent(in) :: count 10802 character(len=*), intent(in) :: data 10803 10804 character, pointer :: tmp(:) 10805 integer :: n 10806 10807 if (.not.associated(arg)) then 10808 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10809 call throw_exception(FoX_NODE_IS_NULL, "replaceData", ex) 10810 if (present(ex)) then 10811 if (inException(ex)) then 10812 return 10813 endif 10814 endif 10815endif 10816 10817 endif 10818 10819 if (.not.isCharData(arg%nodeType)) then 10820 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10821 call throw_exception(FoX_INVALID_NODE, "replaceData", ex) 10822 if (present(ex)) then 10823 if (inException(ex)) then 10824 return 10825 endif 10826 endif 10827endif 10828 10829 elseif (arg%readonly) then 10830 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 10831 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "replaceData", ex) 10832 if (present(ex)) then 10833 if (inException(ex)) then 10834 return 10835 endif 10836 endif 10837endif 10838 10839 elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then 10840 if (getFoX_checks().or.INDEX_SIZE_ERR<200) then 10841 call throw_exception(INDEX_SIZE_ERR, "replaceData", ex) 10842 if (present(ex)) then 10843 if (inException(ex)) then 10844 return 10845 endif 10846 endif 10847endif 10848 10849 endif 10850 10851 if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then 10852 if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then 10853 call throw_exception(FoX_INVALID_CHARACTER, "replaceData", ex) 10854 if (present(ex)) then 10855 if (inException(ex)) then 10856 return 10857 endif 10858 endif 10859endif 10860 10861 endif 10862 10863 if (offset+count>size(arg%nodeValue)) then 10864 n = len(data)-(size(arg%nodeValue)-offset) 10865 else 10866 n = len(data)-count 10867 endif 10868 10869 tmp => arg%nodeValue 10870 if (offset+count <= size(arg%nodeValue)) then 10871 arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data//str_vs(tmp(offset+count+1:))) 10872 else 10873 arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data) 10874 endif 10875 deallocate(tmp) 10876 10877 ! We have to do these checks *after* appending data in case offending string 10878 ! spans old & new data 10879 if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then 10880 if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then 10881 call throw_exception(FoX_INVALID_COMMENT, "replaceData", ex) 10882 if (present(ex)) then 10883 if (inException(ex)) then 10884 return 10885 endif 10886 endif 10887endif 10888 10889 elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then 10890 if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then 10891 call throw_exception(FoX_INVALID_CDATA_SECTION, "replaceData", ex) 10892 if (present(ex)) then 10893 if (inException(ex)) then 10894 return 10895 endif 10896 endif 10897endif 10898 10899 endif 10900 10901 ! And propagate length upwards ... 10902 if (getNodeType(arg)/=COMMENT_NODE) & 10903 call updateTextContentLength(arg, n) 10904 10905 end subroutine replaceData 10906 10907 10908 10909 10910 pure function getnotationName_len(np, p) result(n) 10911 type(Node), intent(in) :: np 10912 logical, intent(in) :: p 10913 integer :: n 10914 10915 if (p .and. ( & 10916 np%nodeType==ENTITY_NODE .or. & 10917 .false.)) then 10918 n = size(np%dtdExtras%notationName) 10919 else 10920 n = 0 10921 endif 10922 end function getnotationName_len 10923function getnotationName(np, ex)result(c) 10924 type(DOMException), intent(out), optional :: ex 10925 type(Node), pointer :: np 10926#ifdef RESTRICTED_ASSOCIATED_BUG 10927 character(len=getnotationName_len(np, .true.)) :: c 10928#else 10929 character(len=getnotationName_len(np, associated(np))) :: c 10930#endif 10931 10932 10933 if (.not.associated(np)) then 10934 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10935 call throw_exception(FoX_NODE_IS_NULL, "getnotationName", ex) 10936 if (present(ex)) then 10937 if (inException(ex)) then 10938 return 10939 endif 10940 endif 10941endif 10942 10943 endif 10944 10945 if (getNodeType(np)/=ENTITY_NODE .and. & 10946 .true.) then 10947 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10948 call throw_exception(FoX_INVALID_NODE, "getnotationName", ex) 10949 if (present(ex)) then 10950 if (inException(ex)) then 10951 return 10952 endif 10953 endif 10954endif 10955 10956 endif 10957 10958 c = str_vs(np%dtdExtras%notationName) 10959 10960 end function getnotationName 10961 10962 10963!Internally-used getters/setters: 10964 10965 function getillFormed(np, ex)result(c) 10966 type(DOMException), intent(out), optional :: ex 10967 type(Node), pointer :: np 10968 logical :: c 10969 10970 10971 if (.not.associated(np)) then 10972 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 10973 call throw_exception(FoX_NODE_IS_NULL, "getillFormed", ex) 10974 if (present(ex)) then 10975 if (inException(ex)) then 10976 return 10977 endif 10978 endif 10979endif 10980 10981 endif 10982 10983 if (getNodeType(np)/=ENTITY_NODE .and. & 10984 .true.) then 10985 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 10986 call throw_exception(FoX_INVALID_NODE, "getillFormed", ex) 10987 if (present(ex)) then 10988 if (inException(ex)) then 10989 return 10990 endif 10991 endif 10992endif 10993 10994 endif 10995 10996 c = np%dtdExtras%illFormed 10997 10998 end function getillFormed 10999 11000 subroutine setillFormed(np, c, ex) 11001 type(DOMException), intent(out), optional :: ex 11002 type(Node), pointer :: np 11003 logical :: c 11004 11005 11006 if (.not.associated(np)) then 11007 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11008 call throw_exception(FoX_NODE_IS_NULL, "setillFormed", ex) 11009 if (present(ex)) then 11010 if (inException(ex)) then 11011 return 11012 endif 11013 endif 11014endif 11015 11016 endif 11017 11018 if (getNodeType(np)/=ENTITY_NODE .and. & 11019 .true.) then 11020 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11021 call throw_exception(FoX_INVALID_NODE, "setillFormed", ex) 11022 if (present(ex)) then 11023 if (inException(ex)) then 11024 return 11025 endif 11026 endif 11027endif 11028 11029 endif 11030 11031 np%dtdExtras%illFormed = c 11032 11033 end subroutine setillFormed 11034 11035 11036 11037 pure function getstringValue_len(np, p) result(n) 11038 type(Node), intent(in) :: np 11039 logical, intent(in) :: p 11040 integer :: n 11041 11042 if (p .and. ( & 11043 np%nodeType==ENTITY_NODE .or. & 11044 .false.)) then 11045 n = size(np%nodeValue) 11046 else 11047 n = 0 11048 endif 11049 end function getstringValue_len 11050function getstringValue(np, ex)result(c) 11051 type(DOMException), intent(out), optional :: ex 11052 type(Node), pointer :: np 11053#ifdef RESTRICTED_ASSOCIATED_BUG 11054 character(len=getstringValue_len(np, .true.)) :: c 11055#else 11056 character(len=getstringValue_len(np, associated(np))) :: c 11057#endif 11058 11059 11060 if (.not.associated(np)) then 11061 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11062 call throw_exception(FoX_NODE_IS_NULL, "getstringValue", ex) 11063 if (present(ex)) then 11064 if (inException(ex)) then 11065 return 11066 endif 11067 endif 11068endif 11069 11070 endif 11071 11072 if (getNodeType(np)/=ENTITY_NODE .and. & 11073 .true.) then 11074 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11075 call throw_exception(FoX_INVALID_NODE, "getstringValue", ex) 11076 if (present(ex)) then 11077 if (inException(ex)) then 11078 return 11079 endif 11080 endif 11081endif 11082 11083 endif 11084 11085 c = str_vs(np%nodeValue) 11086 11087 end function getstringValue 11088 11089 subroutine setstringValue(np, c, ex) 11090 type(DOMException), intent(out), optional :: ex 11091 type(Node), pointer :: np 11092 character(len=*) :: c 11093 11094 11095 if (.not.associated(np)) then 11096 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11097 call throw_exception(FoX_NODE_IS_NULL, "setstringValue", ex) 11098 if (present(ex)) then 11099 if (inException(ex)) then 11100 return 11101 endif 11102 endif 11103endif 11104 11105 endif 11106 11107 if (getNodeType(np)/=ENTITY_NODE .and. & 11108 .true.) then 11109 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11110 call throw_exception(FoX_INVALID_NODE, "setstringValue", ex) 11111 if (present(ex)) then 11112 if (inException(ex)) then 11113 return 11114 endif 11115 endif 11116endif 11117 11118 endif 11119 11120 if (associated(np%nodeValue)) deallocate(np%nodeValue) 11121 np%nodeValue => vs_str_alloc(c) 11122 11123 end subroutine setstringValue 11124 11125 11126 11127 11128 11129 pure function getTarget_len(np, p) result(n) 11130 type(Node), intent(in) :: np 11131 logical, intent(in) :: p 11132 integer :: n 11133 11134 if (p .and. ( & 11135 np%nodeType==PROCESSING_INSTRUCTION_NODE .or. & 11136 .false.)) then 11137 n = size(np%nodename) 11138 else 11139 n = 0 11140 endif 11141 end function getTarget_len 11142function getTarget(np, ex)result(c) 11143 type(DOMException), intent(out), optional :: ex 11144 type(Node), pointer :: np 11145#ifdef RESTRICTED_ASSOCIATED_BUG 11146 character(len=getTarget_len(np, .true.)) :: c 11147#else 11148 character(len=getTarget_len(np, associated(np))) :: c 11149#endif 11150 11151 11152 if (.not.associated(np)) then 11153 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11154 call throw_exception(FoX_NODE_IS_NULL, "getTarget", ex) 11155 if (present(ex)) then 11156 if (inException(ex)) then 11157 return 11158 endif 11159 endif 11160endif 11161 11162 endif 11163 11164 if (getNodeType(np)/=PROCESSING_INSTRUCTION_NODE .and. & 11165 .true.) then 11166 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11167 call throw_exception(FoX_INVALID_NODE, "getTarget", ex) 11168 if (present(ex)) then 11169 if (inException(ex)) then 11170 return 11171 endif 11172 endif 11173endif 11174 11175 endif 11176 11177 c = str_vs(np%nodename) 11178 11179 end function getTarget 11180 11181 11182 11183 11184 function splitText(arg, offset, ex)result(np) 11185 type(DOMException), intent(out), optional :: ex 11186 type(Node), pointer :: arg 11187 integer, intent(in) :: offset 11188 11189 type(Node), pointer :: np 11190 11191 character, pointer :: tmp(:) 11192 11193 if (.not.associated(arg)) then 11194 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11195 call throw_exception(FoX_NODE_IS_NULL, "splitText", ex) 11196 if (present(ex)) then 11197 if (inException(ex)) then 11198 return 11199 endif 11200 endif 11201endif 11202 11203 endif 11204 11205 if (.not.(arg%nodeType==TEXT_NODE.or.arg%nodeType==CDATA_SECTION_NODE)) then 11206 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11207 call throw_exception(FoX_INVALID_NODE, "splitText", ex) 11208 if (present(ex)) then 11209 if (inException(ex)) then 11210 return 11211 endif 11212 endif 11213endif 11214 11215 elseif (arg%readonly) then 11216 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 11217 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "splitText", ex) 11218 if (present(ex)) then 11219 if (inException(ex)) then 11220 return 11221 endif 11222 endif 11223endif 11224 11225 elseif (offset<0 .or. offset>size(arg%nodeValue)) then 11226 if (getFoX_checks().or.INDEX_SIZE_ERR<200) then 11227 call throw_exception(INDEX_SIZE_ERR, "splitText", ex) 11228 if (present(ex)) then 11229 if (inException(ex)) then 11230 return 11231 endif 11232 endif 11233endif 11234 11235 endif 11236 11237 tmp => arg%nodeValue 11238 if (arg%nodeType==TEXT_NODE) then 11239 np => createTextNode(arg%ownerDocument, str_vs(tmp(offset+1:))) 11240 elseif (arg%nodeType==CDATA_SECTION_NODE) then 11241 np => createCdataSection(arg%ownerDocument, str_vs(tmp(offset+1:))) 11242 endif 11243 arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))) 11244 deallocate(tmp) 11245 if (associated(arg%parentNode)) then 11246 if (associated(arg%nextSibling)) then 11247 np => insertBefore(arg%parentNode, np, arg%nextSibling) 11248 else 11249 np => appendChild(arg%parentNode, np) 11250 endif 11251 endif 11252 11253 end function splitText 11254 11255function getisElementContentWhitespace(np, ex)result(c) 11256 type(DOMException), intent(out), optional :: ex 11257 type(Node), pointer :: np 11258 logical :: c 11259 11260 11261 if (.not.associated(np)) then 11262 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11263 call throw_exception(FoX_NODE_IS_NULL, "getisElementContentWhitespace", ex) 11264 if (present(ex)) then 11265 if (inException(ex)) then 11266 return 11267 endif 11268 endif 11269endif 11270 11271 endif 11272 11273 if (getNodeType(np)/=TEXT_NODE .and. & 11274getNodeType(np)/=CDATA_SECTION_NODE .and. & 11275 .true.) then 11276 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11277 call throw_exception(FoX_INVALID_NODE, "getisElementContentWhitespace", ex) 11278 if (present(ex)) then 11279 if (inException(ex)) then 11280 return 11281 endif 11282 endif 11283endif 11284 11285 endif 11286 11287 c = np%ignorableWhitespace 11288 11289 end function getisElementContentWhitespace 11290 11291 11292 subroutine setIsElementContentWhitespace(np, isElementContentWhitespace, ex) 11293 type(DOMException), intent(out), optional :: ex 11294 type(Node), pointer :: np 11295 logical :: isElementContentWhitespace 11296 11297 integer :: n 11298 11299 np%ignorableWhitespace = isElementContentWhitespace 11300 11301 if (isElementContentWhitespace) then 11302 n = -np%textContentLength 11303 else 11304 n = size(np%nodeValue) 11305 endif 11306 11307 call updateTextContentLength(np, n) 11308 end subroutine setIsElementContentWhitespace 11309 11310! function getWholeText 11311! function replaceWholeText 11312 11313 11314 11315 11316 pure function getdata_len(np, p) result(n) 11317 type(Node), intent(in) :: np 11318 logical, intent(in) :: p 11319 integer :: n 11320 11321 if (p .and. ( & 11322 np%nodeType==TEXT_NODE .or. & 11323 np%nodeType==COMMENT_NODE .or. & 11324 np%nodeType==CDATA_SECTION_NODE .or. & 11325 np%nodeType==PROCESSING_INSTRUCTION_NODE .or. & 11326 .false.)) then 11327 n = size(np%nodeValue) 11328 else 11329 n = 0 11330 endif 11331 end function getdata_len 11332function getdata(np, ex)result(c) 11333 type(DOMException), intent(out), optional :: ex 11334 type(Node), pointer :: np 11335#ifdef RESTRICTED_ASSOCIATED_BUG 11336 character(len=getdata_len(np, .true.)) :: c 11337#else 11338 character(len=getdata_len(np, associated(np))) :: c 11339#endif 11340 11341 11342 if (.not.associated(np)) then 11343 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11344 call throw_exception(FoX_NODE_IS_NULL, "getdata", ex) 11345 if (present(ex)) then 11346 if (inException(ex)) then 11347 return 11348 endif 11349 endif 11350endif 11351 11352 endif 11353 11354 if (getNodeType(np)/=TEXT_NODE .and. & 11355getNodeType(np)/=COMMENT_NODE .and. & 11356getNodeType(np)/=CDATA_SECTION_NODE .and. & 11357getNodeType(np)/=PROCESSING_INSTRUCTION_NODE .and. & 11358 .true.) then 11359 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11360 call throw_exception(FoX_INVALID_NODE, "getdata", ex) 11361 if (present(ex)) then 11362 if (inException(ex)) then 11363 return 11364 endif 11365 endif 11366endif 11367 11368 endif 11369 11370 c = str_vs(np%nodeValue) 11371 11372 end function getdata 11373 11374 11375 subroutine setData(arg, data, ex) 11376 type(DOMException), intent(out), optional :: ex 11377 type(Node), pointer :: arg 11378 character(len=*) :: data 11379 11380 integer :: n 11381 11382 if (.not.associated(arg)) then 11383 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11384 call throw_exception(FoX_NODE_IS_NULL, "setData", ex) 11385 if (present(ex)) then 11386 if (inException(ex)) then 11387 return 11388 endif 11389 endif 11390endif 11391 11392 endif 11393 11394!NB special case in order to check readonly correctly 11395 if (arg%nodeType==TEXT_NODE .or. & 11396 arg%nodeType==COMMENT_NODE .or. & 11397 arg%nodeType==CDATA_SECTION_NODE .or. & 11398 arg%nodeType==PROCESSING_INSTRUCTION_NODE) then 11399 if (arg%readonly) then 11400 if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then 11401 call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setData", ex) 11402 if (present(ex)) then 11403 if (inException(ex)) then 11404 return 11405 endif 11406 endif 11407endif 11408 11409 endif 11410 else 11411 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11412 call throw_exception(FoX_INVALID_NODE, "setData", ex) 11413 if (present(ex)) then 11414 if (inException(ex)) then 11415 return 11416 endif 11417 endif 11418endif 11419 11420 endif 11421 11422 select case (arg%nodeType) 11423 case (CDATA_SECTION_NODE) 11424 if (index(data,"]]>")>0) then 11425 if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then 11426 call throw_exception(FoX_INVALID_CDATA_SECTION, "setData", ex) 11427 if (present(ex)) then 11428 if (inException(ex)) then 11429 return 11430 endif 11431 endif 11432endif 11433 11434 endif 11435 case (COMMENT_NODE) 11436 if (index(data,"--")>0) then 11437 if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then 11438 call throw_exception(FoX_INVALID_COMMENT, "setData", ex) 11439 if (present(ex)) then 11440 if (inException(ex)) then 11441 return 11442 endif 11443 endif 11444endif 11445 11446 endif 11447 case (PROCESSING_INSTRUCTION_NODE) 11448 if (index(data,"?>")>0) then 11449 if (getFoX_checks().or.FoX_INVALID_PI_DATA<200) then 11450 call throw_exception(FoX_INVALID_PI_DATA, "setData", ex) 11451 if (present(ex)) then 11452 if (inException(ex)) then 11453 return 11454 endif 11455 endif 11456endif 11457 11458 endif 11459 end select 11460 11461 deallocate(arg%nodeValue) 11462 arg%nodeValue => vs_str_alloc(data) 11463 11464 if (arg%nodeType==TEXT_NODE .or. & 11465 arg%nodeType==CDATA_SECTION_NODE) then 11466 n = len(data) - arg%textContentLength 11467 call updateTextContentLength(arg, n) 11468 endif 11469 11470 end subroutine setData 11471 11472 11473 pure function getname_len(np, p) result(n) 11474 type(Node), intent(in) :: np 11475 logical, intent(in) :: p 11476 integer :: n 11477 11478 if (p .and. ( & 11479 np%nodeType==DOCUMENT_TYPE_NODE .or. & 11480 np%nodeType==ATTRIBUTE_NODE .or. & 11481 .false.)) then 11482 n = size(np%nodeName) 11483 else 11484 n = 0 11485 endif 11486 end function getname_len 11487function getname(np, ex)result(c) 11488 type(DOMException), intent(out), optional :: ex 11489 type(Node), pointer :: np 11490#ifdef RESTRICTED_ASSOCIATED_BUG 11491 character(len=getname_len(np, .true.)) :: c 11492#else 11493 character(len=getname_len(np, associated(np))) :: c 11494#endif 11495 11496 11497 if (.not.associated(np)) then 11498 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11499 call throw_exception(FoX_NODE_IS_NULL, "getname", ex) 11500 if (present(ex)) then 11501 if (inException(ex)) then 11502 return 11503 endif 11504 endif 11505endif 11506 11507 endif 11508 11509 if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & 11510getNodeType(np)/=ATTRIBUTE_NODE .and. & 11511 .true.) then 11512 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11513 call throw_exception(FoX_INVALID_NODE, "getname", ex) 11514 if (present(ex)) then 11515 if (inException(ex)) then 11516 return 11517 endif 11518 endif 11519endif 11520 11521 endif 11522 11523 c = str_vs(np%nodeName) 11524 11525 end function getname 11526 11527 11528 11529 pure function getpublicId_len(np, p) result(n) 11530 type(Node), intent(in) :: np 11531 logical, intent(in) :: p 11532 integer :: n 11533 11534 if (p .and. ( & 11535 np%nodeType==DOCUMENT_TYPE_NODE .or. & 11536 np%nodeType==NOTATION_NODE .or. & 11537 np%nodeType==ENTITY_NODE .or. & 11538 .false.)) then 11539 n = size(np%dtdExtras%publicId) 11540 else 11541 n = 0 11542 endif 11543 end function getpublicId_len 11544function getpublicId(np, ex)result(c) 11545 type(DOMException), intent(out), optional :: ex 11546 type(Node), pointer :: np 11547#ifdef RESTRICTED_ASSOCIATED_BUG 11548 character(len=getpublicId_len(np, .true.)) :: c 11549#else 11550 character(len=getpublicId_len(np, associated(np))) :: c 11551#endif 11552 11553 11554 if (.not.associated(np)) then 11555 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11556 call throw_exception(FoX_NODE_IS_NULL, "getpublicId", ex) 11557 if (present(ex)) then 11558 if (inException(ex)) then 11559 return 11560 endif 11561 endif 11562endif 11563 11564 endif 11565 11566 if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & 11567getNodeType(np)/=NOTATION_NODE .and. & 11568getNodeType(np)/=ENTITY_NODE .and. & 11569 .true.) then 11570 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11571 call throw_exception(FoX_INVALID_NODE, "getpublicId", ex) 11572 if (present(ex)) then 11573 if (inException(ex)) then 11574 return 11575 endif 11576 endif 11577endif 11578 11579 endif 11580 11581 c = str_vs(np%dtdExtras%publicId) 11582 11583 end function getpublicId 11584 11585 11586 11587 pure function getsystemId_len(np, p) result(n) 11588 type(Node), intent(in) :: np 11589 logical, intent(in) :: p 11590 integer :: n 11591 11592 if (p .and. ( & 11593 np%nodeType==DOCUMENT_TYPE_NODE .or. & 11594 np%nodeType==NOTATION_NODE .or. & 11595 np%nodeType==ENTITY_NODE .or. & 11596 .false.)) then 11597 n = size(np%dtdExtras%systemId) 11598 else 11599 n = 0 11600 endif 11601 end function getsystemId_len 11602function getsystemId(np, ex)result(c) 11603 type(DOMException), intent(out), optional :: ex 11604 type(Node), pointer :: np 11605#ifdef RESTRICTED_ASSOCIATED_BUG 11606 character(len=getsystemId_len(np, .true.)) :: c 11607#else 11608 character(len=getsystemId_len(np, associated(np))) :: c 11609#endif 11610 11611 11612 if (.not.associated(np)) then 11613 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11614 call throw_exception(FoX_NODE_IS_NULL, "getsystemId", ex) 11615 if (present(ex)) then 11616 if (inException(ex)) then 11617 return 11618 endif 11619 endif 11620endif 11621 11622 endif 11623 11624 if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & 11625getNodeType(np)/=NOTATION_NODE .and. & 11626getNodeType(np)/=ENTITY_NODE .and. & 11627 .true.) then 11628 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11629 call throw_exception(FoX_INVALID_NODE, "getsystemId", ex) 11630 if (present(ex)) then 11631 if (inException(ex)) then 11632 return 11633 endif 11634 endif 11635endif 11636 11637 endif 11638 11639 c = str_vs(np%dtdExtras%systemId) 11640 11641 end function getsystemId 11642 11643 11644 11645 11646 function getnamespaceNodes(np, ex)result(c) 11647 type(DOMException), intent(out), optional :: ex 11648 type(Node), pointer :: np 11649 type(NodeList), pointer :: c 11650 11651 11652 if (.not.associated(np)) then 11653 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11654 call throw_exception(FoX_NODE_IS_NULL, "getnamespaceNodes", ex) 11655 if (present(ex)) then 11656 if (inException(ex)) then 11657 return 11658 endif 11659 endif 11660endif 11661 11662 endif 11663 11664 if (getNodeType(np)/=ELEMENT_NODE .and. & 11665 .true.) then 11666 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11667 call throw_exception(FoX_INVALID_NODE, "getnamespaceNodes", ex) 11668 if (present(ex)) then 11669 if (inException(ex)) then 11670 return 11671 endif 11672 endif 11673endif 11674 11675 endif 11676 11677 c => np%elExtras%namespaceNodes 11678 11679 end function getnamespaceNodes 11680 11681 11682 subroutine appendNSNode(np, prefix, namespaceURI, specified, ex) 11683 type(DOMException), intent(out), optional :: ex 11684 type(Node), pointer :: np 11685 character(len=*), intent(in) :: prefix 11686 character(len=*), intent(in) :: namespaceURI 11687 logical, intent(in) :: specified 11688 11689 type(Node), pointer :: ns 11690 type(NodeList), pointer :: nsnodes 11691 integer :: i 11692 logical :: quickFix 11693 11694 if (.not.associated(np)) then 11695 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11696 call throw_exception(FoX_NODE_IS_NULL, "appendNSNode", ex) 11697 if (present(ex)) then 11698 if (inException(ex)) then 11699 return 11700 endif 11701 endif 11702endif 11703 11704 endif 11705 11706 if (np%nodeType /= ELEMENT_NODE) then 11707 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11708 call throw_exception(FoX_INVALID_NODE, "appendNSNode", ex) 11709 if (present(ex)) then 11710 if (inException(ex)) then 11711 return 11712 endif 11713 endif 11714endif 11715 11716 endif 11717 11718 ! We never put namespace nodes in the hanging nodes 11719 ! list since they can never be separated from their 11720 ! parent element node, so will always be destroyed alongside it. 11721 quickFix = getGCState(getOwnerDocument(np)) 11722 call setGCState(getOwnerDocument(np), .false.) 11723 nsnodes => getNamespaceNodes(np) 11724 ! If we already have this prefix registered in the list, then remove it 11725 do i = 0, getLength(nsNodes)-1 11726 ns => item(nsNodes, i) 11727! Intel 8.1 & 9.1 insist on separate variable here and just below 11728 if (getPrefix(ns)==prefix) then 11729 call setNamespaceURI(ns, namespaceURI) 11730 exit 11731 endif 11732 enddo 11733 if (i==getLength(nsNodes)) then 11734 ns => createNamespaceNode(getOwnerDocument(np), & 11735 prefix, namespaceURI, specified) 11736 call append_nl(nsNodes, ns) 11737 endif 11738 call setGCState(getOwnerDocument(np), quickFix) 11739 11740 end subroutine appendNSNode 11741 11742 subroutine normalizeDocument(doc, ex) 11743 type(DOMException), intent(out), optional :: ex 11744 type(Node), pointer :: doc 11745 11746 type(Node), pointer :: this, treeroot, dummy, new, old, nsp 11747 type(DOMConfiguration), pointer :: dc 11748 logical :: doneAttributes, doneChildren 11749 integer :: i_tree, i_children 11750 11751 type(Node), pointer :: parent, attr 11752 type(NamedNodeMap), pointer :: attrs 11753 type(NodeList), pointer :: nsNodes, nsNodesParent 11754 integer :: i, nsIndex 11755 logical :: merged, ns 11756 11757 if (.not.associated(doc)) then 11758 if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then 11759 call throw_exception(FoX_NODE_IS_NULL, "normalizeDocument", ex) 11760 if (present(ex)) then 11761 if (inException(ex)) then 11762 return 11763 endif 11764 endif 11765endif 11766 11767 endif 11768 11769 if (getNodeType(doc)/=DOCUMENT_NODE) then 11770 if (getFoX_checks().or.FoX_INVALID_NODE<200) then 11771 call throw_exception(FoX_INVALID_NODE, "normalizeDocument", ex) 11772 if (present(ex)) then 11773 if (inException(ex)) then 11774 return 11775 endif 11776 endif 11777endif 11778 11779 endif 11780 dc => getDomConfig(doc) 11781 ns = getParameter(dc, "namespaces") 11782 treeroot => doc 11783 11784 call setGCstate(doc, .false.) 11785 ! switch off the memory management, we are going 11786 ! to destroy all nodes we remove from the tree 11787 ! immediately. 11788 11789 ! exception object is *not* passed through in any 11790 ! of the DOM calls below. This is because all of 11791 ! these should succeed - if they dont then there 11792 ! is a problem so we need to terminate immediately 11793 11794 i_tree = 0 11795 doneChildren = .false. 11796 doneAttributes = .false. 11797 this => treeroot 11798 do 11799 if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then 11800 11801 if (.not.getReadonly(this)) then 11802 select case (getNodeType(this)) 11803 case (ELEMENT_NODE) 11804 if (ns) then 11805 11806 ! Clear all current namespace nodes: 11807 nsnodes => getNamespaceNodes(this) 11808 do i = 1, getLength(nsNodes) 11809 call destroyNode(nsNodes%nodes(i)%this) 11810 enddo 11811 deallocate(nsNodes%nodes) 11812 11813 parent => getParentNode(this) 11814 do while (associated(parent)) 11815 ! Go up (through perhaps multiple entref nodes) 11816 if (getNodeType(parent)==ELEMENT_NODE) exit 11817 parent => getParentNode(parent) 11818 enddo 11819 ! Inherit from parent (or not ...) 11820 if (associated(parent)) then 11821 nsNodesParent => getNamespaceNodes(parent) 11822 allocate(nsNodes%nodes(getLength(nsNodesParent))) 11823 nsNodes%length = getLength(nsNodesParent) 11824 do i = 0, getLength(nsNodes) - 1 11825 ! separate variable for intel 11826 nsp => item(nsNodesParent, i) 11827 nsNodes%nodes(i+1)%this => & 11828 createNamespaceNode(getOwnerDocument(this), & 11829 getPrefix(nsp), getNamespaceURI(nsp), & 11830 specified=.false.) 11831 enddo 11832 else 11833 allocate(nsNodes%nodes(0)) 11834 nsNodes%length = 0 11835 endif 11836 11837 ! Now check for broken NS declarations, and add namespace 11838 ! nodes for all non-broken declarations 11839 attrs => getAttributes(this) 11840 do i = 0, getLength(attrs)-1 11841 attr => item(attrs, i) 11842 if ((getLocalName(attr)=="xmlns" & 11843 .or.getPrefix(attr)=="xmlns") & 11844 .and.getNamespaceURI(attr)/="http://www.w3.org/2000/xmlns/") then 11845 ! This can only I think happen if we bugger about with setPrefix ... 11846 if (getFoX_checks().or.NAMESPACE_ERR<200) then 11847 call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) 11848 if (present(ex)) then 11849 if (inException(ex)) then 11850 return 11851 endif 11852 endif 11853endif 11854 11855 endif 11856 if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then 11857 if (getLocalName(attr)=="xmlns") then 11858 call appendNSNode(this, "", getValue(attr), specified=.true.) 11859 else 11860 call appendNSNode(this, getLocalName(attr), & 11861 getValue(attr), specified=.true.) 11862 endif 11863 endif 11864 enddo 11865 11866 11867 if (getNamespaceURI(this)/="") then 11868 ! Is the nsURI of this node bound to its prefix? 11869 ! This will automatically do any necessary replacements ... 11870 if (getPrefix(this)=="") then 11871 if (.not.isDefaultNamespace(this, getNamespaceURI(this))) then 11872 ! We are dealing with the default prefix 11873 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 11874 "xmlns", getNamespaceURI(this)) 11875 call appendNSNode(this, "", getNamespaceURI(this), specified=.true.) 11876 endif 11877 elseif (lookupNamespaceURI(this, getPrefix(this))/=getNamespaceURI(this)) then 11878 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 11879 "xmlns:"//getPrefix(this), getNamespaceURI(this)) 11880 call appendNSNode(this, getPrefix(this), getNamespaceURI(this), specified=.true.) 11881 endif 11882 else 11883 ! No (or empty) namespace URI ... 11884 if (getLocalName(this)=="") then 11885 ! DOM level 1 node ... report error 11886 if (getFoX_checks().or.NAMESPACE_ERR<200) then 11887 call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) 11888 if (present(ex)) then 11889 if (inException(ex)) then 11890 return 11891 endif 11892 endif 11893endif 11894 11895 else 11896 ! We must declare the elements prefix to have an empty nsURI 11897 if (lookupNamespaceURI(this, getPrefix(this))/="") then 11898 if (getPrefix(this)=="") then 11899 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 11900 "xmlns", "") 11901 else 11902 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 11903 "xmlns:"//getPrefix(this), "") 11904 endif 11905 ! and add a namespace node for the empty nsURI 11906 call appendNSNode(this, getPrefix(this), "", specified=.true.) 11907 endif 11908 endif 11909 endif 11910 11911 do i = 0, getLength(attrs)-1 11912 ! This loops over the number of attrs present initially, so any we 11913 ! add within this loop will not get checked - but they will only 11914 ! be namespace declarations about which we dont care anyway. 11915 attr => item(attrs, i) 11916 if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then 11917 cycle ! We already worried about it above. 11918 elseif (getNamespaceURI(attr)=="http://www.w3.org/XML/1998/namespace") then 11919 cycle ! We dont have to declare these 11920 elseif (getNamespaceURI(attr)/="") then 11921 ! This is a namespaced attribute 11922 if (getPrefix(attr)=="" & 11923 .or. lookupNamespaceURI(this, getPrefix(attr))/=getNamespaceURI(attr)) then 11924 ! It has an inappropriate prefix 11925 if (lookupPrefix(this, getNamespaceURI(attr))/="") then 11926 ! then an appropriate prefix exists, use it. 11927 call setPrefix(attr, lookupPrefix(this, getNamespaceURI(attr))) 11928 ! FIXME should be "most local" prefix. Make sure lookupPrefix does that. 11929 else 11930 ! No suitable prefix exists, declare one. 11931 if (getPrefix(attr)/="") then 11932 ! Then the current prefix is not in use, its just undeclared. 11933 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 11934 "xmlns:"//getPrefix(attr), getNamespaceURI(attr)) 11935 call appendNSNode(this, getPrefix(attr), getNamespaceURI(attr), specified=.true.) 11936 else 11937 ! This node has no prefix, but needs one. Make it up. 11938 nsIndex = 1 11939 do while (lookupNamespaceURI(this, "NS"//nsIndex)/="") 11940 ! FIXME this will exit if the namespace is undeclared *or* if it is declared to be empty. 11941 nsIndex = nsIndex+1 11942 enddo 11943 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 11944 "xmlns:NS"//nsIndex, getNamespaceURI(attr)) 11945 ! and create namespace node 11946 call appendNSNode(this, "NS"//nsIndex, getNamespaceURI(attr), specified=.true.) 11947 call setPrefix(attr, "NS"//nsIndex) 11948 endif 11949 endif 11950 endif 11951 else 11952 ! attribute has no namespace URI 11953 if (getLocalName(this)=="") then 11954 ! DOM level 1 node ... report error 11955 if (getFoX_checks().or.NAMESPACE_ERR<200) then 11956 call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) 11957 if (present(ex)) then 11958 if (inException(ex)) then 11959 return 11960 endif 11961 endif 11962endif 11963 11964 endif 11965 ! otherwise no problem 11966 endif 11967 enddo 11968 11969 endif 11970 11971 case (ATTRIBUTE_NODE) 11972 if (getParameter(dc, "entities")) then 11973 ! we dont care about any attribute children, 11974 ! we arent going to do anything 11975 doneChildren = .true. 11976 endif 11977 11978 case (TEXT_NODE) 11979 ! we may need to reset "this" later on ... 11980 old => getPreviousSibling(this) 11981 if (.not.associated(old)) old => getParentNode(this) 11982 merged = .false. 11983 if (getIsElementContentWhitespace(this) & 11984 .and..not.getParameter(dc, "element-content-whitespace")) then 11985 dummy => removeChild(getParentNode(this), this) 11986 call destroy(dummy) 11987 this => old 11988 merged = .true. 11989 endif 11990 if (.not.merged) then 11991 ! We didnt just remove this node. 11992 ! Do we need to normalize? 11993 dummy => getPreviousSibling(this) 11994 if (associated(dummy)) then 11995 if (getNodeType(dummy)==TEXT_NODE) then 11996 call appendData(dummy, getData(this)) 11997 parent => getParentNode(this) 11998 dummy => removeChild(parent, this) 11999 call destroy(dummy) 12000 this => old 12001 endif 12002 endif 12003 endif 12004 12005 case (CDATA_SECTION_NODE) 12006 if (.not.getParameter(dc, "cdata-sections")) then 12007 ! we may need to reset "this" later on ... 12008 old => getPreviousSibling(this) 12009 if (.not.associated(old)) old => getParentNode(this) 12010 merged = .false. 12011 dummy => getPreviousSibling(this) 12012 if (associated(dummy)) then 12013 if (getNodeType(dummy)==TEXT_NODE) then 12014 ! append the data to the previous node & chuck away this node 12015 call appendData(dummy, getData(this)) 12016 dummy => removeChild(getParentNode(this), this) 12017 call destroy(dummy) 12018 this => old 12019 merged =.true. 12020 endif 12021 endif 12022 if (.not.merged) then 12023 ! we didnt merge it so just convert this to a text node 12024 new => createTextNode(doc, getData(this)) 12025 dummy => replaceChild(getParentNode(this), new, this) 12026 call destroy(dummy) 12027 this => new 12028 endif 12029 elseif (.not.getParameter(dc, "split-cdata-sections")) then 12030 ! Actually, on re-reading DOM 3, this is a ridiculous 12031 ! option. Ignoring for now. 12032 endif 12033 12034 case (ENTITY_REFERENCE_NODE) 12035 if (.not.getParameter(dc, "entities")) then 12036 if (associated(getFirstChild(this))) then 12037 !If this node is not representing an unexpanded entity 12038 ! we will need to reset "this" later on ... 12039 old => getPreviousSibling(this) 12040 if (.not.associated(old)) old => getParentNode(this) 12041 ! take each child, and insert it immediately before the current node 12042 do i_children = 0, getLength(getChildNodes(this))-1 12043 dummy => insertBefore(getParentNode(this), getFirstChild(this), this) 12044 enddo 12045 ! and finally remove the current node 12046 dummy => removeChild(getParentNode(this), this) 12047 call destroy(dummy) 12048 ! and set the "this" pointer back so we go over these again 12049 this => old 12050 endif 12051 endif 12052 12053 case (COMMENT_NODE) 12054 if (.not.getParameter(dc, "comments")) then 12055 old => getPreviousSibling(this) 12056 if (.not.associated(old)) old => getParentNode(this) 12057 dummy => removeChild(getParentNode(this), this) 12058 call destroy(dummy) 12059 this => old 12060 endif 12061 12062 case (DOCUMENT_TYPE_NODE) 12063 if (getParameter(dc, "canonical-form")) then 12064 old => getPreviousSibling(this) 12065 if (.not.associated(old)) old => getParentNode(this) 12066 dummy => removeChild(getParentNode(this), this) 12067 call destroy(this) 12068 this => old 12069 endif 12070 12071 end select 12072 endif 12073 12074 else 12075 if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then 12076 doneAttributes = .true. 12077 else 12078 12079 endif 12080 endif 12081 12082 12083 if (.not.doneChildren) then 12084 if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then 12085 if (getLength(getAttributes(this))>0) then 12086 this => item(getAttributes(this), 0) 12087 else 12088 doneAttributes = .true. 12089 endif 12090 elseif (hasChildNodes(this)) then 12091 this => getFirstChild(this) 12092 doneChildren = .false. 12093 doneAttributes = .false. 12094 else 12095 doneChildren = .true. 12096 doneAttributes = .false. 12097 endif 12098 12099 else ! if doneChildren 12100 12101 if (associated(this, treeroot)) exit 12102 if (getNodeType(this)==ATTRIBUTE_NODE) then 12103 if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then 12104 i_tree= i_tree+ 1 12105 this => item(getAttributes(getOwnerElement(this)), i_tree) 12106 doneChildren = .false. 12107 else 12108 i_tree= 0 12109 this => getOwnerElement(this) 12110 doneAttributes = .true. 12111 doneChildren = .false. 12112 endif 12113 elseif (associated(getNextSibling(this))) then 12114 12115 this => getNextSibling(this) 12116 doneChildren = .false. 12117 doneAttributes = .false. 12118 else 12119 this => getParentNode(this) 12120 endif 12121 endif 12122 12123 enddo 12124 12125 12126 12127 end subroutine normalizeDocument 12128 12129 recursive subroutine namespaceFixup(this, deep, ex) 12130 type(DOMException), intent(out), optional :: ex 12131 type(Node), pointer :: this 12132 logical, intent(in) :: deep 12133 12134 type(Node), pointer :: parent, child, attr, nsp 12135 type(NamedNodeMap), pointer :: attrs 12136 type(NodeList), pointer :: nsNodes, nsNodesParent 12137 integer :: i, nsIndex 12138 12139 if (getNodeType(this) /= ELEMENT_NODE & 12140 .and. getNodeType(this) /= ENTITY_REFERENCE_NODE & 12141 .and. getNodeType(this)/=DOCUMENT_FRAGMENT_NODE) then 12142 return 12143 endif 12144 12145 if (this%nodeType==ELEMENT_NODE) then 12146 12147 ! Clear all current namespace nodes: 12148 nsnodes => getNamespaceNodes(this) 12149 do i = 1, getLength(nsNodes) 12150 call destroyNode(nsNodes%nodes(i)%this) 12151 enddo 12152 deallocate(nsNodes%nodes) 12153 12154 parent => getParentNode(this) 12155 do while (associated(parent)) 12156 ! Go up (through perhaps multiple entref nodes) 12157 if (getNodeType(parent)==ELEMENT_NODE) exit 12158 parent => getParentNode(parent) 12159 enddo 12160 ! Inherit from parent (or not ...) 12161 if (associated(parent)) then 12162 nsNodesParent => getNamespaceNodes(parent) 12163 allocate(nsNodes%nodes(getLength(nsNodesParent))) 12164 nsNodes%length = getLength(nsNodesParent) 12165 do i = 0, getLength(nsNodes) - 1 12166 ! separate variable for intel 12167 nsp => item(nsNodesParent, i) 12168 nsNodes%nodes(i+1)%this => & 12169 createNamespaceNode(getOwnerDocument(this), & 12170 getPrefix(nsp), getNamespaceURI(nsp), & 12171 specified=.false.) 12172 enddo 12173 else 12174 allocate(nsNodes%nodes(0)) 12175 nsNodes%length = 0 12176 endif 12177 12178 ! Now check for broken NS declarations, and add namespace 12179 ! nodes for all non-broken declarations 12180 attrs => getAttributes(this) 12181 do i = 0, getLength(attrs)-1 12182 attr => item(attrs, i) 12183 if ((getLocalName(attr)=="xmlns" & 12184 .or.getPrefix(attr)=="xmlns") & 12185 .and.getNamespaceURI(attr)/="http://www.w3.org/2000/xmlns/") then 12186 ! This can only I think happen if we bugger about with setPrefix ... 12187 if (getFoX_checks().or.NAMESPACE_ERR<200) then 12188 call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) 12189 if (present(ex)) then 12190 if (inException(ex)) then 12191 return 12192 endif 12193 endif 12194endif 12195 12196 endif 12197 if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then 12198 if (getLocalName(attr)=="xmlns") then 12199 call appendNSNode(this, "", getValue(attr), specified=.true.) 12200 else 12201 call appendNSNode(this, getLocalName(attr), & 12202 getValue(attr), specified=.true.) 12203 endif 12204 endif 12205 enddo 12206 12207 12208 if (getNamespaceURI(this)/="") then 12209 ! Is the nsURI of this node bound to its prefix? 12210 ! This will automatically do any necessary replacements ... 12211 if (getPrefix(this)=="") then 12212 if (.not.isDefaultNamespace(this, getNamespaceURI(this))) then 12213 ! We are dealing with the default prefix 12214 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 12215 "xmlns", getNamespaceURI(this)) 12216 call appendNSNode(this, "", getNamespaceURI(this), specified=.true.) 12217 endif 12218 elseif (lookupNamespaceURI(this, getPrefix(this))/=getNamespaceURI(this)) then 12219 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 12220 "xmlns:"//getPrefix(this), getNamespaceURI(this)) 12221 call appendNSNode(this, getPrefix(this), getNamespaceURI(this), specified=.true.) 12222 endif 12223 else 12224 ! No (or empty) namespace URI ... 12225 if (getLocalName(this)=="") then 12226 ! DOM level 1 node ... report error 12227 if (getFoX_checks().or.NAMESPACE_ERR<200) then 12228 call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) 12229 if (present(ex)) then 12230 if (inException(ex)) then 12231 return 12232 endif 12233 endif 12234endif 12235 12236 else 12237 ! We must declare the elements prefix to have an empty nsURI 12238 if (lookupNamespaceURI(this, getPrefix(this))/="") then 12239 if (getPrefix(this)=="") then 12240 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 12241 "xmlns", "") 12242 else 12243 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 12244 "xmlns:"//getPrefix(this), "") 12245 endif 12246 ! and add a namespace node for the empty nsURI 12247 call appendNSNode(this, getPrefix(this), "", specified=.true.) 12248 endif 12249 endif 12250 endif 12251 12252 do i = 0, getLength(attrs)-1 12253 ! This loops over the number of attrs present initially, so any we 12254 ! add within this loop will not get checked - but they will only 12255 ! be namespace declarations about which we dont care anyway. 12256 attr => item(attrs, i) 12257 if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then 12258 cycle ! We already worried about it above. 12259 elseif (getNamespaceURI(attr)=="http://www.w3.org/XML/1998/namespace") then 12260 cycle ! We dont have to declare these 12261 elseif (getNamespaceURI(attr)/="") then 12262 ! This is a namespaced attribute 12263 if (getPrefix(attr)=="" & 12264 .or. lookupNamespaceURI(this, getPrefix(attr))/=getNamespaceURI(attr)) then 12265 ! It has an inappropriate prefix 12266 if (lookupPrefix(this, getNamespaceURI(attr))/="") then 12267 ! then an appropriate prefix exists, use it. 12268 call setPrefix(attr, lookupPrefix(this, getNamespaceURI(attr))) 12269 ! FIXME should be "most local" prefix. Make sure lookupPrefix does that. 12270 else 12271 ! No suitable prefix exists, declare one. 12272 if (getPrefix(attr)/="") then 12273 ! Then the current prefix is not in use, its just undeclared. 12274 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 12275 "xmlns:"//getPrefix(attr), getNamespaceURI(attr)) 12276 call appendNSNode(this, getPrefix(attr), getNamespaceURI(attr), specified=.true.) 12277 else 12278 ! This node has no prefix, but needs one. Make it up. 12279 nsIndex = 1 12280 do while (lookupNamespaceURI(this, "NS"//nsIndex)/="") 12281 ! FIXME this will exit if the namespace is undeclared *or* if it is declared to be empty. 12282 nsIndex = nsIndex+1 12283 enddo 12284 call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & 12285 "xmlns:NS"//nsIndex, getNamespaceURI(attr)) 12286 ! and create namespace node 12287 call appendNSNode(this, "NS"//nsIndex, getNamespaceURI(attr), specified=.true.) 12288 call setPrefix(attr, "NS"//nsIndex) 12289 endif 12290 endif 12291 endif 12292 else 12293 ! attribute has no namespace URI 12294 if (getLocalName(this)=="") then 12295 ! DOM level 1 node ... report error 12296 if (getFoX_checks().or.NAMESPACE_ERR<200) then 12297 call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) 12298 if (present(ex)) then 12299 if (inException(ex)) then 12300 return 12301 endif 12302 endif 12303endif 12304 12305 endif 12306 ! otherwise no problem 12307 endif 12308 enddo 12309 12310 endif 12311 12312 if (deep) then 12313 ! And now call this on all appropriate children ... 12314 child => getFirstChild(this) 12315 do while (associated(child)) 12316 call namespaceFixup(child, .true.) 12317 child => getNextSibling(child) 12318 enddo 12319 endif 12320 12321 end subroutine namespaceFixup 12322 12323 12324end module m_dom_dom 12325