source: XMLF90/src/dom/m_dom_node.f90 @ 53

Last change on this file since 53 was 6, checked in by ymipsl, 12 years ago

Import des sources XMLF90

File size: 16.5 KB
Line 
1module m_dom_node
2
3use m_dom_types
4use m_dom_nodelist
5use m_dom_namednodemap
6use m_dom_debug
7use m_dom_error
8
9use m_strings
10
11private
12
13  !-------------------------------------------------------   
14  ! METHODS FOR NODES
15  !-------------------------------------------------------   
16
17  public :: getNodeName
18  public :: getNodevalue       
19  public :: getNodeType
20  public :: hasChildNodes
21  public :: hasAttributes
22  public :: getParentNode
23  public :: getFirstChild
24  public :: getLastChild
25  public :: getNextSibling
26  public :: getPreviousSibling
27  public :: getOwnerDocument
28  public :: getAttributes
29  public :: getChildNodes
30  public :: setNodeValue
31  public :: appendChild
32  public :: removeChild
33  public :: replaceChild
34  public :: cloneNode 
35  public :: isSameNode
36  public :: insertBefore
37
38  private :: name_len, value_len
39
40CONTAINS
41
42  pure function name_len(node)
43    type(fnode), pointer :: node
44    integer :: name_len
45
46    name_len = len_trim(node % nodeName)
47
48  end function name_len
49
50  pure function value_len(node)
51    type(fnode), pointer :: node
52    integer :: value_len
53
54    value_len = len_trim(node % nodeValue)
55
56  end function value_len
57
58  !-----------------------------------------------------------
59  !  METHODS FOR NODES
60  !-----------------------------------------------------------
61  function getNodeName(node)
62
63    type(fnode), pointer :: node
64!    character(len=len_trim(node%nodeName)) :: getNodeName
65    type(string)  :: getNodeName
66    if (.not. associated(node))  &
67               call dom_error("getNodeName",0,"Node not allocated")
68    getNodeName = node % nodeName
69
70  end function getNodeName
71
72  !-----------------------------------------------------------
73
74  function getNodeValue(node)
75
76    type(fnode), pointer :: node
77!    character(len=len_trim(node%nodeValue)) :: getNodeValue
78    type(string)  :: getNodeValue
79
80    if (.not. associated(node))  &
81               call dom_error("getNodeValue",0,"Node not allocated")
82    getNodeValue = node % nodeValue
83
84  end function getNodeValue
85
86  !-----------------------------------------------------------
87
88  function getNodeType(node)
89
90    type(fnode), pointer :: node
91    integer :: getNodeType
92
93    if (.not. associated(node)) call dom_error("getNodeType",0,"Node not allocated")
94    getNodeType = node % nodeType
95
96  end function getNodeTYpe
97
98  !-----------------------------------------------------------
99
100  function hasChildNodes(node)
101
102    type(fnode), pointer :: node
103    logical :: hasChildNodes
104
105    if (.not. associated(node)) call dom_error("hasChildNodes",0,"Node not allocated")
106    hasChildNodes = associated(node % firstChild)
107
108  end function hasChildNodes
109
110  !-----------------------------------------------------------
111
112  function hasAttributes(node)
113
114    type(fnode), pointer    :: node
115    logical                 :: hasAttributes
116
117    hasAttributes = .false.
118    if (.not. associated(node)) call dom_error("hasAttributes",0,"Node not allocated")
119    if (node % nodeType /= ELEMENT_NODE) RETURN
120    if ( getLength(node%attributes) > 0) hasAttributes = .true.
121
122  end function hasAttributes
123
124  !-----------------------------------------------------------
125
126  function getParentNode(node)
127
128    type(fnode), pointer    :: node
129    type(fnode), pointer    :: getParentNode
130
131    if (.not. associated(node)) call dom_error("getParentNode",0,"Node not allocated")
132    getParentNode => node % parentNode
133   
134  end function getParentNode
135 
136  !-----------------------------------------------------------
137
138  function getFirstChild(node)
139
140    type(fnode), pointer    :: node
141    type(fnode), pointer    :: getFirstChild
142
143    if (.not. associated(node)) call dom_error("getFirstChild",0,"Node not allocated")
144    getFirstChild => node % firstChild
145
146  end function getFirstChild
147
148  !-----------------------------------------------------------
149
150  function getLastChild(node)
151
152    type(fnode), pointer :: node
153    type(fnode), pointer    :: getLastChild
154
155    if (.not. associated(node)) call dom_error("getLastChild",0,"Node not allocated")
156    getLastChild => node % lastChild
157
158  end function getLastChild
159
160  !-----------------------------------------------------------
161
162  function getNextSibling(node)
163
164    type(fnode), pointer :: node
165    type(fnode), pointer    :: getNextSibling
166
167    if (.not. associated(node)) call dom_error("getNextSibling",0,"Node not allocated")
168    getNextSibling => node % nextSibling
169
170  end function getNextSibling
171
172  !-----------------------------------------------------------
173
174  function getPreviousSibling(node)
175
176    type(fnode), pointer     :: node
177    type(fnode), pointer    :: getPreviousSibling
178
179    if (.not. associated(node)) call dom_error("getPreviousSibling",0,"Node not allocated")
180    getPreviousSibling => node % previousSibling
181
182  end function getPreviousSibling
183
184  !-----------------------------------------------------------
185
186  function getOwnerDocument(node)
187
188    type(fnode), pointer    :: node
189    type(fnode), pointer    :: getOwnerDocument
190
191    if (.not. associated(node)) call dom_error("getOwnerDocument",0,"Node not allocated")
192    getOwnerDocument => node % ownerDocument
193
194  end function getOwnerDocument
195
196  !-----------------------------------------------------------
197
198  function getChildNodes(node) result(nodelist)
199   
200    type(fnode), pointer        :: node
201    type(fnodeList), pointer    :: nodelist      !!! NB nodeList
202
203    type(fnode), pointer        :: np
204
205    if (.not. associated(node)) call dom_error("getChildNodes",0,"Node not allocated")
206    nodelist => null()
207    np => node%firstChild
208    do
209       if (.not. associated(np)) exit
210       call append(nodelist,np)
211       np => np%nextSibling
212    enddo
213
214  end function getChildNodes
215
216  !-----------------------------------------------------------
217
218  function getAttributes(node)
219
220    type(fnode), pointer         :: node
221    type(fnamedNodeMap), pointer :: getAttributes       !!! NB namedNodeMap
222   
223    if (.not. associated(node))  &
224               call dom_error("getAttributes",0,"Node not allocated")
225    getAttributes => node % attributes
226
227  end function getAttributes
228
229  !-----------------------------------------------------------
230
231  subroutine setNodeValue(node, value)
232
233    type(fnode), pointer :: node
234    character(len=*), intent(in) :: value
235   
236    if (.not. associated(node))  &
237               call dom_error("setNodeValue",0,"Node not allocated")
238
239    select case(node % nodeType)
240
241    case(ATTRIBUTE_NODE)
242       node % nodeValue = trim(value)    !!AG: use just value ??
243
244    case(COMMENT_NODE)
245       node % nodeValue = value
246
247    case(TEXT_NODE)
248       node % nodeValue = value
249
250    case(PROCESSING_INSTRUCTION_NODE)
251       node % nodeValue = value
252
253    case(CDATA_SECTION_NODE)
254       node % nodeValue = value
255
256    end select
257
258  end subroutine setNodeValue
259
260  !-----------------------------------------------------------
261 
262  function appendChild(node, newChild)
263    type(fnode), pointer :: node
264    type(fnode), pointer :: newChild
265    type(fnode), pointer :: appendChild
266   
267    if (.not. associated(node))  & 
268               call dom_error("appendChild",0,"Node not allocated")
269
270    if ((node%nodeType /= ELEMENT_NODE) .and. &
271        (node%nodeType /= DOCUMENT_NODE)) &
272    call dom_error("appendChild",HIERARCHY_REQUEST_ERR, &
273           "this node cannot have children")
274
275    if (.not.(associated(node % firstChild))) then
276       node % firstChild => newChild
277    else
278       newChild % previousSibling   => node % lastChild
279       node % lastChild % nextSibling => newChild 
280    endif
281
282    node % lastChild               => newChild
283    newChild % parentNode          => node
284    newChild % ownerDocument       => node % ownerDocument
285    node%nc  = node%nc + 1
286
287    appendChild => newChild
288
289  end function appendChild
290
291  !-----------------------------------------------------------
292 
293  function removeChild(node, oldChild)
294
295    type(fnode), pointer :: removeChild
296    type(fnode), pointer :: node
297    type(fnode), pointer :: oldChild
298    type(fnode), pointer :: np
299   
300    if (.not. associated(node)) call dom_error("removeChild",0,"Node not allocated")
301    np => node % firstChild
302
303    do while (associated(np))
304       if (associated(np, oldChild)) then   ! Two argument form
305                                              !  of associated()
306          if (associated(np,node%firstChild)) then
307             node%firstChild => np%nextSibling
308             if (associated(np % nextSibling)) then
309                np%nextSibling % previousSibling => null()
310             else
311                node%lastChild => null()    ! there was just 1 node
312             endif
313          else if (associated(np,node%lastChild)) then
314             ! one-node-only case covered above
315             node%lastChild => np%previousSibling
316             np%previousSibling%nextSibling => null()
317          else
318             np % previousSibling % nextSibling => np % nextSibling
319             np % nextSibling % previousSibling => np % previousSibling
320          endif
321          node%nc = node%nc -1
322          np % previousSibling => null()    ! Are these necessary?
323          np % nextSibling => null()
324          np % parentNode => null()
325          removeChild => oldChild
326          RETURN
327       endif
328       np => np % nextSibling
329    enddo
330
331    call dom_error("removeChild",NOT_FOUND_ERR,"oldChild not found")
332
333  end function removeChild
334
335 !-----------------------------------------------------------
336 
337  function replaceChild(node, newChild, oldChild)
338
339    type(fnode), pointer :: replaceChild
340    type(fnode), pointer :: node
341    type(fnode), pointer :: newChild
342    type(fnode), pointer :: oldChild
343
344    type(fnode), pointer :: np
345   
346    if (.not. associated(node)) call dom_error("replaceChild",0,"Node not allocated")
347    if ((node%nodeType /= ELEMENT_NODE) .and. &
348        (node%nodeType /= DOCUMENT_NODE)) &
349    call dom_error("replaceChild",HIERARCHY_REQUEST_ERR, &
350           "this node cannot have children")
351
352    np => node % firstChild
353
354    do while (associated(np))   
355       if (associated(np, oldChild)) then
356          if (associated(np,node%firstChild)) then
357             node%firstChild => newChild
358             if (associated(np % nextSibling)) then
359                oldChild%nextSibling % previousSibling => newChild
360             else
361                node%lastChild => newChild    ! there was just 1 node
362             endif
363          else if (associated(np,node%lastChild)) then
364             ! one-node-only case covered above
365             node%lastChild => newChild
366             oldChild%previousSibling%nextSibling => newChild
367          else
368             oldChild % previousSibling % nextSibling => newChild
369             oldChild % nextSibling % previousSibling => newChild
370          endif
371
372          newChild % parentNode      => oldChild % parentNode
373          newChild % nextSibling     => oldChild % nextSibling
374          newChild % previousSibling => oldChild % previousSibling
375          replaceChild => oldChild
376          RETURN
377       endif
378       np => np % nextSibling
379    enddo
380
381    call dom_error("replaceChild",NOT_FOUND_ERR,"oldChild not found")
382
383  end function replaceChild
384
385  !-----------------------------------------------------------
386
387  function cloneNode(node, deep)             
388    type(fnode), pointer :: cloneNode
389    type(fnode), pointer :: node
390
391    logical, optional :: deep
392    logical           :: do_children
393
394    type(fnode), pointer :: original
395    type(fnode), pointer :: parent_clone
396   
397    if (.not. associated(node)) call dom_error("cloneNode",0,"Node not allocated")
398
399    do_children = .false.
400    if (present(deep)) then
401       do_children = deep
402    endif
403   
404    original => node             ! Keep node
405    cloneNode => null()
406    parent_clone => null()
407    call recursive_clone(original, cloneNode)
408    cloneNode%parentNode => null()     ! as per specs   , superfÃluous
409 
410  Contains
411
412    recursive subroutine recursive_clone(original, cloneNode)
413      type(fnode), pointer :: original        ! node to clone
414      type(fnode), pointer :: cloneNode       ! new node
415
416      type(fnode), pointer :: np, clone
417      type(fnode), pointer :: previous_clone, attr, newattr
418      type(string)         :: name
419      logical :: first_sibling
420      integer :: i
421
422      np => original
423      previous_clone => null()
424      first_sibling = .true.
425      do 
426
427         ! Keep going across siblings
428         ! (2nd and lower levels only)
429
430         if (.not.(associated(np))) EXIT
431
432
433         !----------------------------------------------------!
434         clone => createNode()
435         if (first_sibling) then
436            cloneNode => clone       ! Rest of siblings are chained
437                                     ! automatically, but must not
438                                     ! be aliases of cloneNode !!
439            first_sibling = .false.
440         endif
441         clone % nodeName    = np % nodeName
442         name = np%nodeName
443         if (dom_debug) print *, "Cloning ", char(name)
444         clone % nodeValue   = np % nodeValue
445         clone % nodeType    = np % nodeType
446         clone % ownerDocument => np % ownerDocument
447         clone % parentNode  => parent_clone
448         !
449         ! always deep copy attributes, as per specs
450         ! Note that this will not work for "deep" attributes, with
451         ! hanging entity nodes, etc
452         if (associated(np % attributes)) then
453            do i = 0, getLength(np%attributes) - 1
454               attr => item(np%attributes,i)
455               newattr => createNode()
456               newattr%nodeName = getNodeName(attr)
457               newattr%nodeValue = getNodeValue(attr)
458               newattr%nodeType = ATTRIBUTE_NODE
459               call append(clone%attributes, newattr)
460            enddo
461         endif
462
463         ! Deal with first sibling
464         if (associated(previous_clone)) then
465            if (dom_debug) print *, "linking to previous sibling"
466            previous_clone%nextSibling => clone
467            clone%previousSibling => previous_clone
468         else
469            if (dom_debug) print *, "marking as first child of parent"
470            if (associated(parent_clone))  &
471                           parent_clone%firstChild => clone
472         endif
473
474         ! Deal with last sibling
475         if (.not. associated(np%nextSibling)) then
476            if (dom_debug) print *, "this is the last sibling"
477            if (associated(parent_clone)) then
478               if (dom_debug) print *, "marking as last child of parent"
479               parent_clone%lastChild => clone
480            endif
481         endif
482           
483         if (do_children .and. associated(np%firstChild)) then
484            parent_clone => clone
485            if (dom_debug) print *, ".... going for its children"
486            call recursive_clone(np%firstChild,clone%firstChild)
487            parent_clone => clone%parentNode
488         endif
489
490         if (associated(np,node)) then
491            if (dom_debug) print *, "No more siblings of ", char(name)
492            EXIT  ! no siblings of master node
493         endif
494         np => np % nextSibling
495         previous_clone => clone
496
497      enddo 
498
499    end subroutine recursive_clone
500
501  end function cloneNode
502
503  !-----------------------------------------------------------
504
505  function isSameNode(node1, node2)    ! DOM 3.0
506    type(fnode), pointer :: node1
507    type(fnode), pointer :: node2
508    logical :: isSameNode
509
510    isSameNode = associated(node1, node2)
511
512  end function isSameNode
513
514  !-----------------------------------------------------------
515
516  function insertBefore(node, newChild, refChild)
517    type(fnode), pointer :: insertBefore
518    type(fnode), pointer :: node
519    type(fnode), pointer :: newChild
520    type(fnode), pointer :: refChild
521    type(fnode), pointer :: np
522
523    if (.not. associated(node)) call dom_error("insertBefore",0,"Node not allocated")
524    if ((node%nodeType /= ELEMENT_NODE) .and. &
525        (node%nodeType /= DOCUMENT_NODE)) &
526    call dom_error("insertBefore",HIERARCHY_REQUEST_ERR, &
527           "cannot insert node here")
528
529    if (.not.associated(refChild)) then
530       insertBefore => appendChild(node, newChild)
531       RETURN
532    endif
533
534    np => node % firstChild
535    do while (associated(np))
536       if (associated(np, refChild)) then
537          if (associated(np,node%firstChild)) then
538             node%firstChild => newChild
539          else
540             refChild%previousSibling%nextSibling => newChild
541          endif
542
543          refChild % previousSibling => newChild
544          newChild % nextSibling => refChild
545          newChild % parentNode => node
546          newChild % ownerDocument => refChild % ownerDocument
547          insertBefore => newChild
548          RETURN
549       endif
550       np => np % nextSibling
551    enddo
552
553    call dom_error("insertBefore",NOT_FOUND_ERR,"refChild not found")
554
555  end function insertBefore
556
557!----------------------------------------------------------------------
558
559end module m_dom_node
560
Note: See TracBrowser for help on using the repository browser.