1module m_common_namespaces 2 3#ifndef DUMMYLIB 4 use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc 5 6 use fox_m_utils_uri, only: URI, parseURI, destroyURI, hasScheme 7 use m_common_attrs, only: dictionary_t, get_key, get_value, remove_key, getLength, hasKey 8 use m_common_attrs, only: set_nsURI, set_localName, get_prefix, add_item_to_dict 9 use m_common_charset, only: XML1_0, XML1_1 10 use m_common_error, only: FoX_error, FoX_warning, error_stack, add_error, in_error 11 use m_common_namecheck, only: checkNCName 12 use m_common_struct, only: xml_doc_state 13 14 implicit none 15 private 16 17 character(len=*), parameter :: invalidNS = '::INVALID::' 18 ! an invalid URI name to indicate a namespace error. 19 20 type URIMapping 21 character, dimension(:), pointer :: URI 22 integer :: ix ! link back to node depth 23 end type URIMapping 24 !This is a single URI, and the node depth under which 25 !its namespace applies. 26 27 type prefixMapping 28 character, dimension(:), pointer :: prefix 29 type(URIMapping), dimension(:), pointer :: urilist 30 end type prefixMapping 31 !This is the mapping for a single prefix; with the 32 !list of namespaces which are in force at various 33 !depths 34 35 type namespaceDictionary 36 private 37 type(URIMapping), dimension(:), pointer :: defaults 38 type(prefixMapping), dimension(:), pointer :: prefixes 39 end type namespaceDictionary 40 !This is the full namespace dictionary; defaults is 41 !the list of default namespaces in force; prefix a 42 !list of all prefixes in force. 43 44 public :: invalidNS 45 46 public :: initNamespaceDictionary 47 public :: destroyNamespaceDictionary 48 public :: namespaceDictionary 49 public :: checkNamespaces 50 public :: checkNamespacesWriting 51 public :: checkEndNamespaces 52 public :: getnamespaceURI 53 interface getnamespaceURI 54 module procedure getURIofDefaultNS, getURIofPrefixedNS 55 end interface 56 public :: isPrefixInForce 57 public :: isDefaultNSInForce 58 public :: getNumberOfPrefixes 59 public :: getPrefixByIndex 60 61 public :: dumpnsdict !FIXME 62 63 public :: addDefaultNS 64 public :: removeDefaultNS 65 public :: addPrefixedNS 66 public :: removePrefixedNS 67 68contains 69 70 71 subroutine initNamespaceDictionary(nsDict) 72 type(namespaceDictionary), intent(inout) :: nsDict 73 74 !We need to properly initialize 0th elements 75 !(which are never used) in order to provide 76 !sensible behaviour when trying to manipulate 77 !an empty dictionary. 78 79 allocate(nsDict%defaults(0:0)) 80 allocate(nsDict%defaults(0)%URI(0)) 81 !The 0th element of the defaults NS is the empty namespace 82 nsDict%defaults(0)%ix = -1 83 84 allocate(nsDict%prefixes(0:0)) 85 allocate(nsDict%prefixes(0)%prefix(0)) 86 allocate(nsDict%prefixes(0)%urilist(0:0)) 87 allocate(nsDict%prefixes(0)%urilist(0)%URI(len(invalidNS))) 88 nsDict%prefixes(0)%urilist(0)%URI = vs_str(invalidNS) 89 nsDict%prefixes(0)%urilist(0)%ix = -1 90 91 end subroutine initNamespaceDictionary 92 93 94 subroutine destroyNamespaceDictionary(nsDict) 95 type(namespaceDictionary), intent(inout) :: nsDict 96 97 integer :: i, j 98 99 do i = 0, ubound(nsDict%defaults,1) 100 deallocate(nsDict%defaults(i)%URI) 101 enddo 102 deallocate(nsDict%defaults) 103 do i = 0, ubound(nsDict%prefixes,1) 104 do j = 0, ubound(nsDict%prefixes(i)%urilist,1) 105 deallocate(nsDict%prefixes(i)%urilist(j)%URI) 106 enddo 107 deallocate(nsDict%prefixes(i)%prefix) 108 deallocate(nsDict%prefixes(i)%urilist) 109 enddo 110 deallocate(nsDict%prefixes) 111 end subroutine destroyNamespaceDictionary 112 113 114 subroutine copyURIMapping(urilist1, urilist2, l_m) 115 type(URIMapping), dimension(0:), intent(inout) :: urilist1 116 type(URIMapping), dimension(0:), intent(inout) :: urilist2 117 integer, intent(in):: l_m 118 integer :: i 119 120 if (ubound(urilist1,1) < l_m .or. ubound(urilist2,1) < l_m) then 121 call FoX_error('Internal error in m_sax_namespaces:copyURIMapping') 122 endif 123 ! Now copy all defaults across (or rather - add pointers to them) 124 do i = 0, l_m 125 urilist2(i)%ix = urilist1(i)%ix 126 urilist2(i)%URI => urilist1(i)%URI 127 enddo 128 129 end subroutine copyURIMapping 130 131 132 subroutine addDefaultNS(nsDict, uri, ix, es) 133 type(namespaceDictionary), intent(inout) :: nsDict 134 character(len=*), intent(in) :: uri 135 integer, intent(in) :: ix 136 type(error_stack), intent(inout), optional :: es 137 138 type(URIMapping), dimension(:), allocatable :: tempMap 139 integer :: l_m, l_s 140 141 if (uri=="http://www.w3.org/XML/1998/namespace") then 142 if (present(es)) then 143 call add_error(es, "Attempt to assign incorrect URI to prefix 'xml'") 144 else 145 call FoX_error("Attempt to assign incorrect URI to prefix 'xml'") 146 endif 147 elseif (uri=="http://www.w3.org/2000/xmlns/") then 148 if (present(es)) then 149 call add_error(es, "Attempt to assign prefix to xmlns namespace") 150 else 151 call FoX_error("Attempt to assign prefix to xmlns namespace") 152 endif 153 endif 154 155 ! FIXME check URI is valid ... 156 157 l_m = ubound(nsDict%defaults,1) 158 allocate(tempMap(0:l_m)) 159 ! Now copy all defaults across ... 160 call copyURIMapping(nsDict%defaults, tempMap, l_m) 161 deallocate(nsDict%defaults) 162 l_m = l_m + 1 163 allocate(nsDict%defaults(0:l_m)) 164 !Now copy everything back ... 165 call copyURIMapping(tempMap, nsDict%defaults, l_m-1) 166 deallocate(tempMap) 167 ! And finally, add the new default NS 168 nsDict%defaults(l_m)%ix = ix 169 l_s = len(uri) 170 allocate(nsDict%defaults(l_m)%URI(l_s)) 171 nsDict%defaults(l_m)%URI = vs_str(uri) 172 173 end subroutine addDefaultNS 174 175 176 subroutine addPrefixedURI(nsPrefix, uri, ix) 177 type(PrefixMapping), intent(inout) :: nsPrefix 178 character, dimension(:), intent(in) :: uri 179 integer, intent(in) :: ix 180 181 type(URIMapping), dimension(:), allocatable :: tempMap 182 integer :: l_m, l_s 183 184 l_m = ubound(nsPrefix%urilist,1) 185 allocate(tempMap(0:l_m)) 186 ! Now copy all across ... 187 call copyURIMapping(nsPrefix%urilist, tempMap, l_m) 188 deallocate(nsPrefix%urilist) 189 l_m = l_m + 1 190 allocate(nsPrefix%urilist(0:l_m)) 191 !Now copy everything back ... 192 call copyURIMapping(tempMap, nsPrefix%urilist, l_m-1) 193 deallocate(tempMap) 194 ! And finally, add the new default NS 195 nsPrefix%urilist(l_m)%ix = ix 196 l_s = size(uri) 197 allocate(nsPrefix%urilist(l_m)%URI(l_s)) 198 nsPrefix%urilist(l_m)%URI = uri 199 200 end subroutine addPrefixedURI 201 202 subroutine removeDefaultNS(nsDict) 203 type(namespaceDictionary), intent(inout) :: nsDict 204 205 type(URIMapping), dimension(:), allocatable :: tempMap 206 integer :: l_m 207 208 l_m = ubound(nsDict%defaults,1) 209 allocate(tempMap(0:l_m-1)) 210 ! Now copy all defaults across ... 211 call copyURIMapping(nsDict%defaults, tempMap, l_m-1) 212 !And remove tail-end charlie 213 deallocate(nsDict%defaults(l_m)%URI) 214 deallocate(nsDict%defaults) 215 l_m = l_m - 1 216 allocate(nsDict%defaults(0:l_m)) 217 !Now copy everything back ... 218 call copyURIMapping(tempMap, nsDict%defaults, l_m) 219 deallocate(tempMap) 220 221 end subroutine removeDefaultNS 222 223 subroutine removePrefixedURI(nsPrefix) 224 type(PrefixMapping), intent(inout) :: nsPrefix 225 226 type(URIMapping), dimension(:), allocatable :: tempMap 227 integer :: l_m 228 229 l_m = ubound(nsPrefix%urilist,1) 230 allocate(tempMap(0:l_m-1)) 231 ! Now copy all defaults across ... 232 call copyURIMapping(nsPrefix%urilist, tempMap, l_m-1) 233 !And remove tail-end charlie 234 deallocate(nsPrefix%urilist(l_m)%URI) 235 deallocate(nsPrefix%urilist) 236 l_m = l_m - 1 237 allocate(nsPrefix%urilist(0:l_m)) 238 !Now copy everything back ... 239 call copyURIMapping(tempMap, nsPrefix%urilist, l_m) 240 deallocate(tempMap) 241 242 end subroutine removePrefixedURI 243 244 subroutine addPrefixedNS(nsDict, prefix, URI, ix, xds, xml, es) 245 type(namespaceDictionary), intent(inout) :: nsDict 246 character(len=*), intent(in) :: prefix 247 character(len=*), intent(in) :: uri 248 integer, intent(in) :: ix 249 type(xml_doc_state), intent(in) :: xds 250 logical, intent(in), optional :: xml 251 type(error_stack), intent(inout), optional :: es 252 253 integer :: l_p, p_i, i 254 logical :: xml_ 255 256 if (present(xml)) then 257 xml_ = xml 258 else 259 xml_ = .false. 260 endif 261 262 if (prefix=='xml' .and. & 263 URI/='http://www.w3.org/XML/1998/namespace') then 264 if (present(es)) then 265 call add_error(es, "Attempt to assign incorrect URI to prefix 'xml'") 266 else 267 call FoX_error("Attempt to assign incorrect URI to prefix 'xml'") 268 endif 269 elseif (prefix/='xml' .and. & 270 URI=='http://www.w3.org/XML/1998/namespace') then 271 if (present(es)) then 272 call add_error(es, "Attempt to assign incorrect prefix to XML namespace") 273 else 274 call FoX_error("Attempt to assign incorrect prefix to XML namespace") 275 endif 276 elseif (prefix == 'xmlns') then 277 if (present(es)) then 278 call add_error(es, "Attempt to declare 'xmlns' prefix") 279 else 280 call FoX_error("Attempt to declare 'xmlns' prefix") 281 endif 282 elseif (URI=="http://www.w3.org/2000/xmlns/") then 283 if (present(es)) then 284 call add_error(es, "Attempt to assign prefix to xmlns namespace") 285 else 286 call FoX_error("Attempt to assign prefix to xmlns namespace") 287 endif 288 elseif (len(prefix) > 2) then 289 if ((verify(prefix(1:1), 'xX') == 0) & 290 .and. (verify(prefix(2:2), 'mM') == 0) & 291 .and. (verify(prefix(3:3), 'lL') == 0)) then 292 if (.not.xml_) then 293 ! FIXME need working warning infrastructure 294 !if (present(es)) then 295 ! call add_error(es, "Attempt to declare reserved prefix: "//prefix) 296 !else 297 call FoX_warning("Attempt to declare reserved prefix: "//prefix) 298 !endif 299 endif 300 endif 301 endif 302 303 if (.not.checkNCName(prefix, xds%xml_version)) & 304 call FoX_error("Attempt to declare invalid prefix: "//prefix) 305 306 ! FIXME check URI is valid 307 308 l_p = ubound(nsDict%prefixes, 1) 309 310 p_i = 0 311 do i = 1, l_p 312 if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then 313 p_i = i 314 exit 315 endif 316 enddo 317 318 if (p_i == 0) then 319 call addPrefix(nsDict, vs_str(prefix)) 320 p_i = l_p + 1 321 endif 322 323 call addPrefixedURI(nsDict%prefixes(p_i), vs_str(URI), ix) 324 325 end subroutine addPrefixedNS 326 327 subroutine removePrefixedNS(nsDict, prefix) 328 type(namespaceDictionary), intent(inout) :: nsDict 329 character, dimension(:), intent(in) :: prefix 330 integer :: l_p, p_i, i 331 l_p = ubound(nsDict%prefixes, 1) 332 333 p_i = 0 334 do i = 1, l_p 335 if (str_vs(nsDict%prefixes(i)%prefix) == str_vs(prefix)) then 336 p_i = i 337 exit 338 endif 339 enddo 340 341 if (p_i /= 0) then 342 call removePrefixedURI(nsDict%prefixes(p_i)) 343 if (ubound(nsDict%prefixes(p_i)%urilist,1) == 0) then 344 !that was the last mapping for that prefix 345 call removePrefix(nsDict, p_i) 346 endif 347 else 348 call FoX_error('Internal error in m_sax_namespaces:removePrefixedNS') 349 endif 350 351 end subroutine removePrefixedNS 352 353 subroutine addPrefix(nsDict, prefix) 354 type(namespaceDictionary), intent(inout) :: nsDict 355 character, dimension(:), intent(in) :: prefix 356 integer :: l_p 357 358 type(prefixMapping), dimension(:), pointer :: tempPrefixMap 359 360 integer :: i 361 362 !Add a new prefix to the namespace dictionary. 363 !Unfortunately this involves copying the entire 364 !prefixes dictionary to a temporary structure, then 365 !reallocating the prefixes dictionary to be one 366 !longer, then copying everything back: 367 368 l_p = ubound(nsDict%prefixes, 1) 369 allocate(tempPrefixMap(0:l_p)) 370 371 !for each current prefix, append everything to temporary structure 372 do i = 0, l_p 373 tempPrefixMap(i)%prefix => nsDict%prefixes(i)%prefix 374 tempPrefixMap(i)%urilist => nsDict%prefixes(i)%urilist 375 enddo 376 deallocate(nsDict%prefixes) 377 !extend prefix dictionary by one ... 378 l_p = l_p + 1 379 allocate(nsDict%prefixes(0:l_p)) 380 !and copy back ... 381 do i = 0, l_p-1 382 nsDict%prefixes(i)%prefix => tempPrefixMap(i)%prefix 383 nsDict%prefixes(i)%urilist => tempPrefixMap(i)%urilist 384 enddo 385 deallocate(tempPrefixMap) 386 387 allocate(nsDict%prefixes(l_p)%prefix(size(prefix))) 388 nsDict%prefixes(l_p)%prefix = prefix 389 allocate(nsDict%prefixes(l_p)%urilist(0:0)) 390 allocate(nsDict%prefixes(l_p)%urilist(0)%URI(len(invalidNS))) 391 nsDict%prefixes(l_p)%urilist(0)%URI = vs_str(invalidNS) 392 nsDict%prefixes(l_p)%urilist(0)%ix = -1 393 394 end subroutine addPrefix 395 396 subroutine removePrefix(nsDict, i_p) 397 type(namespaceDictionary), intent(inout) :: nsDict 398 integer, intent(in) :: i_p 399 integer :: l_p 400 401 type(prefixMapping), dimension(:), pointer :: tempPrefixMap 402 403 integer :: i 404 405 !Remove a prefix from the namespace dictionary. 406 !Unfortunately this involves copying the entire 407 !prefixes dictionary to a temporary structure, then 408 !reallocating the prefixes dictionary to be one 409 !shorter, then copying everything back: 410 411 l_p = ubound(nsDict%prefixes, 1) 412 allocate(tempPrefixMap(0:l_p-1)) 413 414 !for each current prefix, append everything to temporary structure 415 do i = 0, i_p-1 416 tempPrefixMap(i)%prefix => nsDict%prefixes(i)%prefix 417 tempPrefixMap(i)%urilist => nsDict%prefixes(i)%urilist 418 enddo 419 deallocate(nsDict%prefixes(i_p)%urilist(0)%URI) 420 deallocate(nsDict%prefixes(i_p)%urilist) 421 deallocate(nsDict%prefixes(i_p)%prefix) 422 !this subroutine will only get called if the urilist is already 423 !empty, so no need to deallocate it. 424 do i = i_p+1, l_p 425 tempPrefixMap(i-1)%prefix => nsDict%prefixes(i)%prefix 426 tempPrefixMap(i-1)%urilist => nsDict%prefixes(i)%urilist 427 enddo 428 deallocate(nsDict%prefixes) 429 !shorten prefix dictionary by one ... 430 l_p = l_p - 1 431 allocate(nsDict%prefixes(0:l_p)) 432 !and copy back ... 433 do i = 0, l_p 434 nsDict%prefixes(i)%prefix => tempPrefixMap(i)%prefix 435 nsDict%prefixes(i)%urilist => tempPrefixMap(i)%urilist 436 enddo 437 deallocate(tempPrefixMap) 438 439 end subroutine removePrefix 440 441 442 subroutine checkNamespaces(atts, nsDict, ix, xds, namespace_prefixes, xmlns_uris, es, & 443 partial, start_prefix_handler, end_prefix_handler) 444 type(dictionary_t), intent(inout) :: atts 445 type(namespaceDictionary), intent(inout) :: nsDict 446 integer, intent(in) :: ix ! depth of nesting of current element. 447 type(xml_doc_state), intent(in) :: xds 448 logical, intent(in) :: namespace_prefixes, xmlns_uris 449 type(error_stack), intent(inout) :: es 450 logical, intent(in) :: partial ! if so, don't try and resolve anything except xml & xmlns 451 optional :: start_prefix_handler, end_prefix_handler 452 453 interface 454 subroutine start_prefix_handler(namespaceURI, prefix) 455 character(len=*), intent(in) :: namespaceURI 456 character(len=*), intent(in) :: prefix 457 end subroutine start_prefix_handler 458 subroutine end_prefix_handler(prefix) 459 character(len=*), intent(in) :: prefix 460 end subroutine end_prefix_handler 461 end interface 462 463 character(len=6) :: xmlns 464 character, dimension(:), pointer :: QName, URIstring 465 integer :: i, n 466 type(URI), pointer :: URIref 467 !Check for namespaces; *and* remove xmlns references from 468 !the attributes dictionary. 469 470 ! we can't do a simple loop across the attributes, 471 ! because we need to remove some as we go along ... 472 i = 1 473 do while (i <= getLength(atts)) 474 xmlns = get_key(atts, i) 475 if (xmlns == 'xmlns ') then 476 !Default namespace is being set 477 URIstring => vs_str_alloc(get_value(atts, i)) 478 if (str_vs(URIstring)=="") then 479 ! Empty nsURI on default namespace has same effect in 1.0 and 1.1 480 if (present(end_prefix_handler)) & 481 call end_prefix_handler("") 482 call addDefaultNS(nsDict, invalidNS, ix) 483 deallocate(URIstring) 484 else 485 URIref => parseURI(str_vs(URIstring)) 486 if (.not.associated(URIref)) then 487 call add_error(es, "Invalid URI: "//str_vs(URIstring)) 488 deallocate(URIstring) 489 return 490 elseif (.not.hasScheme(URIref)) then 491 call add_error(es, "Relative namespace in URI deprecated: "//str_vs(URIstring)) 492 deallocate(URIstring) 493 call destroyURI(URIref) 494 return 495 endif 496 call destroyURI(URIref) 497 if (present(start_prefix_handler)) & 498 call start_prefix_handler(str_vs(URIstring), "") 499 call addDefaultNS(nsDict, str_vs(URIstring), ix) 500 deallocate(URIstring) 501 endif 502 if (namespace_prefixes) then 503 i = i + 1 504 else 505 call remove_key(atts, i) 506 endif 507 elseif (xmlns == 'xmlns:') then 508 !Prefixed namespace is being set 509 QName => vs_str_alloc(get_key(atts, i)) 510 URIstring => vs_str_alloc(get_value(atts, i)) 511 if (str_vs(URIstring)=="") then 512 if (xds%xml_version==XML1_0) then 513 call add_error(es, "Empty nsURI is invalid in XML 1.0") 514 deallocate(URIstring) 515 deallocate(QName) 516 return 517 elseif (xds%xml_version==XML1_1) then 518 call addPrefixedNS(nsDict, str_vs(QName(7:)), invalidNS, ix, xds, es=es) 519 if (in_error(es)) then 520 deallocate(URIstring) 521 deallocate(QName) 522 return 523 elseif (present(end_prefix_handler)) then 524 call end_prefix_handler(str_vs(QName(7:))) 525 endif 526 deallocate(URIstring) 527 deallocate(QName) 528 endif 529 else 530 URIref => parseURI(str_vs(URIstring)) 531 if (.not.associated(URIref)) then 532 call add_error(es, "Invalid URI: "//str_vs(URIstring)) 533 deallocate(URIstring) 534 deallocate(QName) 535 return 536 elseif (.not.hasScheme(URIref)) then 537 call add_error(es, "Relative namespace in URI deprecated: "//str_vs(URIstring)) 538 deallocate(URIstring) 539 deallocate(QName) 540 call destroyURI(URIref) 541 return 542 endif 543 call destroyURI(URIref) 544 call addPrefixedNS(nsDict, str_vs(QName(7:)), str_vs(URIstring), ix, xds, es=es) 545 if (in_error(es)) then 546 deallocate(URIstring) 547 deallocate(QName) 548 return 549 elseif (present(start_prefix_handler)) then 550 call start_prefix_handler(str_vs(URIstring), str_vs(QName(7:))) 551 endif 552 deallocate(URIstring) 553 deallocate(QName) 554 endif 555 if (namespace_prefixes) then 556 i = i + 1 557 else 558 call remove_key(atts, i) 559 endif 560 else 561 ! we only increment if we haven't removed a key 562 i = i + 1 563 endif 564 enddo 565 566 ! having done that, now resolve all attribute namespaces: 567 do i = 1, getLength(atts) 568 QName => vs_str_alloc(get_key(atts,i)) 569 n = index(str_vs(QName), ":") 570 if (n > 0) then 571 if (str_vs(QName(1:n-1))=="xmlns") then 572 ! FIXME but this can be controlled by SAX configuration xmlns-uris 573 if (xmlns_uris) then 574 call set_nsURI(atts, i, "http://www.w3.org/2000/xmlns/") 575 else 576 call set_nsURI(atts, i, "") 577 endif 578 else 579 if (str_vs(QName(1:n-1))=="xml") then 580 call set_nsURI(atts, i, "http://www.w3.org/XML/1998/namespace") 581 elseif (getnamespaceURI(nsDict, str_vs(QName(1:n-1)))==invalidNS) then 582 ! Sometimes we don't want to worry about unbound prefixes, 583 ! eg if we are in the middle of parsing an entity. 584 if (.not.partial) then 585 call add_error(es, "Unbound namespace prefix") 586 deallocate(QName) 587 return 588 else 589 call set_nsURI(atts, i, "") 590 endif 591 else 592 call set_nsURI(atts, i, getnamespaceURI(nsDict, str_vs(QName(1:n-1)))) 593 endif 594 endif 595 else 596 if (xmlns_uris.and.str_vs(QName)=="xmlns") then 597 call set_nsURI(atts, i, "http://www.w3.org/2000/xmlns/") 598 else 599 call set_nsURI(atts, i, "") ! no such thing as a default namespace on attributes 600 endif 601 endif 602 ! Check for duplicates 603 if (hasKey(atts, getnamespaceURI(nsDict, str_vs(QName(1:n-1))), str_vs(QName(n+1:)))) then 604 call add_error(es, "Duplicate attribute names after namespace processing") 605 deallocate(QName) 606 return 607 endif 608 call set_localName(atts, i, QName(n+1:)) 609 deallocate(QName) 610 enddo 611 612 end subroutine checkNamespaces 613 614 615 subroutine checkNamespacesWriting(atts, nsdict, ix) 616 type(dictionary_t), intent(inout) :: atts 617 type(namespaceDictionary), intent(inout) :: nsDict 618 integer, intent(in) :: ix 619 ! Read through a list of attributes, check with currently 620 ! active namespaces & add any necessary declarations 621 622 integer :: i, i_p, l_d, l_ps, n 623 624 n = getLength(atts) ! we need the length before we fiddle with it 625 626 !Does the default NS need added? 627 l_d = ubound(nsDict%defaults,1) 628 if (nsDict%defaults(l_d)%ix == ix) then 629 !It's not been registered yet: 630 call add_item_to_dict(atts, "xmlns", & 631 str_vs(nsDict%defaults(l_d)%URI), type="CDATA") 632 endif 633 634 !next, add any overdue prefixed NS's in the same way: 635 ! there should only ever be one. More would be an error, 636 ! but the check should have been done earlier. 637 do i_p = 0, ubound(nsDict%prefixes, 1) 638 l_ps = ubound(nsDict%prefixes(i_p)%urilist,1) 639 if (nsDict%prefixes(i_p)%urilist(l_ps)%ix == ix) then 640 call add_item_to_dict(atts, & 641 "xmlns:"//str_vs(nsDict%prefixes(i_p)%prefix), & 642 str_vs(nsDict%prefixes(i_p)%urilist(l_ps)%URI), & 643 type="CDATA") 644 endif 645 enddo 646 647 648 !Finally, we may have some we've added for attribute QNames 649 ! have to get those too: 650 do i = 1, getLength(atts) 651 ! get prefix, and identify the relevant NS mapping 652 i_p = getPrefixIndex(nsDict, get_prefix(atts, i)) 653 l_ps = ubound(nsDict%prefixes(i_p)%urilist,1) 654 !If the index is greater than what it should be: 655 if (nsDict%prefixes(i_p)%urilist(l_ps)%ix > ix) then 656 !we only just added this, so we need to declare it 657 call add_item_to_dict(atts, "xmlns:"//get_prefix(atts, i), & 658 str_vs(nsDict%prefixes(i_p)%urilist(l_ps)%URI), & 659 type="CDATA") 660 !Reset the index to the right value: 661 nsDict%prefixes(i_p)%urilist(l_ps)%ix = ix 662 endif 663 enddo 664 665 end subroutine checkNamespacesWriting 666 667 668 subroutine checkEndNamespaces(nsDict, ix, end_prefix_handler) 669 type(namespaceDictionary), intent(inout) :: nsDict 670 integer, intent(in) :: ix 671 672 optional :: end_prefix_handler 673 674 interface 675 subroutine end_prefix_handler(prefix) 676 character(len=*), intent(in) :: prefix 677 end subroutine end_prefix_handler 678 end interface 679 680 integer :: l_d, l_p, l_ps, i 681 character, pointer :: prefix(:) 682 683 !It will only ever be the final elements in the list which 684 ! might have expired. 685 686 l_d = ubound(nsDict%defaults,1) 687 do while (nsDict%defaults(l_d)%ix == ix) 688 if (present(end_prefix_handler)) & 689 call end_prefix_handler("") 690 call removeDefaultNS(nsDict) 691 l_d = ubound(nsDict%defaults,1) 692 enddo 693 694 l_p = ubound(nsDict%prefixes, 1) 695 i = 1 696 do while (i <= l_p) 697 l_ps = ubound(nsDict%prefixes(l_p)%urilist,1) 698 if (nsDict%prefixes(i)%urilist(l_ps)%ix == ix) then 699 if (present(end_prefix_handler)) & 700 call end_prefix_handler(str_vs(nsDict%prefixes(i)%prefix)) 701 ! We have to assign this pointer explicitly, otherwise the next call 702 ! aliases its arguments illegally. 703 prefix => nsDict%prefixes(i)%prefix 704 call removePrefixedNS(nsDict, prefix) 705 if (l_p > ubound(nsDict%prefixes, 1)) then 706 ! we just removed the last reference to that prefix, 707 ! so our list of prefixes has shrunk - update the running total. 708 ! and go to the next prefix, which is at the same index 709 l_p = l_p - 1 710 cycle 711 endif 712 endif 713 i = i + 1 714 enddo 715 716 end subroutine checkEndNamespaces 717 718 719 subroutine dumpnsdict(nsdict) 720 type(namespaceDictionary), intent(in) :: nsdict 721 integer :: i, j 722 write(*,'(a)')'* default namespaces *' 723 724 do i = 1, ubound(nsdict%defaults, 1) 725 write(*,'(i0,a)') nsdict%defaults(i)%ix, str_vs(nsdict%defaults(i)%URI) 726 enddo 727 write(*,'(a)') '* Prefixed namespaces *' 728 do i = 1, ubound(nsdict%prefixes, 1) 729 write(*,'(2a)') '* prefix: ', str_vs(nsdict%prefixes(i)%prefix) 730 do j = 1, ubound(nsdict%prefixes(i)%urilist, 1) 731 write(*,'(i0,a)') nsdict%prefixes(i)%urilist(j)%ix, str_vs(nsdict%prefixes(i)%urilist(j)%URI) 732 enddo 733 enddo 734 735 end subroutine dumpnsdict 736 737 738 pure function getURIofDefaultNS(nsDict) result(uri) 739 type(namespaceDictionary), intent(in) :: nsDict 740 character(len=size(nsDict%defaults(ubound(nsDict%defaults,1))%URI)) :: URI 741 742 integer :: l_d 743 l_d = ubound(nsDict%defaults,1) 744 uri = str_vs(nsDict%defaults(l_d)%URI) 745 end function getURIofDefaultNS 746 747 748 pure function isPrefixInForce(nsDict, prefix) result(force) 749 type(namespaceDictionary), intent(in) :: nsDict 750 character(len=*), intent(in) :: prefix 751 logical :: force 752 integer :: i, l_s 753 754 force = .false. 755 do i = 1, ubound(nsDict%prefixes, 1) 756 if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then 757 l_s = ubound(nsDict%prefixes(i)%urilist, 1) 758 force = (size(nsdict%prefixes(i)%urilist(l_s)%URI) > 0) 759 exit 760 endif 761 enddo 762 763 end function isPrefixInForce 764 765 766 pure function isDefaultNSInForce(nsDict) result(force) 767 type(namespaceDictionary), intent(in) :: nsDict 768 logical :: force 769 integer :: l_s 770 771 force = .false. 772 l_s = ubound(nsDict%defaults, 1) 773 if (l_s > 0) & 774 force = (size(nsdict%defaults(l_s)%URI) > 0) 775 776 end function isDefaultNSInForce 777 778 779 pure function getPrefixIndex(nsDict, prefix) result(p) 780 type(namespaceDictionary), intent(in) :: nsDict 781 character(len=*), intent(in) :: prefix 782 integer :: p 783 784 integer :: i 785 p = 0 786 do i = 1, ubound(nsDict%prefixes, 1) 787 if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then 788 p = i 789 exit 790 endif 791 enddo 792 end function getPrefixIndex 793 794 795 function getNumberOfPrefixes(nsDict) result(n) 796 type(namespaceDictionary), intent(in) :: nsDict 797 integer :: n 798 n = ubound(nsDict%prefixes, 1) 799 end function getNumberOfPrefixes 800 801 802 function getPrefixByIndex(nsDict, i) result(c) 803 type(namespaceDictionary), intent(in) :: nsDict 804 integer, intent(in) :: i 805 character(len=size(nsDict%prefixes(i)%prefix)) :: c 806 807 c = str_vs(nsDict%prefixes(i)%prefix) 808 end function getPrefixByIndex 809 810 811 pure function getURIofPrefixedNS(nsDict, prefix) result(uri) 812 type(namespaceDictionary), intent(in) :: nsDict 813 character(len=*), intent(in) :: prefix 814 character(len=size( & 815 nsDict%prefixes( & 816 getPrefixIndex(nsDict,prefix) & 817 ) & 818 %urilist( & 819 ubound(nsDict%prefixes(getPrefixIndex(nsDict,prefix))%urilist, 1) & 820 ) & 821 %uri)) :: URI 822 integer :: p_i, l_m 823 p_i = getPrefixIndex(nsDict, prefix) 824 l_m = ubound(nsDict%prefixes(p_i)%urilist, 1) 825 uri = str_vs(nsDict%prefixes(p_i)%urilist(l_m)%URI) 826 827 end function getURIofPrefixedNS 828 829#endif 830end module m_common_namespaces 831