1#xmlRoot.HTMLInternalDocument =
2  xmlRoot.XMLInternalDocument =
3function(x, skip = TRUE, addFinalizer = NA, ...)
4{
5  .Call("R_xmlRootNode", x, as.logical(skip), addFinalizer, PACKAGE = "XML")
6}
7
8setAs("XMLNode", "XMLInternalNode",
9       function(from) {
10           con = textConnection("tmp", "w", local = TRUE)
11           sink(con)
12           on.exit({sink(file = NULL); close(con)})
13           print(from)
14
15           doc = xmlParse(tmp, asText = TRUE)
16           node = xmlRoot(doc)
17           removeChildren(node)
18           node
19        }
20      )
21
22
23setAs("XMLInternalDocument", "character", function(from) saveXML(from))
24setAs("XMLInternalDOM", "character", function(from) saveXML(from))
25
26
27setAs("XMLInternalDocument", "XMLInternalNode",
28       function(from) xmlRoot(from))
29
30
31setAs("XMLInternalNode", "XMLInternalDocument",
32        function(from) {
33           doc = .Call("R_getXMLNodeDocument", from, PACKAGE = "XML")
34           addDocFinalizer(doc, TRUE)
35           if(is(doc, "HTMLInternalDocument"))
36              class(doc) = c(class(doc), "XMLInternalDocument", "XMLAbstractDocument")
37	   doc
38      })
39
40
41
42setGeneric("free", function(obj) standardGeneric("free"))
43
44setMethod("free", "XMLInternalDocument",
45           function(obj) {
46              invisible(.Call("R_XMLInternalDocument_free", obj, PACKAGE = "XML"))
47           })
48
49
50addFinalizer =
51function(obj, fun, ...)
52{
53  UseMethod("addFinalizer")
54}
55
56addCFinalizer.XMLInternalDocument =
57function(obj, fun, ...)
58{
59  if(missing(fun) || fun == NULL)
60    fun = getNativeSymbolInfo("RSXML_free_internal_document")$address
61  else if(!is.function(obj)) {
62
63  }
64
65  .Call("R_addXMLInternalDocument_finalizer", obj, fun, PACKAGE = "XML")
66}
67
68
69asRXMLNode =
70function(node, converters = NULL, trim = TRUE, ignoreBlanks = TRUE)
71{
72   .Call("R_createXMLNode", node, converters, as.logical(trim), as.logical(ignoreBlanks), PACKAGE = "XML")[[1]]
73}
74
75"[.XMLInternalDocument" =
76function(x, i, j, ..., namespaces = xmlNamespaceDefinitions(x, simplify = TRUE), addFinalizer = NA)
77{
78  if(is.character(i)) {
79    getNodeSet(x, i, ..., addFinalizer = addFinalizer)
80  } else
81     stop("No method for subsetting an XMLInternalDocument with ", class(i))
82}
83
84"[[.XMLInternalDocument" =
85function(x, i, j, ..., exact = NA, namespaces = xmlNamespaceDefinitions(x, simplify = TRUE),
86           addFinalizer = NA)
87{
88  ans = x[i, addFinalizer = addFinalizer]
89  if(length(ans) > 1)
90    warning(length(ans), " elements in node set. Returning just the first one! (Use [])")
91  ans[[1]]
92}
93
94
95
96
97
98
99xmlName.XMLInternalNode =
100function(node, full = FALSE)
101{
102  ans = .Call("RS_XML_xmlNodeName", node, PACKAGE = "XML")
103  if((is.logical(full) && full) || (!is.logical(full) && length(full))) {
104    tmp = xmlNamespace(node)
105    if(length(tmp) && length(names(tmp)) > 0 && names(tmp) != "")
106       ans = paste(names(tmp), ans, sep = ":")
107    else if(is.character(full) && full != "")
108       ans = paste(full, ans, sep = ":")
109  }
110  ans
111}
112
113if(useS4)
114 setMethod("xmlName", "XMLInternalNode", xmlName.XMLInternalNode)
115
116
117xmlNamespace.XMLInternalNode =
118function(x)
119{
120  .Call("RS_XML_xmlNodeNamespace", x, PACKAGE = "XML")
121}
122
123
124
125xmlAttrs.XMLInternalNode =
126function(node, addNamespacePrefix = FALSE, addNamespaceURLs = TRUE, ...)
127{
128  ans = .Call("RS_XML_xmlNodeAttributes",  node, as.logical(addNamespacePrefix), as.logical(addNamespaceURLs), PACKAGE = "XML")
129  if(length(attr(ans, "namespaces")))
130    ans = new("XMLAttributes", ans) # class(ans) = "XMLAttributes"
131
132  ans
133}
134
135#setOldClass(c("XMLAttributes", "character"))
136setClass("XMLAttributes", contains = "character")
137
138setMethod("show", "XMLAttributes",
139           function(object)
140              print(unclass(object)))
141
142setMethod('[', c('XMLAttributes', "ANY"),
143function(x, i, j, ...)
144{
145  ans = callNextMethod()
146  i = match(i, names(x))
147  structure(ans, namespaces = attr(x, "namespaces")[i], class = class(x))
148})
149
150
151
152xmlChildren.XMLInternalNode =
153function(x, addNames = TRUE, omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA, ...)
154{
155  kids = .Call("RS_XML_xmlNodeChildrenReferences", x, as.logical(addNames), addFinalizer, PACKAGE = "XML")
156
157if(length(omitNodeTypes))
158    kids = kids[! sapply(kids, function(x) any(inherits(x, omitNodeTypes)) )]
159
160  structure(kids, class = c("XMLInternalNodeList", "XMLNodeList"))
161}
162
163
164xmlChildren.XMLInternalDocument =
165function(x, addNames = TRUE, ...)
166{
167# .Call("RS_XML_xmlDocumentChildren", x, as.logical(addNames), PACKAGE = "XML")
168 xmlChildren.XMLInternalNode(x, addNames, ...)
169}
170
171
172if(useS4) {
173setMethod("xmlAttrs", "XMLInternalNode", xmlAttrs.XMLInternalNode)
174setMethod("xmlChildren", "XMLInternalNode", xmlChildren.XMLInternalNode)
175setMethod("xmlChildren", "XMLInternalDocument", xmlChildren.XMLInternalDocument)
176}
177
178
179xmlSize.XMLInternalNode =
180function(obj)
181  .Call("RS_XML_xmlNodeNumChildren", obj, PACKAGE = "XML")
182
183"[[.XMLInternalNode" <-
184#setMethod("[[", "XMLInternalNode",
185function(x, i, j, ..., addFinalizer = NA)
186{
187  if(inherits(i, "formula")) {
188    return(getNodeSet(x, i, if(missing(j)) character() else j, addFinalizer = addFinalizer, ...)[[1]])
189  }
190
191  if(is.na(i))
192     return(NULL)
193     # Get the individual elements rather than all the children and then subset those
194  return(
195       if(is(i, "numeric"))
196          .Call("R_getChildByIndex", x, as.integer(i), as.logical(addFinalizer), PACKAGE = "XML")
197       else
198          .Call("R_getChildByName", x, as.character(i), as.logical(addFinalizer), PACKAGE = "XML")
199       )
200
201  kids = xmlChildren(x, addFinalizer = addFinalizer)
202  if(length(kids) == 0)
203    return(NULL)
204
205  if(is.numeric(i))
206     kids[[i]]
207  else {
208     id = as.character(i)
209     which = match(id, sapply(kids, xmlName))
210     kids[[which]]
211  }
212}
213
214
215
216"[.XMLInternalNode" <-
217function(x, i, j, ..., addFinalizer = NA)
218{
219  kids = xmlChildren(x, addFinalizer = addFinalizer)
220  if(is.logical(i))
221    i = which(i)
222
223  if(is(i, "numeric"))
224     structure(kids[i], class = c("XMLInternalNodeList", "XMLNodeList"))
225  else {
226     id = as.character(i)
227     which = match(sapply(kids, xmlName), id)
228     structure(kids[!is.na(which)], class = c("XMLInternalNodeList", "XMLNodeList"))
229  }
230}
231
232
233xmlValue.XMLInternalNode =
234function(x, ignoreComments = FALSE, recursive = TRUE, encoding = getEncoding(x), trim = FALSE) #CE_NATIVE)
235{
236
237  encoding = if(is.integer(encoding))
238               encoding
239             else
240               getEncodingREnum(encoding)
241
242  if(!recursive) {
243     if(xmlSize(x) == 0)
244       return(character())
245
246    kids = xmlChildren(x, addFinaliizer = FALSE)
247    i = sapply(kids, inherits, "XMLInternalTextNode")
248    if(any(i))
249      return(paste(unlist(lapply(kids[i], xmlValue, ignoreComments, recursive = TRUE, encoding = encoding, trim = trim)), collapse = ""))
250    else
251      return(character())
252   }
253
254  ans = .Call("R_xmlNodeValue", x, NULL, encoding, PACKAGE = "XML") # 2nd argument ignored.
255  if(trim)
256     trim(ans)
257  else
258     ans
259}
260
261setS3Method("xmlValue", "XMLInternalNode")
262
263setGeneric("xmlValue<-", function(x, ..., value) standardGeneric("xmlValue<-"))
264
265setMethod("xmlValue<-", "XMLInternalTextNode",
266           function(x, ..., value) {
267             .Call("R_setXMLInternalTextNode_value", x, as.character(value), PACKAGE = "XML")
268             x
269           })
270
271setMethod("xmlValue<-", "XMLTextNode",
272           function(x, ..., value) {
273              x$value = as.character(value)
274              x
275           })
276
277setMethod("xmlValue<-", "XMLAbstractNode",
278           function(x, ..., value) {
279             if(xmlSize(x) == 0) {
280               x = addChildren(x, as.character(value))
281             } else if(xmlSize(x) == 1 && any(inherits(x[[1]], c("XMLTextNode", "XMLInternalTextNode")))) {
282               #XXX Fix the assignment to children.
283               #   should be xmlValue(x[[1]]) = value
284               tmp = x[[1]]
285               xmlValue(tmp) = as.character(value)
286               if(inherits(x[[1]], "XMLTextNode"))
287                  x$children[[1]] = tmp
288             } else
289                 stop("Cannot set the content of a node that is not an XMLInternalTextNode or a node containing a text node")
290             x
291           })
292
293
294
295names.XMLInternalNode =
296function(x)
297  xmlSApply(x, xmlName, addFinalizer = FALSE)
298
299xmlApply.XMLInternalNode =
300function(X, FUN, ..., omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA)
301{
302   kids = xmlChildren(X, addFinalizer = addFinalizer)
303   if(length(omitNodeTypes))
304     kids = kids[! sapply(kids, function(x) any(inherits(x, omitNodeTypes)) )]
305   lapply(kids, FUN, ...)
306}
307
308xmlSApply.XMLInternalNode =
309function(X, FUN, ..., omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA)
310{
311   kids = xmlChildren(X, addFinalizer = addFinalizer)
312   if(length(omitNodeTypes))
313     kids = kids[! sapply(kids, function(x) any(inherits(x, omitNodeTypes)) )]
314   sapply(kids, FUN, ...)
315}
316
317
318xmlSApply.XMLNodeSet =
319function(X, FUN, ..., omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA)
320{
321  sapply(X, FUN, ...)
322}
323
324xmlApply.XMLNodeSet =
325function(X, FUN, ..., omitNodeTypes = c("XMLXIncludeStartNode", "XMLXIncludeEndNode"), addFinalizer = NA)
326{
327  lapply(X, FUN, ...)
328}
329
330getChildrenStrings =
331function(node, encoding = getEncoding(node), asVector = TRUE, len = xmlSize(node),
332          addNames = TRUE)
333{
334   encoding = getEncodingREnum(encoding)
335   .Call("R_childStringValues", node, as.integer(len), as.logical(asVector), as.integer(encoding),
336               as.logical(addNames), PACKAGE = "XML")
337}
338
339
340setMethod("xmlParent", "XMLInternalNode",
341function(x, addFinalizer = NA, ...)
342{
343  .Call("RS_XML_xmlNodeParent", x, addFinalizer, PACKAGE = "XML")
344})
345
346
347newXMLDTDNode <-
348function(nodeName, externalID = character(), systemID = character(), doc = NULL, addFinalizer = NA)
349{
350  if(length(nodeName) > 1 && missing(externalID))
351    externalID = nodeName[2]
352  if(length(nodeName) > 2 && missing(systemID))
353    systemID = nodeName[3]
354
355  .Call("R_newXMLDtd", doc, as.character(nodeName), as.character(externalID), as.character(systemID),
356          addFinalizer, PACKAGE = "XML")
357}
358
359setInternalNamespace =
360function(node, ns)
361{
362  .Call("R_xmlSetNs", node, ns, FALSE, PACKAGE = "XML") # as.logical(append))
363}
364
365
366addDocFinalizer =
367function(doc, finalizer)
368{
369  fun = NULL
370  if(is.logical(finalizer)) {
371    if(is.na(finalizer) || !finalizer)
372      return()
373    else
374      fun = NULL
375  } else {
376    fun = finalizer
377    if(inherits(fun, "NativeSymbolInfo"))
378      fun = fun$address
379  }
380
381  if(!is.null(fun) && !is.function(fun) && typeof(fun) != "externalptr")
382    stop("need an R function, address of a routine or NULL for finalizer")
383
384  .Call("R_addXMLInternalDocument_finalizer", doc, fun, PACKAGE = "XML")
385}
386
387HTML_DTDs =
388  c("http://www.w3.org/TR/html4/frameset.dtd",
389    "http://www.w3.org/TR/html4/loose.dtd",
390    "http://www.w3.org/TR/html4/strict.dtd",
391    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd",
392    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd",
393    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd",
394    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"
395    )
396
397newHTMLDoc =
398function(dtd = "loose", addFinalizer = TRUE, name = character(),
399          node = newXMLNode("html", newXMLNode("head", addFinalizer = FALSE), newXMLNode("body", addFinalizer = FALSE),
400                             addFinalizer = FALSE))
401{
402  if(is.na(dtd) || dtd == "")
403     dtd = ""
404  else if(tolower(dtd) %in% c("html5", "5"))
405     dtd = "5"
406  else {
407     i = grep(dtd, HTML_DTDs)
408     if(length(i)) {
409        if(length(i) > 1)
410           warning("matched multiple DTDs. Using the first")
411        dtd = HTML_DTDs[i[1]]
412     } else
413        dtd = ""
414   }
415
416
417  doc = newXMLDoc(dtd = dtd, isHTML = TRUE, addFinalizer = addFinalizer, node = node)
418  doc
419}
420
421newXMLDoc <-
422#
423# Creates internal C-level libxml object for representing
424# an XML document/tree of nodes.
425#
426function(dtd = "", namespaces = NULL, addFinalizer = TRUE, name = character(), node = NULL,
427          isHTML = FALSE)
428{
429  if(is(dtd, "XMLInternalNode")) {
430    dtdNode = dtd
431    dtd = character()
432  } else
433    dtdNode = NULL
434
435  ans = .Call("R_newXMLDoc", dtd, namespaces, as.logical(isHTML), PACKAGE = "XML")
436  class(ans) = oldClass(class(ans))
437
438  addDocFinalizer(ans, addFinalizer)
439
440  if(length(name))
441     docName(ans) = as.character(name)
442
443  if(length(dtdNode))
444     addChildren(ans, dtdNode)
445
446  if(length(node)) {
447    if(is.character(node))
448	## was parent = doc
449       newXMLTextNode(node, addFinalizer = FALSE, parent = ans)
450    else
451       addChildren(ans, node)
452  }
453
454  ans
455}
456
457XMLOptions = new.env()
458getOption =
459function(name, default = NULL, converter = NULL)
460{
461  if(!exists(name, XMLOptions, inherits = FALSE))
462    return(base::getOption(name, default))
463
464   ans = get(name, XMLOptions)
465
466   if(is.function(converter))
467     converter(ans)
468    else
469      ans
470}
471
472setOption =
473function(name, value)
474{
475   prev = getOption(name)
476   assign(name, value, XMLOptions)
477   prev
478}
479
480
481newXMLNode <-
482  ###XXX Note that there is another definition of this in dups.R
483  # Which is now elided.
484
485  # Create an internal C-level libxml node
486  #
487  #
488  #  It is  possible to use a namespace prefix that is not defined.
489  #  This is okay as it may be defined in another node which will become
490  #  an ancestor of this newly created one.
491
492  # XXX Have to add something to force the namespace prefix into the node
493  # when there is no corresponding definition for that prefix.
494
495function(name, ..., attrs = NULL,
496         namespace = character(), namespaceDefinitions = character(),
497         doc = NULL, .children = list(...), parent = NULL,
498         at = NA,
499         cdata = FALSE,
500         suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), #  i.e. warn.
501         sibling = NULL, addFinalizer = NA,
502         noNamespace = length(namespace) == 0 && !missing(namespace),
503         fixNamespaces = c(dummy = TRUE, default = TRUE)
504        )
505{
506   # determine whether we know now that there is definitely no namespace.
507
508    # make certain we have a character vector for the attributes.
509 if(length(attrs)) {
510     ids = names(attrs)
511     attrs = structure(as(attrs, "character"), names = ids)
512
513       # Find any attributes that are actually namespace definitions.
514     i = grep("^xmlns", names(attrs))
515     if(length(i)) {
516         warning("Don't specify namespace definitions via 'attrs'; use namespaceDefinitions")
517         namespace = c(namespace, structure(attrs[i], names = gsub("^xmlns:", "", names(attrs)[i])))
518         attrs = attrs[ -i]
519     }
520  } else
521     attrs = character()
522
523     # allow the caller to specify the node name as  ns_prefix:name
524     # but we have to create it as name and the set the namespace.
525  ns = character()  # the namespace prefix
526  name = strsplit(name, ":")[[1]]
527  if(length(name) == 2) {
528     ns = name[1]
529     name = name[2]
530     noNamespace = FALSE
531  }
532
533 if(is.list(parent)) {
534    if(length(parent) < 1 ||
535        !(is(parent[[1]], "XMLInternalElementNode") || is(parent[[1]], "XMLInternalDocument")))
536        stop("incorrect value for parent")
537
538    parent = parent[[1]]
539  }
540
541   # if there is no doc, but we have a parent which is an XMLInternalDocument, use that.
542 if(missing(doc) && !missing(parent) &&
543     inherits(parent, "XMLInternalDocument")) {
544   doc = parent
545   parent = NULL
546 }
547
548    # Get the doc from the parent node/document.
549 if(is.null(doc) && !is.null(parent))  {
550   # doc = as(parent, "XMLInternalDocument")
551   doc = if(inherits(parent, "XMLInternalDocument"))
552            parent
553         else
554            .Call("R_getXMLNodeDocument", parent, PACKAGE = "XML")
555 }
556
557
558     # create the node. Let's leave the namespace definitions and prefix till later.
559
560     # xmlSetProp() routine in R_newXMLNode() handles namespaces on the attribute names, even checking them.
561  node <- .Call("R_newXMLNode", as.character(name), character(), character(), doc, namespaceDefinitions,
562                   addFinalizer, PACKAGE = "XML")
563
564  if(!is.null(sibling))
565     addSibling(sibling, node, after = as.logical(at))
566  else if(!is.null(parent))
567     addChildren(parent, node, at = at)
568
569
570 if(TRUE) { # Create the name space definitions here rather than in C code.
571      nsDefs = lapply(seq(along  = namespaceDefinitions),
572                   function(i)
573                     newNamespace(node, namespaceDefinitions[[i]], names(namespaceDefinitions)[i], set = FALSE)
574                   )
575      if(length(namespaceDefinitions))
576         names(nsDefs) = if(length(names(namespaceDefinitions))) names(namespaceDefinitions) else ""
577  } else
578      nsDefs = xmlNamespaceDefinitions(node)
579
580       # Now that the namespaces are defined, we can define the attributes which _may_ use them.
581  addAttributes(node, .attrs = attrs, suppressNamespaceWarning = suppressNamespaceWarning)
582
583 if(is(namespace, "XMLNamespaceRef")) {
584    setInternalNamespace(node, namespace)
585 } else if(is.na(noNamespace) || !noNamespace)  {
586    ns = getNodeNamespace(ns, nsDefs, node, namespace, noNamespace, namespaceDefinitions, parent, suppressNamespaceWarning)
587    if(is.null(ns))
588       !.Call("R_setNamespaceFromAncestors", node, PACKAGE = "XML")
589#          .Call("R_getAncestorDefaultNSDef", node, TRUE, PACKAGE = "XML")
590 }
591
592
593
594     # Here is where we set the namespace for this node.
595 if(length(ns) && (inherits(ns, c("XMLNamespaceRef", "XMLNamespaceDeclaration")) || (is.character(ns) && ns != "")))
596     setXMLNamespace( node, ns) # should this be append = FALSE ?
597
598
599    # Add any children to this node.
600 if(length(.children))  {
601   if(!is.list(.children))
602      .children = list(.children)
603   addChildren(node, kids = .children, cdata = cdata, addFinalizer = addFinalizer)
604 }
605
606 if(any(fixNamespaces)) { # !is.null(parent)) {
607    xmlFixNamespaces(node, fixNamespaces)
608   # fixDummyNS(node, suppressNamespaceWarning)
609 }
610
611 node
612}
613
614xmlFixNamespaces =
615function(node, fix)
616{
617
618   if(length(fix) == 1)
619      fix = structure(rep(fix, 2), names = c("dummy", "default"))
620
621   if(length(names(fix)) == 0)
622      names(fix)  = c("dummy", "default")
623
624
625   if(fix["dummy"])
626      xmlApply(node, function(x) .Call("R_fixDummyNS", x, TRUE, PACKAGE = "XML"))
627   if(fix["default"])
628      .Call("R_getAncestorDefaultNSDef", node, TRUE, PACKAGE = "XML")
629}
630
631
632FixDummyNS = 2L
633FixDefaultNS = 4L
634
635
636xmlNamespaceRef =
637function(node)
638  .Call("R_getXMLNsRef", node, PACKAGE = "XML")
639
640
641
642if(FALSE) {
643  # Quick check to see if the speed problem in newXMLNode above is in the extra processing
644newXMLNode <-
645function(name, ..., attrs = NULL,
646         namespace = "", namespaceDefinitions = character(),
647         doc = NULL, .children = list(...), parent = NULL,
648         at = NA,
649         cdata = FALSE,
650         suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE) #  i.e. warn.
651        )
652{
653  node = .Call("R_newXMLNode", name, as.character(attrs), character(), doc, character(), TRUE, PACKAGE = "XML")
654  if(!is.null(parent))
655     addChildren(parent, node, at = at)
656  node
657}
658}
659
660
661findNamespaceDefinition =
662  #
663  # Search up the node hierarchy looking for a namespace
664  # matching that prefix.
665  #
666function(node, namespace, error = TRUE)
667{
668  ptr = node
669  while(!is.null(ptr)) {
670     tmp = namespaceDeclarations(ptr, TRUE)
671     i = match(namespace, names(tmp))
672     if(!is.na(i))
673       return(tmp[[i]])
674     ptr = xmlParent(ptr)
675  }
676
677  if(error)
678    stop("no matching namespace definition for prefix ", namespace)
679
680  NULL
681}
682
683setXMLNamespace =
684  #
685  # Set the specified namespace as the namespace for this
686  # node.
687  # namespace can be a prefix in which case we find it in the
688  # definition in this node or its ancestors.
689  # Otherwise, we expect a name = value character vector giving the
690  # prefix and URI and we create a new namespace definition.
691  # Alternatively, if you already have the namespace reference object
692  # from earlier, you can pass that in.
693  # Then we set the namespace on the node.
694function(node,  namespace, append = FALSE)
695{
696  if(is.character(namespace) && is.null(names(namespace)))
697
698     namespace = findNamespaceDefinition(node, namespace)
699
700  else if(is.character(namespace))
701
702     namespace = newNamespace(node, namespace)
703  else if(!is.null(namespace) && !inherits(namespace, c("XMLNamespaceRef", "XMLNamespaceDeclaration")))
704    stop("Must provide a namespace definition, a prefix of existing namespace or a reference to a namespace definition")
705
706  .Call("R_xmlSetNs", node, namespace, FALSE, PACKAGE = "XML")
707}
708
709
710setAs("XMLNamespace", "character",
711       function(from)
712         unclass(from))
713
714setAs("XMLNamespaceDefinition", "character",
715       function(from)
716         structure(from$uri, names = from$id))
717
718
719setGeneric("xmlNamespace<-",
720            function(x, ..., value)
721              standardGeneric("xmlNamespace<-"))
722
723setMethod("xmlNamespace<-", "XMLInternalNode",
724            function(x, ..., value) {
725               setXMLNamespace(x, value)
726               x
727            })
728
729
730setGeneric("xmlNamespaces<-",
731            function(x, append = TRUE, set = FALSE, value)
732              standardGeneric("xmlNamespaces<-"))
733
734
735setMethod("xmlNamespaces<-", "XMLNode",
736            function(x, append = TRUE, set = FALSE, value) {
737
738                if(inherits(value, "XMLNamespace"))
739                  value = as(value, "character")
740                else if(is.null(names(value)))
741                   names(value) = ""
742
743                    # check for duplicates?
744                i = duplicated(names(value))
745                if(any(i)) {
746                    warning("discarding duplicated namespace prefixes ", paste(names(value)[i], collapse = ", "))
747                    value = value[!i]
748                }
749
750                 if(append) {
751                     cur = as(x$namespaceDefinitions, "character")
752                     cur[names(value)] = value
753                     value = cur
754                 }
755
756                x$namespaceDefinitions = as(value, "XMLNamespaceDefinitions")
757
758                if(set)
759                  x$namespace = names(value)
760
761               x
762            })
763
764
765
766
767setMethod("xmlNamespaces<-", "XMLInternalNode",
768            function(x, append = TRUE, set = FALSE, value) {
769
770                value = as(value, "character")
771
772                if(is.null(names(value)))
773                   names(value) = ""
774
775                    # check for duplicates?
776                i = duplicated(names(value))
777                if(any(i)) {
778                    warning("discarding duplicated namespace prefixes ", paste(names(value)[i], collapse = ", "))
779                    value = value[!i]
780                }
781
782                if(append) {
783                      # Work with existing ones
784                   curDefs = namespaceDeclarations(x)
785                   i = names(value) %in% names(curDefs)
786                   if(any(i)) {
787                       warning("discarding duplicated namespace prefixes ", paste(names(value)[i], collapse = ", "))
788                       value = value[!i]
789                   }
790                }
791
792                if(length(value) == 0)
793                    # Should worry about the set.
794                  return()
795
796                if(length(set) == 1 && set == TRUE && length(value) > 1)
797                   set = c(set, rep(FALSE, length(value) - 1))
798                else
799                   set = rep(set, length.out = length(value))
800
801
802                for(i in seq(along = value))
803                  newXMLNamespace(x, value[i], set = set[i])
804
805                x
806            })
807
808
809
810newXMLNamespace = newNamespace =
811  # Create a new namespace reference object.
812function(node, namespace, prefix = names(namespace), set = FALSE)
813{
814   if(is.null(namespace))
815      return(NULL) # XXX
816
817   ns <- .Call("R_xmlNewNs", node, namespace, as.character(prefix), PACKAGE = "XML")
818   if(set)
819      setXMLNamespace(node, ns)
820   ns
821}
822
823checkNodeNamespace =
824  #
825  # can only be checked after we know the parent node,
826  # i.e. after it has been inserted.
827  #
828function(node, prefix = xmlNamespace(node))
829{
830  if(length(prefix) == 0 || prefix == "")
831    return(TRUE)
832
833       # XXX should check that namespace is defined
834       # walk the parents.
835
836  okay = FALSE
837  p = xmlParent(node)
838  while(!is.null(p)) {
839    okay = prefix %in% names(xmlNamespaceDefinitions(p))
840    if(okay)
841      break
842  }
843
844  if(!okay)
845    stop("using an XML namespace prefix '", prefix, "' for a node that is not defined for this node or its node's ancestors")
846
847  TRUE
848}
849
850# Still to do:
851#   element, entity, entity_ref, notation
852# And more in libxml/tree.h, e.g. the declaration nodes
853#
854
855newXMLTextNode =
856  #
857  #  cdata allows the caller to specify that the text be
858  #  wrapped in a newXMLCDataNode
859function(text,  parent = NULL, doc = NULL, cdata = FALSE, escapeEntities = is(text, "AsIs"),
860          addFinalizer = NA)
861{
862  if(cdata)
863    return(newXMLCDataNode(text, parent, doc, addFinalizer = addFinalizer))
864
865  a = .Call("R_newXMLTextNode", as.character(text), doc, addFinalizer, PACKAGE = "XML")
866  if(escapeEntities)
867    setNoEnc(a)
868
869  if(!is.null(parent))
870     addChildren(parent, a)
871
872  a
873}
874
875newXMLPINode <-
876function(name,  text,  parent = NULL, doc = NULL, at = NA, addFinalizer = NA)
877{
878  a = .Call("R_newXMLPINode", doc, as.character(name), as.character(text), addFinalizer, PACKAGE = "XML")
879  if(!is.null(parent))
880    addChildren(parent, a, at = at)
881  a
882}
883
884newXMLCDataNode <-
885function(text, parent = NULL, doc = NULL, at = NA, sep = "\n", addFinalizer = NA)
886{
887  text = paste(as.character(text), collapse = "\n")
888  a = .Call("R_newXMLCDataNode", doc,  text, addFinalizer, PACKAGE = "XML")
889  if(!is.null(parent))
890    addChildren(parent, a, at = at)
891  a
892}
893
894newXMLCommentNode <-
895function(text, parent = NULL, doc = NULL, at = NA, addFinalizer = NA)
896{
897  a = .Call("R_xmlNewComment",  as.character(text), doc, addFinalizer, PACKAGE = "XML")
898  if(!is.null(parent))
899    addChildren(parent, a, at = at)
900  a
901}
902
903replaceNodes =
904function(oldNode, newNode, ...)
905{
906  UseMethod("replaceNodes")
907}
908
909replaceNodes.list =
910function(oldNode, newNode, addFinalizer = NA, ...)
911{
912 mapply(replaceNodes, oldNode, newNode, MoreArgs = list(addFinalizer = addFinalizer, ...))
913}
914
915replaceNodes.XMLInternalNode =
916function(oldNode, newNode, addFinalizer = NA, ...)
917{
918  oldNode = as(oldNode, "XMLInternalNode")
919  #XXX deal with a list of nodes.
920  newNode = as(newNode, "XMLInternalNode")
921
922  .Call("RS_XML_replaceXMLNode", oldNode, newNode, addFinalizer, PACKAGE = "XML")
923}
924
925#
926if(FALSE) # This is vectorized for no reason
927"[[<-.XMLInternalNode" =
928function(x, i, j, ..., value)
929{
930   if(!is.list(value))
931     value = list(value)
932
933  if(is.character(i)) {
934     if(length(names(x)) == 0)
935         k = rep(NA, length(i))
936     else
937         k = match(i, names(x))
938
939     if(any(is.na(k))) {
940           # create a node with that name and text
941         value[is.na(k)] = mapply(function(name, val)
942                                    if(is.character(val))
943                                         newXMLNode(name, val)
944                                    else
945                                         val)
946     }
947     i = k
948   }
949
950   replace =  (i <= xmlSize(x))
951
952   if(any(replace)) {
953     replaceNodes(xmlChildren(x)[i[replace]], value[replace])
954     value = value[!replace]
955     i = i[!replace]
956   }
957
958   if(length(i))
959      addChildren(x, kids = value, at = i)
960
961   x
962}
963
964
965
966
967"[[<-.XMLInternalNode" =
968function(x, i, j, ..., value)
969{
970  if(is.character(i)) {
971     if(length(names(x)) == 0)
972         k = NA
973     else
974         k = match(i, names(x))
975
976     if(is.na(k) && is.character(value) && !inherits(value, "AsIs")) {
977           # create a node with that name and text
978        value = newXMLNode(i, value)
979     }
980     i = k
981   }
982
983   replace = !is.na(i) & (i <= xmlSize(x))
984
985   if(replace)
986     replaceNodes(xmlChildren(x)[[i]], value)
987   else
988     addChildren(x, kids = list(value), at = i)
989
990   x
991}
992
993
994
995
996setNoEnc =
997function(node)
998{
999  if(!is(node, "XMLInternalTextNode"))
1000    stop("setNoEnc can only be applied to an native/internal text node, not ", paste(class(node), collapse = ", "))
1001
1002  .Call("R_setXMLInternalTextNode_noenc", node, PACKAGE = "XML")
1003}
1004
1005
1006
1007addChildren.XMLInternalNode =
1008addChildren.XMLInternalDocument =
1009  #
1010  # XXX need to expand/recycle the at if it is given as a scalar
1011  # taking into account if the subsequent elements are lists, etc.
1012  #
1013  # Basically, if the caller specifies at as a scalar
1014  # we expand this to be the sequence starting at that value
1015  # and having length which is the total number of nodes
1016  # in kids.  This is not just the length of kids but
1017  # the number of nodes since some of the elements might be lists.
1018  #
1019function(node, ..., kids = list(...), at = NA, cdata = FALSE, addFinalizer = NA,
1020          fixNamespaces = c(dummy = TRUE, default = TRUE))
1021{
1022  kids = unlist(kids, recursive = FALSE)
1023
1024  removeNodes(kids[!vapply(kids, is.character, logical(1L))])
1025
1026  if(length(kids) == 1 && inherits(kids[[1]], "XMLInternalNode") && is.na(at)) {
1027     .Call("R_insertXMLNode", kids[[1]], node, -1L, FALSE, PACKAGE = "XML")
1028#     return(node)
1029  } else {
1030
1031# if(all(is.na(at))) {
1032#    kids = lapply(kids, as, function(x) if(is.character(x)) newXMLTextNode(x) else as(x, "XMLInternalNode"))
1033#    .Call("R_insertXMLNodeDirectly", node, kids, PACKAGE = "XML")
1034#    return(node)
1035# }
1036
1037
1038  if(!is.na(at)) {
1039
1040       # if at is the name of a child node, find its index (first node with that name)
1041    if(is.character(at))
1042      at = match(at, names(node))
1043
1044
1045    if(length(at) == 1)
1046       at = seq(as.integer(at), length = sum(sapply(kids, function(x) if(is.list(x)) length(x) else 1)))
1047    else  # pad with NAs
1048       length(at) = length(kids)
1049
1050    return(lapply(seq(along = kids),
1051            function(j) {
1052               i = kids[[j]]
1053
1054               if(is.character(i))
1055                 i = newXMLTextNode(i, cdata = cdata, addFinalizer = addFinalizer)
1056
1057               if(!inherits(i, "XMLInternalNode")) #XX is(i, "XMLInternalNode")
1058                 i = as(i, "XMLInternalNode")
1059
1060               if(.Call("R_isNodeChildOfAt", i, node, as.integer(at[j]), PACKAGE = "XML"))
1061                 return(i)
1062
1063               if(is.na(at[j]))
1064                  .Call("R_insertXMLNode", i, node, -1L, FALSE, PACKAGE = "XML")
1065               else {
1066                  after = at[j] > 0
1067                  if(!after)
1068                     at[j] = 1
1069
1070                  if(xmlSize(node) < at[j])
1071                    .Call("R_insertXMLNode", i, node, as.integer(NA), FALSE, PACKAGE = "XML")
1072                  else
1073                    .Call("RS_XML_xmlAddSiblingAt", node[[ at[j] ]], i, after, addFinalizer, PACKAGE = "XML") # if at = 0, then shove it in before the sibling.
1074               }
1075            }))
1076  }
1077
1078  for(j in seq(along = kids)) {
1079      i = kids[[j]]
1080
1081      if(is.list(i)) {  # can't happen now since we unlist()
1082         for(k in i)
1083            addChildren(node, k, addFinalizer = addFinalizer)
1084      } else {
1085
1086        if(is.null(i))
1087           next
1088
1089        if(is.character(i))
1090           i = newXMLTextNode(i, cdata = cdata, addFinalizer = FALSE)
1091
1092
1093        if(!inherits(i, "XMLInternalNode")) {
1094           i = as(i, "XMLInternalNode")
1095         }
1096
1097        .Call("R_insertXMLNode", i, node, at[j], FALSE, PACKAGE = "XML")
1098
1099        ns = attr(i, "xml:namespace")
1100        if(!is.null(ns)) {
1101           nsdef = findNamespaceDefinition(node, ns)
1102           if(!is.null(nsdef) && (inherits(nsdef, c("XMLNamespaceRef", "XMLNamespaceDeclaration")) || (is.character(nsdef) && nsdef != ""))) {
1103             setXMLNamespace( i, nsdef)
1104             attr(i, "xml:namespace") = NULL
1105           }
1106        }
1107     }
1108    }
1109  }
1110
1111
1112  if(!is(node, "XMLInternalDocument") && any(fixNamespaces))
1113    xmlFixNamespaces(node, fixNamespaces)
1114
1115  node
1116}
1117
1118
1119
1120addSibling =
1121function(node, ..., kids = list(...), after = NA)
1122{
1123  UseMethod("addSibling")
1124}
1125
1126addSibling.XMLInternalNode =
1127function(node, ..., kids = list(...), after = TRUE, addFinalizer = NA)
1128{
1129   #XXX Why add as children?
1130   if(FALSE && is.na(after))
1131     addChildren(node, kids = kids, at = NA)
1132   else {
1133     lapply(kids,
1134            function(x) {
1135              .Call("RS_XML_xmlAddSiblingAt", node, x, as.logical(after), addFinalizer, PACKAGE = "XML")
1136            })
1137   }
1138
1139}
1140
1141
1142
1143removeNodes =
1144function(node, free = rep(FALSE, length(node)))
1145  UseMethod("removeNodes")
1146
1147removeNodes.default =
1148function(node, free = rep(FALSE, length(node)))
1149 NULL
1150
1151removeNodes.list = removeNodes.XMLNodeList =
1152function(node, free = rep(FALSE, length(node)))
1153{
1154   if(!all(sapply(node, inherits, "XMLInternalNode"))) {
1155      warning("removeNode only works on internal nodes at present")
1156      return(NULL)
1157   }
1158
1159    free = as.logical(free)
1160    free = rep(free, length = length(node))
1161    .Call("R_removeInternalNode", node, free, PACKAGE = "XML")
1162}
1163
1164removeNodes.XMLNodeSet =
1165function(node, free = rep(FALSE, length(node)))
1166{
1167   removeNodes.list(node, free)
1168}
1169
1170
1171removeNodes.XMLInternalNode =
1172function(node, free = rep(FALSE, length(node)))
1173{
1174    node = list(node)
1175    free = as.logical(free)
1176    .Call("R_removeInternalNode", node, free, PACKAGE = "XML")
1177}
1178
1179
1180
1181
1182removeChildren =
1183function(node, ..., kids = list(...), free = FALSE)
1184{
1185  UseMethod("removeChildren")
1186}
1187
1188removeChildren.XMLNode =
1189  #
1190  #
1191function(node, ..., kids = list(...), free = FALSE)
1192{
1193
1194  kidNames = names(node)
1195  w = sapply(kids,
1196              function(i)  {
1197                orig = i
1198                if(length(i) > 1)
1199                  warning("each node identifier should be a single value, i.e. a number or a name, not a vector. Ignoring ",
1200                           paste(i[-1], collapse = ", "))
1201
1202                if(!inherits(i, "numeric"))
1203                    i = match(i, kidNames)
1204
1205                if(is.na(i)) {
1206                  warning("can't find node identified by ", orig)
1207                  i = 0
1208                }
1209                i
1210              })
1211
1212  node$children = unclass(node)$children[ - w ]
1213  node
1214}
1215
1216removeChildren.XMLInternalNode =
1217function(node, ..., kids = list(...), free = FALSE)
1218{
1219   # idea is to get the actual XMLInternalNode objects
1220   # corresponding the identifiers in the kids list.
1221   # These are numbers, node names or node objects themselves
1222   # This could be fooled by duplicates, e.g. kids = list(2, 2)
1223   # or kids = list(2, "d") where "d" identifies the second node.
1224   # We can put in stricter checks in the C code if needed.
1225  nodes =  xmlChildren(node)
1226  nodeNames = xmlSApply(node, xmlName)
1227  v = lapply(kids,
1228             function(x)  {
1229                 if(inherits(x, "XMLInternalNode"))
1230                   x
1231                 else if(is.character(x)) {
1232                   i = match(x, nodeNames)
1233                   nodes[[i]]
1234                 } else
1235                   nodes[[as.integer(x)]]
1236               })
1237
1238   free = rep(free, length = length(v))
1239   .Call("RS_XML_removeChildren", node, v, as.logical(free), PACKAGE = "XML")
1240   node
1241}
1242
1243replaceNodeWithChildren =
1244function(node)
1245{
1246  if(!inherits(node, "XMLInternalNode"))
1247      stop("replaceNodeWithChildren only work on internal XML/HTML nodes")
1248
1249  .Call("R_replaceNodeWithChildren", node, PACKAGE = "XML")
1250}
1251
1252
1253
1254setGeneric("toHTML",
1255            function(x, context = NULL) standardGeneric("toHTML"))
1256
1257
1258setMethod('toHTML', 'vector',
1259            function(x, context = NULL) {
1260              tb = newXMLNode("table")
1261              if(length(names(x)) > 0)
1262                addChildren(tb, newXMLNode("tr", .children = sapply(names(x), function(x) newXMLNode("th", x))))
1263
1264
1265              addChildren(tb, newXMLNode("tr", .children = sapply(x, function(x) newXMLNode("th", format(x)))))
1266              tb
1267            })
1268
1269setMethod('toHTML', 'matrix',
1270            function(x, context = NULL) {
1271              tb = newXMLNode("table")
1272              if(length(colnames(x)) > 0)
1273                addChildren(tb, newXMLNode("tr", .children = sapply(names(x), function(x) newXMLNode("th", x))))
1274
1275              rows = sapply(seq(length = nrow(x)),
1276                             function(i) {
1277                               row = newXMLNode("tr")
1278                               if(length(rownames(x)) > 0)
1279                                 addChildren(row, newXMLNode("th", rownames(x)[i]))
1280                               addChildren(row,  .children = sapply(x[i,], function(x) newXMLNode("th", format(x))))
1281                               row
1282                             })
1283              addChildren(tb, rows)
1284
1285              tb
1286              })
1287
1288
1289
1290SpecialCallOperators =
1291  c("+", "-", "*", "/", "%*%", "%in%", ":")
1292
1293#XXX Not necessarily working yet! See RXMLDoc
1294setMethod('toHTML', 'call',
1295            function(x, context) {
1296                # handle special operators like +, -, :, ...
1297              if(as.character(v[[1]]) %in% SpecialCallOperators) {
1298
1299              }
1300
1301              v = newXMLNode(x[[1]], "(")
1302              for(i in v[-1])
1303                 addChildren(v, toHTML( i , context))
1304
1305              v
1306            })
1307
1308setAs("vector", "XMLInternalNode",
1309      function(from) {
1310          newXMLTextNode(as(from, "character"))
1311      })
1312
1313
1314
1315print.XMLInternalDocument =
1316function(x, ...)
1317{
1318  cat(as(x, "character"), "\n")
1319}
1320
1321print.XMLInternalNode =
1322function(x, ...)
1323{
1324  cat(as(x, "character"), "\n")
1325}
1326
1327
1328setAs("XMLInternalNode", "character",
1329          function(from) saveXML.XMLInternalNode(from))
1330
1331setAs("XMLInternalTextNode", "character",
1332          function(from) xmlValue(from))
1333
1334
1335checkAttrNamespaces =
1336function(nsDefs, .attrs, suppressNamespaceWarning)
1337{
1338      ns = sapply(strsplit(names(.attrs), ":"),
1339                   function(x)  if(length(x) > 1) x[1] else NA)
1340      i = which(!is.na(ns))
1341      m = match(ns[i], names(nsDefs))
1342      if(any(is.na(m))) {
1343         f = if(is.character(suppressNamespaceWarning))
1344                get(suppressNamespaceWarning, mode = "function")
1345             else
1346                warning
1347
1348         f(paste("missing namespace definitions for prefix(es)", paste(ns[i][is.na(m)])))
1349      }
1350}
1351
1352setGeneric("addAttributes",
1353           function(node, ..., .attrs = NULL, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), append = TRUE)
1354             standardGeneric("addAttributes"))
1355
1356setMethod("addAttributes", "XMLInternalElementNode",
1357function(node, ..., .attrs = NULL, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), append = TRUE)
1358{
1359   if(missing(.attrs))
1360     .attrs = list(...)
1361
1362   .attrs = structure(as.character(.attrs), names = names(.attrs))
1363
1364   if(length(.attrs) == 0)
1365      return(node)
1366
1367   if(is.null(names(.attrs)) || any(names(.attrs) == ""))
1368     stop("all node attributes must have a name")
1369
1370
1371   if(is.character(suppressNamespaceWarning) || !suppressNamespaceWarning)
1372      checkAttrNamespaces(getEffectiveNamespaces(node), .attrs, suppressNamespaceWarning)
1373
1374   if(!append)
1375     removeAttributes(node, .all = TRUE)
1376
1377   .Call("RS_XML_addNodeAttributes", node, .attrs, PACKAGE = "XML")
1378   node
1379})
1380
1381#if(!isGeneric("xmlAttrs<-"))
1382 setGeneric("xmlAttrs<-", function(node, append = TRUE, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), value)
1383                          standardGeneric("xmlAttrs<-"))
1384
1385tmp =
1386function(node, append = TRUE, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), value)
1387{
1388   addAttributes(node, .attrs = value, suppressNamespaceWarning = suppressNamespaceWarning, append = append)
1389}
1390
1391setMethod("xmlAttrs<-", "XMLInternalElementNode", tmp)
1392setMethod("xmlAttrs<-", "XMLNode", tmp)
1393
1394
1395setMethod("addAttributes", "XMLNode",
1396           function(node, ..., .attrs = NULL, suppressNamespaceWarning = getOption('suppressXMLNamespaceWarning', FALSE), append = TRUE) {
1397             if(missing(.attrs))
1398               .attrs = list(...)
1399
1400             .attrs = structure(as.character(.attrs), names = names(.attrs))
1401
1402             if(is.null(names(.attrs)) || any(names(.attrs) == ""))
1403               stop("all node attributes must have a name")
1404
1405             if(is.character(suppressNamespaceWarning) || !suppressNamespaceWarning)
1406                 checkAttrNamespaces(getEffectiveNamespaces(node), .attrs, suppressNamespaceWarning)
1407
1408             if(append) {
1409                i = match(names(.attrs), names(node$attributes))
1410                if(any(!is.na(i))) {
1411                  node$attributes[i[!is.na(i)]] =  .attrs[!is.na(i)]
1412                  .attrs = .attrs[is.na(i)]
1413                }
1414                node$attributes = c(node$attributes, .attrs)
1415             } else
1416                node$attributes = .attrs
1417             node
1418           })
1419
1420setGeneric("removeAttributes", function(node, ..., .attrs = NULL, .namespace = FALSE,
1421                                        .all = (length(list(...)) + length(.attrs)) == 0)
1422                                 standardGeneric("removeAttributes"))
1423
1424
1425setGeneric("removeXMLNamespaces",
1426             function(node, ..., all = FALSE, .els = unlist(list(...)))
1427	         standardGeneric("removeXMLNamespaces"))
1428
1429
1430setMethod("removeXMLNamespaces", "XMLInternalElementNode",
1431          function(node, ..., all = FALSE, .els = unlist(list(...))) {
1432
1433      	      if(all)
1434                .Call("RS_XML_removeAllNodeNamespaces", node, PACKAGE = "XML")
1435	      else {
1436                 if(is.character(.els))
1437                   .els = lapply(.els, function(x) x)
1438                 .Call("RS_XML_removeNodeNamespaces", node, .els, PACKAGE = "XML")
1439              }
1440          })
1441
1442setMethod("removeAttributes", "XMLInternalElementNode",
1443#
1444# The idea here is to remove attributes by name
1445# We handle the case where these are a simple collection
1446# of character string identifiers given via the ... or as a character
1447# vector using, e.g., .attrs = c("a", "b")
1448#
1449# Each identifier can be of the form  "name" or "ns:name" giving
1450# the namespace prefix. We resolve the namespace and
1451#
1452
1453#  If we are dealing with regular attributes (no namespace attributes)
1454#  then we expect these as a character vector.
1455#
1456# The intent of the .namespace argument was originally to indicate that
1457# we wanted to remove the namespace definition. It appears that libxml2 does
1458# not support that. (And it would seem that this is a real pain as the xmlNsPtr
1459# objects can be shared across numerous places in a linked list, so it would
1460# be very difficult to remove it from one node.)
1461#
1462#
1463#
1464function(node, ..., .attrs = NULL, .namespace = FALSE,
1465          .all = (length(list(...)) + length(.attrs)) == 0)
1466{
1467   if(missing(.attrs))
1468     .attrs = list(...)
1469
1470   .attrs = as.character(.attrs)
1471
1472   if(.all) {
1473     if(length(list(...)) || length(.attrs))
1474         stop(".all specified as TRUE and individual values specified via .../.attrs")
1475
1476         # Use the integer indices to identify the elements.
1477     .Call("RS_XML_removeNodeAttributes", node, seq(along = xmlAttrs(node)), FALSE, PACKAGE = "XML")
1478     return(node)
1479   }
1480
1481
1482   if(is(.namespace, "XMLNamespaceDeclaration"))
1483     .namespace = list(.namespace)
1484#XXX
1485
1486   tmp = strsplit(.attrs, ":")
1487   prefix = sapply(tmp, function(x) if(length(x) > 1) x[1] else "")
1488   ids = sapply(tmp, function(x) if(length(x) == 1) x[1] else x[2])
1489
1490   if(any(prefix != "") && is.logical(.namespace))
1491     .namespace = TRUE
1492
1493   if(is.logical(.namespace) && .namespace) {
1494     ns = namespaceDeclarations(node, TRUE)
1495     # need to create a list with the elements corresponding to the
1496     # (potentially repeated) ns elements
1497
1498     i = match(prefix, names(ns))
1499     ns = ns[i]
1500     names(ns) = gsub("^.*:", "", .attrs) # or ids from above
1501
1502     .attrs = ns
1503   }
1504
1505   .Call("RS_XML_removeNodeAttributes", node, .attrs, .namespace, PACKAGE = "XML")
1506   node
1507})
1508
1509
1510setMethod("removeAttributes", "XMLNode",
1511function(node, ..., .attrs = NULL, .namespace = FALSE,
1512         .all = (length(list(...)) + length(.attrs)) == 0)
1513{
1514   a = node$attributes
1515
1516   if(missing(.attrs))
1517     .attrs = list(...)
1518
1519   .attrs = as.character(.attrs)
1520
1521  if(.all) {
1522    if(length(.attrs))
1523      stop("Both individual attribute names and .all specified")
1524    node$attributes = character()
1525    return(node)
1526  }
1527
1528  i = match(.attrs, names(a))
1529  if(any(is.na(i)) )
1530     warning("Can't locate attributes ", paste(.attrs[is.na(i)], collapse = ", "), "in XML node ", node$name)
1531
1532  a = a[is.na(i)]
1533
1534  node$attributes <- a
1535  node
1536})
1537
1538#xmlNamespaceDefinitions =  # ??? added this but overrides other S3 generic.
1539namespaceDeclarations =
1540function(node, ref = FALSE, ...)
1541{
1542  .Call("RS_XML_getNsList", node,  as.logical(ref), PACKAGE = "XML")
1543}
1544
1545
1546"xmlName<-" =
1547function(x, value)
1548{
1549   UseMethod("xmlName<-")
1550}
1551
1552"xmlName<-.XMLNode" <-
1553function(x, value)
1554{
1555   x$name <- value
1556   x
1557}
1558
1559"xmlName<-.XMLInternalElementNode" <-
1560function(x, value)
1561{
1562   # we could handle a new namespace by accepting value as
1563   # a character vector with a name
1564   # e.g.   c(r:array = 'http://www.r-project.org')
1565   # Alternatively, just define the namespace on the node _before_
1566   # changing the name.
1567   id = names(value)
1568   if(!is.null(id) && length( (tmp <- strsplit(id, ":")[[1]])) > 1) {
1569       names(value) = tmp[1]
1570       newXMLNamespaces(x, .values = as(value, "character"))
1571       value = id
1572   }
1573
1574   .Call("RS_XML_setNodeName", x, value, PACKAGE = "XML")
1575
1576   x
1577}
1578
1579
1580
1581newXMLNamespaces =
1582  # allow for multiple namespaces
1583  # and also allow for "r:value"
1584  #
1585  #  newXMLNamespaces(node, r = "http://www.r-project.org", ...)
1586  #
1587function(node, ..., .values = list(...))
1588{
1589  ids = names(.values)
1590  ans = lapply(ids, function(id)
1591                      newNamespace(node, id, as.character(.values[[id]])))
1592
1593  names(ans) = ids
1594  ans
1595}
1596
1597
1598
1599
1600xmlNodeMatch =
1601function(x, table, nomatch = NA_integer_)
1602{
1603  .Call("R_matchNodesInList", x, table, as.integer(nomatch), PACKAGE = "XML")
1604}
1605
1606
1607setGeneric("xmlClone",
1608function(node, recursive = TRUE, addFinalizer = FALSE, ...)
1609           {
1610              oclass = class(node)
1611              ans = standardGeneric("xmlClone")
1612              if(!isS4(node))
1613                class(ans) = oclass
1614              ans
1615           })
1616
1617setMethod("xmlClone", "XMLInternalDocument",
1618function(node, recursive = TRUE, addFinalizer = NA, ...)
1619{
1620  ans = .Call("RS_XML_clone", node, as.logical(recursive), addFinalizer, PACKAGE = "XML")
1621
1622  addDocFinalizer(ans, addFinalizer)
1623  ans
1624})
1625
1626setMethod("xmlClone", "XMLInternalNode",
1627function(node, recursive = TRUE, addFinalizer = FALSE, ...)
1628{
1629  ans = .Call("RS_XML_clone", node, as.logical(recursive), addFinalizer, PACKAGE = "XML")
1630})
1631
1632
1633
1634
1635
1636
1637
1638
1639ensureNamespace =
1640  #
1641  # Idea is to make certain that the root node has definitions for the specified
1642  # namespaces.  The caller specifies the named vector of interest.
1643  # If the URL already exists, we return the corresponding prefix.
1644  #
1645  #
1646  #  Returns the prefixes in the documents that correspond to the
1647  #  namespace definitions
1648  #
1649function(doc, what)
1650{
1651  if(is(doc, "XMLInternalDocument"))
1652     node = xmlRoot(doc)
1653  else
1654     node = doc
1655
1656  defs = xmlNamespaceDefinitions(xmlRoot(doc), simplify = TRUE)
1657  i = match(what, defs)
1658  w = is.na(i)
1659
1660  if(any(w)) {
1661     sapply(names(what)[w], function(id) newXMLNamespace(node, what[id], id))
1662     names(what)[w]
1663  } else
1664     names(defs)[i]
1665}
1666
1667
1668"xmlParent<-" =
1669 function(x, ..., value) {
1670  addChildren(value, ..., kids = list(x))
1671}
1672
1673
1674setOldClass("XMLNamespaceRef")
1675setAs("XMLNamespaceRef", "character",
1676       function(from) {
1677 	.Call("R_convertXMLNsRef", from, PACKAGE = "XML")
1678       })
1679
1680
1681
1682
1683xmlSearchNs =
1684function(node, ns, asPrefix = TRUE, doc = as(node, "XMLInternalDocument"))
1685{
1686
1687 .Call("R_xmlSearchNs", doc, node, as.character(ns), as.logical(asPrefix), PACKAGE = "XML")
1688}
1689