The R Project SVN R-packages

xmlNode <-
function(name, ..., attrs = NULL, namespace = "",
          namespaceDefinitions = NULL, .children = list(...))
{
  kids <- lapply(.children, asXMLNode)
  kids = addNames(kids)

    # Check the names paces
  node <- list(name = name, attributes = attrs, children = kids, namespace=namespace,
                namespaceDefinitions = as(namespaceDefinitions, "XMLNamespaceDefinitions"))
  class(node) <- oldClass("XMLNode") # , "XMLAbstractNode")

  node
}

setAs("NULL", "XMLNamespaceDefinitions", function(from) structure(list(), class = "XMLNamespaceDefinitions"))

addNames =
function(kids, fromTag = TRUE)
{
  if(fromTag)
     names(kids) = sapply(kids, xmlName)
  else if(length(names(kids)) == 0)
      names(kids) <- sapply(kids,xmlName)
  else if(any( idx <- names(kids) == "")) 
      names(kids)[idx] <- sapply(kids[idx], xmlName)

  kids
}

setGeneric("xmlChildren<-",
function(x, ..., value) {
  standardGeneric("xmlChildren<-")
})

setMethod("xmlChildren<-", "ANY",
function(x, append = FALSE, ..., value) {
  #value = addNames(value)
  #x$children <- value
  addChildren(x, append = append, ..., kids = value)
})

# Don't need this.
# xmlName.character =
# function(node, full = FALSE)
#    "text"

setMethod("xmlChildren<-", "XMLInternalNode",
function(x, append = TRUE, ..., value) {
  if(!append)
     removeNodes(xmlChildren(x))
  if(!is.list(value))
    value = list(value)
  addChildren(x, kids = value)
})




addChildren =
function(node, ..., kids = list(...), at = NA, cdata = FALSE, append = TRUE)
  UseMethod("addChildren")


addChildren.XMLNode =  
function(node, ..., kids = list(...), at = NA, cdata = FALSE, append = TRUE)
{
  kids = lapply(kids,
                function(i) {
                  if(!inherits(i, "XMLNode"))
                    xmlTextNode(as.character(i), cdata = cdata)
                  else
                    i
                })

  node$children = if(append) c(node$children, kids) else kids
  node$children = addNames(node$children)
  
  node
}


# It would be better tokenize this, but ...
XMLEntities =
  c("&" = "amp",  # order is important as if we insert an entity, then the next time we will see the &.
    ">" = "gt",
    "<" = "lt",
    "'" = "apos",
    '"' = "quot")


insertEntities =
function(value, entities = XMLEntities)
{
    pat = names(entities)
    subs = paste("&", entities, ";", sep = "")
    for(i in seq(along = entities)) 
      value = gsub(pat[i], subs[i], value)

    value
}

xmlTextNode <- 
function(value, namespace = "", entities = XMLEntities, cdata = FALSE)
{
  node <- xmlNode("text", namespace = namespace)

  if(length(entities) && !inherits(value, "AsIs")) 
   value = insertEntities(value, XMLEntities)

  if(cdata)
    value = xmlCDataNode(value)
  
  node$value <- value
  if(!cdata)
     class(node) <- oldClass("XMLTextNode") # , class(node))
  if(length(entities))
    class(node) <- c(class(node), "EntitiesEscaped") #"XMLEntitiesEscapedTextNode"
  
  node
}


xmlPINode <-
function(sys, value, namespace="")
{
  x <- xmlNode(name=sys, namespace=namespace)
  x$value <- value
  class(x) <- oldClass("XMLProcessingInstruction") # , class(x))

 x
}

xmlCommentNode <-
function(text)
{
  node <- xmlTextNode(text)
  class(node) <- oldClass("XMLCommentNode") # , class(node))

  node
}

xmlCDataNode <-
function(...)
{
  txt <- paste(..., collapse="")  
 
  node <- xmlNode("text")
  node$value <- txt
  class(node) <- oldClass("XMLCDataNode") # , class(node))

 node
}

asXMLNode <-
function(x)
{
   #XXX
  if(!inherits(x, "XMLNode")) {
    xmlTextNode(x)
  } else {
    x
  }
}