swh:1:snp:7d9f1bc35e120776766db9334626062f837c20ad
Tip revision: 9ee7aebbd4099fb9a462c14f75a73eb3755b1612 authored by Duncan Temple Lang on 03 October 2007, 00:00:00 UTC
version 1.93-2
version 1.93-2
Tip revision: 9ee7aeb
xmlTree.R
xmlTree <-
#
# Create an XML document using internal nodes and help to manage
# the state for the user rather than requiring them to manage
# the individual nodes. For the most part, the two approaches
# are relatively similar in complexity.
#
#
function(tag = NULL, attrs = NULL, dtd=NULL, namespaces = list(),
doc = newXMLDoc(dtd, namespaces))
# Allows a DOCTYPE, etc. at the beginning by specifying dtd as
# a vector of 1, 2, 3 elements passed to newXMLDTDNode() or
# as an XMLDTDNode directly.
#
{
currentNodes <- list(doc) # the stack of nodes
isXML2 <- libxmlVersion()$major != "1"
# if we are given a DTD, add it to the document.
if(!is.null(dtd)) {
if(isXML2) {
node = NULL
if(is(dtd, "XMLDTDNode"))
node = dtd
else if(is.character(dtd) && dtd[1] != "")
node = newXMLDTDNode(dtd, doc = doc)
if(!is.null(node)) {
addChildren(doc, node)
currentNodes[[2]] <- node #???XXX
}
} else
warning("DTDs not supported in R for libxml 1.*. Use libxml2 instead.")
}
definedNamespaces = list()
defaultNamespace = NULL
addNamespaceDefinitions = is.null(tag)
setActiveNamespace = function(ns) {
defaultNamespace <<- ns
}
asXMLNode <- function(x) {
if(is(x, "XMLInternalNode"))
return(x)
v = if(is.list(x))
lapply(x, asXMLNode)
else
newXMLTextNode(as.character(x), doc = doc)
v
}
setNamespace <- function(node, namespace = defaultNamespace) {
# if there is no namespace or if we have one and no names on the namespace
if(length(namespace) == 0 || ! ( length(namespace) == 1 && is.null(names(namespace)) ) )
return(NULL)
if(is.list(namespace))
return(NULL)
#debugging
if(FALSE) {
a = xmlNamespaceDefinitions(node)
b = namespaceDeclarations(node, TRUE)
}
#end debugging
if(!is.na(match(namespace, names(namespaces))) && is.na(match(namespace, names(definedNamespaces)))) {
ns <- .Call("R_xmlNewNs", node, namespaces[[namespace]], namespace)
definedNamespaces[[namespace]] <<- ns
}
setXMLNamespace(node, definedNamespaces[[namespace]])
#old setInternalNamespace( node, definedNamespaces[[namespace]])
}
# namespace is intended to be the namespace for this node
# and not any definitions.
# How do we define new namespaces with this function?
# Can we add them to attrs. No!
addTag <- function(name, ..., attrs = NULL,
close = TRUE, namespace = defaultNamespace, .children = list(...) )
{
if(inherits(name, "XMLInternalNode")) {
addChildren(currentNodes[[1]], name)
currentNodes <<- c(node, currentNodes)
addChildren(node, kids = .children)
if(close)
currentNodes <<- currentNodes[-1]
return(name)
}
# if the user gives us something like "r" for the namespace as opposed to
# c(r = "http:...") then we try to match the prefix in an earlier node
# ??? Should we use the defined namespaces in the document?
if(FALSE) {
if(length(namespace) == 1 && length(names(namespace)) == 0) {
tmp = namespace
if(length(currentNodes)) {
defs = namespaceDeclarations(currentNodes[[1]], TRUE)
i = match(namespace, names(defs))
if(!is.na(i))
namespace = defs[[i]]
}
}
}
if(!is.null(attrs))
storage.mode(attrs) <- "character"
if(inherits(name, "XMLInternalNode"))
node = name
else {
node <- newXMLNode(name, attrs = attrs, namespace = namespace, doc = doc,
parent = if(length(currentNodes) > 1) currentNodes[[1]] else xmlRoot(currentNodes[[1]]),
namespaceDefinitions = if(addNamespaceDefinitions) namespaces else NULL)
if(addNamespaceDefinitions) {
# lapply(seq(along = namespaces),
# function(i)
# setXMLNamespace(node, namespaces[[i]], names(namespaces)[i]))
addNamespaceDefinitions <<- FALSE
}
}
# if(length(currentNodes) > 1)
# addChildren(currentNodes[[1]], node)
currentNodes <<- c(node, currentNodes)
# if(!inherits(name, "XMLInternalNode"))
# setNamespace(node, namespace)
for(i in .children)
addChildren(node, asXMLNode(i)) # vectorize XXX
if(close == TRUE)
closeTag()
invisible(node)
}
closeTag <- function(name="") {
if(nargs() == 0) {
tmp <- currentNodes[[1]]
currentNodes <<- currentNodes[-1]
} else if( is.character(name) ) {
w = sapply(currentNodes, inherits, "XMLInternalElementNode")
useNamespace = length(grep(":", name)) > 0
ids = sapply(currentNodes[ w ], xmlName, useNamespace)
tmp = list()
for(id in name) {
i = which(id == ids)
if(length(i) == 0)
stop("Cannot close tag for node with name ", id, " - no such node open")
tmp = c(tmp, currentNodes[1:i])
currentNodes <<- currentNodes[-c(1:i)]
ids = ids[-(1:i)]
}
} else if(is(name, "numeric")) {
num = name
if(is.na(num) || num == -1)
# close all of the nodes, except the document node.
w = seq(along = currentNodes[- length(currentNodes)])
else if(length(num) == 1)
w = 1:num
else
w = num
tmp = currentNodes[ w ]
currentNodes <<- currentNodes[ - w ]
}
invisible(tmp)
}
add = function(node, parent = currentNodes[[1]], close = TRUE) {
if(!is.null(parent)) {
addChildren(parent, node)
if(!close)
currentNodes <<- c(node, currentNodes)
}
invisible(node)
}
addComment <- function(...) {
add(newXMLCommentNode(paste(as.character(list(...)), sep=""), doc = doc))
}
addCData <- function(text) {
add(newXMLCDataNode(text, doc = doc))
}
addPI <- function(name, text) {
add(newXMLPINode(name, text, doc = doc), NULL)
}
# deal with the top-level node the user may have supplied.
if(!is.null(tag)) {
if(is.character(tag)) {
node = addTag(tag, attrs = attrs, namespace = namespaces, close = FALSE)
} else if(is(tag, "XMLInternalNode")) {
if(is.null(xmlParent(node))) # if we have a DTD node, need to add it to that or parallel to that?
addChildren(doc, node)
}
}
v <- list(
addTag = addTag,
addNode = addTag,
addCData = addCData,
addPI = addPI,
closeTag = closeTag,
closeNode = closeTag,
addComment = addComment,
setNamespace = setActiveNamespace,
value = function() doc,
doc = function() doc,
add = function(...){}
)
class(v) <- c("XMLInternalDOM", "XMLOutputStream")
return(v)
}
# Also in xmlNodes.R
setAs("XMLInternalNode", "XMLNode",
function(from)
asRXMLNode(from)
)
setGeneric("free", function(obj) standardGeneric("free"))
setMethod("free", "XMLInternalDocument",
function(obj) .Call("R_XMLInternalDocument_free", obj))
xmlRoot.XMLInternalDOM =
function(x, ...)
{
xmlRoot(x$doc())
}
xmlRoot.XMLInternalElement =
function(x, ...)
{
xmlRoot(as(x, "XMLInternalDocument"))
}