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