dtdIsAttribute <-
function(name, element, dtd)
{
 if(!inherits(element,"XMLElementDef")) {
   element <- dtdElement(as.character(element), dtd)
 }

# return(!is.na(amatch(name, names(element$attributes))))
 return(!is.na(match(name, names(element$attributes))))
}

dtdValidElement <-
#
# checks whether an XML element named `name'
# can be inserted into an element named `within'
# as defined in the specific DTD, optionally
# specifying the position the `name' element would
# be added.
#
# Ideally, this would be used when writing to an XML stream
# (doesn't exist in R or S, yes).
# The stream would monitor the currently open tags
# (as a stack) and would be able to test whether a new 
# insertion was valid.

function(name, within, dtd, pos=NULL)
{

 el <- dtdElement(within, dtd)
 if(is.null(el))
     stop(paste("No such element \"",within,"\" in DTD",sep="", collapse=""))

 return(dtdElementValidEntry(el, name,pos=pos))
}

dtdElementValidEntry <-
function(element, name, pos=NULL)
{
 UseMethod("dtdElementValidEntry", element, name, pos)
}

dtdElementValidEntry.XMLElementDef <-
function(element, name, pos=NULL)
{
 return(dtdElementValidEntry(element$contents,name,pos=pos))
}

dtdElementValidEntry.XMLOrContent <-
function(element, name, pos=NULL)
{
 for(i in element$elements) {
   if(dtdElementValidEntry(i, name, pos=pos))
     return(TRUE)
 }

 return(FALSE)
}

dtdElementValidEntry.XMLElementContent <-
function(element, name, pos=NULL)
{
 # if there are no sub-element types, then can't be here.
 # Might check this is a PCDATA by looking at the type.
 if(is.null(element$elements)) {
  return(FALSE)
 }

 return( any(element$elements == name) )
}

dtdElementValidEntry.character <-
function(element, name, pos=NULL)
{
 return(element == name)
}

dtdElementValidEntry.XMLSequenceContent <-
function(element, name, pos=NULL)
{
 if(!is.null(pos)) {
   tmp <- element$elements[[as.integer(pos)]]
   if(!is.null(tmp))
      return(dtdElementValidEntry(tmp))
   else
     return(FALSE)
 }

 for(i in element$elements) {
   if(dtdElementValidEntry(i, name)) {
     return(TRUE)
   }
 }

 return(FALSE)
}

xmlContainsEntity <-
#
# Determine if a particular entity is defined
# within the DTD.
#
function(name, dtd)
{
 return(!is.na(match(name,dtd$entities)))
}

xmlContainsElement <-
#
# Determine if a particular entity is defined
# within the DTD.
#
function(name, dtd)
{
 return(!is.na(match(name,dtd$element)))
}


dtdEntity <-
#
# Retrieves the specified entity from the DTD definition.
# Uses the `dtd$entitities' list.
#
function(name, dtd)
{
 dtd$entities[[name]]
}

dtdElement <-
#
# Retrieves the specified element from the DTD definition.
# Uses the `dtd$elements' list.
function(name, dtd)
{
 dtd$elements[[name]]
}
#
# Some methods for the DTD classes, similar in spirit
# to those in XMLClasses
#
#    print()
#
#
#
# XMLSystemEntity
# XMLEntity
# XMLElementDef
# XMLSequenceContent
# XMLOrContent
# XMLElementContent
# XMLAttributeDef
#


print.XMLElementDef <-
function(x, ...)
{
 cat("<!ELEMENT", x$name," ")
 print(x$contents)
 cat(">\n")
 if(length(x$attributes)) {

 cat("<!ATTLIST ", x$name,"\n")
  for(i in x$attributes) {
    cat("\t")
    print(i)
    cat("\n")
  }
  cat(">\n")
 }
}


print.XMLElementContent <-
function(x, ...)
{
 if(names(x$type)[1] == "PCData") {
   cat(" ( #PCDATA ) ")
   return()
 }
 cat("(")
 cat(x$elements)
 cat(")",switch(names(x$ocur)[1],Once="", "One or More"="+","Zero or One"="?","Mult"="*")) 
}


print.XMLOrContent <-
function(x, ...)
{
 n <- length(x$elements)
 cat("( ")
 for(i in 1:n) {
   print(x$elements[[i]])
   if(i < n)
    cat(" | ")
 }
 cat(" )")
}

print.XMLSequenceContent <-
function(x, ...)
{
 cat("( ")
 n <- length(x$elements)
 for(i in 1:n) {
    print(x$elements[[i]])
    if(i < n)
        cat(", ")
 }
 cat(" )")
}


print.XMLAttributeDef <-
function(x, ...)
{
 if(names(x$defaultType)[1] != "Implied")
   dflt <- paste("\"", x$defaultValue,"\"",collapse="",sep="")
 else
  dflt <- ""

 cat(x$name, xmlAttributeType(x), xmlAttributeType(x, TRUE), dflt)
}

xmlAttributeType <-
function(def, defaultType = FALSE)
{

 if(defaultType == FALSE & names(def$type)[1] == "Enumeration") {
   return( paste("(",paste(def$defaultValue,collapse=" | "),")", sep=" ", collapse="") )
 }

 switch(ifelse(defaultType, names(def$defaultType)[1], names(def$type)[1]),
         "Fixed" = "#FIXED",
         "CDATA" = "CDATA",
         "Implied" = "#IMPLIED",
         "Required" = "#REQUIRED",
         "Id" = "#ID",
         "IDRef" = "#IDREF",
         "IDRefs" = "#IDREFS",
         "Entity" = "#ENTITY",
         "Entities" = "ENTITIES",
         "NMToken" = "#NMTOKEN",
         "NMTokens" = "#NMTOKENS",
         "Enumeration" = "",
         "Notation" = "",
         "<BROKEN>"
       )
}


print.XMLEntity <-
function(x, ...)
{
 cat("<!ENTITY %", x$name,paste("\"", x$value,"\"",sep="",collapse=""), ">\n")
}


xmlAttrs.XMLElementDef <-
function(node)
{
 node$attributes
}

.InitSAXMethods <-
  # Defines S4 classes for use with the SAX parser and specifically to do with the
  # state variable.
  # This also defines methods for the 
function(where = "package:XML") {  
   require(methods)

   setClass("SAXState",  "VIRTUAL", where = where)

   setGeneric("startElement.SAX", function(name, atts, .state = NULL)  standardGeneric("startElement.SAX"), where = where)
   setGeneric("endElement.SAX", function(name, .state = NULL) { standardGeneric("endElement.SAX")}, where = where)
   setGeneric("comment.SAX", function(content,  .state = NULL) { standardGeneric("comment.SAX")}, where = where)
   # Note that we drop the . here.
   setGeneric("text.SAX", function(content,  .state = NULL) { standardGeneric("text.SAX")}, where = where)
   setGeneric("processingInstruction.SAX", function(target, content, .state = NULL) { standardGeneric("processingInstruction.SAX")}, where = where)
   setGeneric("entityDeclaration.SAX", function(name, base, sysId, publicId, notationName, .state = NULL) { standardGeneric("entityDeclaration.SAX")}, where = where)

   setMethod("startElement.SAX", signature(.state = "SAXState"),
                function(name, atts, .state = NULL) .state, where = where)
   setMethod("endElement.SAX", signature(.state = "SAXState"),
                function(name, .state = NULL) .state, where = where)
   setMethod("comment.SAX", signature(.state = "SAXState"),
                function(content, .state = NULL) .state, where = where)
   setMethod("text.SAX", signature(.state = "SAXState"),
                function(content, .state = NULL) .state, where = where)
   setMethod("processingInstruction.SAX", signature(.state = "SAXState"),
                function(target, content, .state = NULL) .state, where = where)
   setMethod("entityDeclaration.SAX", signature(.state = "SAXState"),
                function(name, base, sysId, publicId, notationName, .state = NULL) .state, where = where)

   return(TRUE)
}

genericSAXHandlers  <-
function(include, exclude)
{
 if(!exists("startElement.SAX"))
   stop("You must call .InitSAXMethods before calling genericSAXHandlers()n")


 ans <- list(startElement = startElement.SAX,
             endElement = endElement.SAX,
             comment = comment.SAX,
             text = text.SAX,
             processingInstruction = processingInstruction.SAX,
             entityDeclaration = entityDeclaration.SAX)

 if(!missing(include))
   ans <- ans[include]
 else if(!missing(exclude)) {
   which <- match(exclude, names(ans))
   ans <- ans[-which]
 }

  ans
}


#
# This file contains the definitions of methods
# for operating on the XMLNode objects to make
# the more user-friendly.  Specifically, these
# methods are 
#       print   displays the contents of a node and children
#               as XML text rather than R/S list
#
#       size    returns the number of children
#
#       name    retrieves the tag name
#
#       attrs   retrieves the attributes element of the XML node
#
#    [ and [[   access the children 
#                 (To get at the regular R/S fields in the object, use $
#                    e.g.  node$name, node$attributes, node$value)

#
# In S4/Splus5, we should use the new class mechanism.
#

xmlChildren <-
function(x)
{
 UseMethod("xmlChildren")
}

xmlChildren.XMLNode <-
#
# Retrieve the list of children (sub-nodes) within
# an XMLNode object.
#
function(x)
{
  x$children
}

xmlName <-
#
#
#
function(node, full = FALSE)
{
  UseMethod("xmlName", node)
}

xmlName.XMLComment <-
function(node, full = FALSE) {
 return("comment")
}

xmlName.XMLNode <-
#
# Get the XML tag name of an XMLNode object
#
function(node, full = FALSE)
{
  if(full && !is.null(node$namespace) && node$namespace != "") {
    tmp <- ifelse(is.character(node$namespace), node$namespace, node$namespace$id)
    paste(tmp, node$name, sep=":")
  }
  else
    node$name
}

xmlAttrs <-
function(node)
{
  UseMethod("xmlAttrs", node)
}

xmlAttrs.XMLNode <-
#
# Get the named list of attributes
# for an XMLNode object.
#
function(node)
{
 node$attributes
}



"[.XMLNode" <-
#
# Extract the  children (sub-nodes) within
# the specified object identified by ...
# and return these as a list
#
function(obj, ...)
{
 obj <- obj$children
 NextMethod("[")
}

"[[.XMLDocumentContent" <-
function(obj, ...) 
{
  obj$children[[...]]
}

"[[.XMLNode" <-
#
# Extract the  children (sub-nodes) within
# the specified object identified by ...
#
function(obj, ...)
{
# print("[.XMLNode")
 obj <- obj$children
 NextMethod("[[")
}

names.XMLNode <-
function(x)
{
 names(xmlChildren(x))
}

length.XMLNode <-
function(x)
{
  xmlSize(x)
}

xmlSize <-
#
# The number of elements within (or length of) a collection
#
function(obj)
{
 UseMethod("xmlSize", obj)
}

xmlSize.XMLDocument <-
function(obj)
{
 return(length(obj$doc$children))
}

xmlSize.default <-
#
# The number of elements within (or length of) a collection
#
function(obj)
{
  length(obj)
}

xmlSize.XMLNode <-
#
# Determine the number of children (or sub-nodes) within an XML node.
#
function(obj)
{
  length(obj$children) 
}


print.XMLComment <-
function(x, ..., indent = "")
{
  cat(indent, "<!--", xmlValue(x), "-->","\n", sep="")
}

print.XMLTextNode <-
function(x, ..., indent = "")
{
  cat(indent, xmlValue(x),"\n", sep="")
}  

print.XMLNode <-
#
# displays a node and attributes (and its children)
# in its XML format.
# 
function(x, ..., indent = "")
{
 if(! is.null(xmlAttrs(x))) {
   tmp <- paste(names(xmlAttrs(x)),paste("\"", xmlAttrs(x),"\"", sep=""), sep="=", collapse=" ")
 } else 
   tmp <- ""

 if(!is.null(x$namespaceDefinitions)) {
   ns <- paste(sapply(x$namespaceDefinitions, function(x) paste("xmlns:", x$id, "=",  x$uri,sep="")), collapse=" ")
 } else 
   ns <- ""

 
 cat(indent, paste("<",xmlName(x, TRUE),
                     ifelse(tmp != ""," ",""), tmp,
                     ifelse(ns != ""," ",""), ns,
                   ">\n", sep=""))
   # Add one space to the indentation level for the children.
   # This will accumulate across successive levels of recursion.
  subIndent <- paste(indent, " ", sep="")
  for(i in xmlChildren(x)) {
     print(i, indent= subIndent)
  }
 cat(indent, paste("</",xmlName(x, TRUE),">\n",sep=""))
}

print.XMLEntityRef <-
function(x, ..., indent="")
{
 cat(indent, x$value)
}



print.XMLCDataNode <-
function(x, ..., indent="")
{
 cat(indent, "<![CDATA[\n")
   # Want new lines in value to be replaced by paste("\n", indent, sep="")
 cat(indent, x$value)
 cat(indent, "]]>\n")
}


print.XMLProcessingInstruction <-
function(x, ..., indent="")
{
 cat(indent, paste("<?", x$name," ", x$value, "?>\n", sep=""))
}


xmlElementsByTagName <-
#
# Extract all the sub-nodes within an XML node
# with the tag name `name'.
#
function(el, name) {
  idx <-  (names(el$children) == name)
      el$children[idx]
}

xmlRoot <-
function(x, ...)
{
 UseMethod("xmlRoot")
}

xmlRoot.XMLDocument <-
function(x, ...)
{
#  x$children[[1]]
# x$doc

  xmlRoot(x$doc, ...)
}

xmlRoot.XMLDocumentContent <-
function(x, ...)
{
  args <- list(...)
  if("skip" %in% names(args))
   skip <- args[["skip"]]
  else
   skip <- TRUE

  a <- x$children[[1]]
  if(skip & inherits(a, "XMLComment")) {
     which <- sapply(x$children, function(x) !inherits(x, "XMLComment"))
     if(any(which)) {
       which <- (1:length(x$children))[which]
       a <- x$children[[which[1]]]
     } 
  }

 a
}

xmlApply <-
function(X, FUN, ...)
{
  UseMethod("xmlApply")
}

xmlSApply <-
function(X, FUN, ...)
{
  UseMethod("xmlSApply")
}

xmlApply.XMLNode <- 
function(X, FUN, ...) { 
  lapply(xmlChildren(X), FUN, ...) 
} 


xmlApply.XMLDocument <-
function(X, FUN, ...)
{
  xmlApply(xmlRoot(X), FUN, ...)
}

xmlSApply.XMLDocument <-
function(X, FUN, ...)
{
  xmlSApply(xmlRoot(X), FUN, ...)
}


xmlSApply.XMLNode <- 
function(X, FUN, ...) { 
  sapply(xmlChildren(X), FUN, ...) 
} 

xmlApply.XMLDocumentContent <-
function(X, FUN, ...)
{
  xmlSApply(X$children, FUN, ...)
}

xmlSApply.XMLDocumentContent <-
function(X, FUN, ...)
{
  xmlSApply(X$children, FUN, ...)
}


xmlValue <- 
function(x, ignoreComments = FALSE)
{
 UseMethod("xmlValue")
}

xmlValue.XMLNode <- 
function(x, ignoreComments = FALSE)
{
 if(xmlSize(x) == 1) # && (inherits(x[[1]], "XMLTextNode"))
    return(xmlValue(x[[1]], ignoreComments))

 x$value
}

xmlValue.XMLTextNode <- 
function(x, ignoreComments = FALSE)
{
 x$value
}

xmlValue.XMLComment <- 
function(x, ignoreComments = FALSE)
{
 if(ignoreComments)
   return("")

 x$value
}

xmlValue.XMLCDataNode <- 
function(x, ignoreComments = FALSE)
{
 x$value
}

xmlValue.XMLProcessingInstruction <- 
function(x, ignoreComments = FALSE)
{
 x$value
}


xmlNamespace <-
function(x)
{
 UseMethod("xmlNamespace")
}


xmlNamespace.XMLNode <-
function(x)
{
 x$namespace
}


xmlGetAttr <-
function(node, name, default = NULL, converter = NULL)
{
  a <- xmlAttrs(node)
  if(is.null(a) || is.na(match(name, names(a)))) 
    return(default)

  if(!is.null(converter))
    converter(a[[name]])
  else
    a[[name]]
}  

xmlDOMApply <- 
function(dom, func)
{
 .Call("RS_XML_RecursiveApply", dom, func, NULL)
}
"[<-.XMLNode" <-
function(x,i,value)
{
  x$children[i] <- value
 x
}


"[[<-.XMLNode" <-
function(x,i,value)
{
  x$children[[i]] <- value
 x
}


append.xmlNode <-
function(to, ...)
{
 UseMethod("append")
}

append.XMLNode <-
function(to, ...)
{
 args <- list(...)
 if(!inherits(args[[1]], "XMLNode") && is.list(args[[1]]))
   args <- args[[1]]
    
 idx <- seq(length(to$children) + 1, length=length(args))

 if(is.null(to$children))
   to$children <- args
 else  {
   to$children[idx] <- args  
#   names(to$children)[idx] <- names(args)
 }
 to
}
xmlNode <-
function(name, ..., attrs=NULL, namespace="")
{
  kids <- lapply(list(...), asXMLNode)
  node <- list(name = name, attributes = attrs, children = kids, namespace=namespace)
  class(node) <- c("XMLNode")

  node
}

xmlTextNode <- 
function(value, namespace="")
{
  node <- xmlNode("text", namespace=namespace)
  node$value <- value
  class(node) <- c("XMLTextNode", class(node))
 node
}


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

 x
}

xmlCommentNode <-
function(text)
{
  node <- xmlTextNode(text)
  class(node) <- c("XMLCommentNode", class(node))
 node
}

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

 node
}

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

supportsExpat <-
function()
{
  is.loaded("RS_XML_initParser")
}

supportsLibxml <-
function()
{
  is.loaded("RS_XML_piHandler")
}
htmlTreeParse <- 
#
# HTML parser that reads the entire `document' tree into memory
# and then converts it to an R/S object. 
# Uses the libxml from Daniel Veillard at W3.org. 
#
# asText  treat the value of file as XML text, not the name of a file containing
#       the XML text, and parse that.
# See also xml
#
function(file, ignoreBlanks = TRUE, handlers=NULL,
           replaceEntities=FALSE, asText=FALSE, trim=TRUE, isURL=FALSE, asTree = FALSE)
{
  if(missing(isURL)) {
    isURL <- length(grep("http://",file)) | length(grep("ftp://",file))
  }

    # check whether we are treating the file name as
    # a) the XML text itself, or b) as a URL.
    # Otherwise, check if the file exists and report an error.
 if(asText == FALSE & isURL == FALSE) {
  if(file.exists(file) == FALSE)
     stop(paste("File", file, "does not exist "))
 }

 ans <- .Call("RS_XML_HtmlParseTree", as.character(file), handlers, 
         as.logical(ignoreBlanks), as.logical(replaceEntities),
          as.logical(asText), as.logical(trim), as.logical(isURL))

 if(!missing(handlers) & !as.logical(asTree))
   return(handlers)

 ans
}
parseDTD <- 
function(extId, asText=FALSE, name="", isURL=FALSE)
{
  extId <- as.character(extId)
  if(missing(isURL)) {
    isURL <- length(grep("http://",extId)) | length(grep("ftp://",extId))
  }

  if(missing(name))
    name <- extId
 .Call("RS_XML_getDTD", as.character(name), as.character(extId),  
                          as.logical(asText), as.logical(isURL))
}
supportsExpat <-
function()
{
  FALSE
}

supportsLibxml <-
function()
{
  TRUE
}

toString.XMLNode <-
function(x, ...)
{
  con <- textConnection(".tempXMLOutput", "w")
  sink(con)
  print(x)
  sink()
  close(con)
  paste(.tempXMLOutput, collapse="\n")
}  
libxmlVersion <-
function()
{
 v <- .Call("RS_XML_libxmlVersion")
 v <- as.character(v)
 els <- substring(v, 1:nchar(v), 1:nchar(v))
 list(major=els[1], minor=paste(els[2:3],sep="", collapse=""), patch=paste(els[4:5], sep="", collapse=""))
}
xmlEventHandler <- 
function() {
  con <- xmlOutputDOM()

  startElement <- function(name, atts,...) {
    con$addTag(name, attrs=atts, close=FALSE)
  }
  endElement <- function(name) {
    con$closeTag(name)
  }
  text <- function(x,...) {
    con$addNode(xmlTextNode(x))  
  }
  comment <- function(x,...) {
    xmlCommentNode(x)
  }
  externalEntity <- function(ctxt, baseURI, sysId, publicId,...) {
    cat("externalEntity", ctxt, baseURI, sysId, publicId,"\n")
  }
  entityDeclaration <- function(name, baseURI, sysId, publicId,notation,...) {
    cat("externalEntity", name, baseURI, sysId, publicId, notation,"\n")
  }

 processingInstruction <- function(sys, value) {
   con$addNode(xmlPINode(sys, value))
 }

 list(startElement=startElement, endElement=endElement, processingInstruction=processingInstruction, text=text, comment=comment, externalEntity=externalEntity, entityDeclaration=entityDeclaration, dom=function(){con})
}

xmlEventParse <- 
#
# Parses an XML file using an event parser which calls user-level functions in the
# `handlers' collection when different XML nodes are encountered in the parse stream.
#
# See also xmlParseTree()
#
function(file, handlers=xmlEventHandler(), ignoreBlanks=FALSE, addContext = TRUE,
          useTagName = TRUE, asText = FALSE, trim=TRUE, useExpat = FALSE, isURL=FALSE, state = NULL,
          replaceEntities = TRUE) 
{
  if(missing(isURL)) { 
        # check if this is a URL or regular file.
    isURL <- length(grep("http://",file)) | length(grep("ftp://",file))
  }

 if(isURL == FALSE & asText == FALSE) {
  if(file.exists(file) == FALSE)
     stop(paste("File", file, "does not exist "))
 }

 state <- .Call("RS_XML_Parse", as.character(file), handlers, 
                    as.logical(addContext), as.logical(ignoreBlanks),  
                     as.logical(useTagName), as.logical(asText), as.logical(trim), 
                      as.logical(useExpat), state, as.logical(replaceEntities))
 if(!is.null(state))
   return(state)
 else
   return(invisible(handlers))
}
xmlHandler <- 
function() {
  data <- list()
  startElement <- function(name, atts,...) {
    if(is.null(atts))
      atts <- list()
    data[[name]] <<- atts
  }
  text <- function(x,...) {
    cat("MyText:",x,"\n")   
  }
  comment <- function(x,...) {
    cat("comment", x,"\n")
  }
  externalEntity <- function(ctxt, baseURI, sysId, publicId,...) {
    cat("externalEntity", ctxt, baseURI, sysId, publicId,"\n")
  }
  entityDeclaration <- function(name, baseURI, sysId, publicId,notation,...) {
    cat("externalEntity", name, baseURI, sysId, publicId, notation,"\n")
  }

  foo <- function(x,attrs,...) { cat("In foo\n")}
  return(list(startElement=startElement, getData=function() {data},
               comment=comment, externalEntity=externalEntity,
                entityDeclaration=entityDeclaration,
                text=text, foo=foo))
}
xmlOutputBuffer <-
#
#
# Want to check with the DTD whether a tag is legitimate
#  attributes are valid, etc.
#
# Add an indentation level.
#
#  Need to escape characters via entities:
#      <-   => %sgets;
#      <    => %lt;
#      >    => %gt;
#   etc.
#
#
# Allow xmlEndTag with no argument to allow closing the current one.
#  (Maintain a stack)
#
# Allow addTag(tag, addTag(), addTag(),)
#
#
#  The handling of the connection (i.e. the buf argument) can
# be cleaned up using the OOP package from Omegahat. This will be done
# in the future.
#
#
# sapply(names(nameSpace), function(i, x){paste("xmlns:",i,"=\"",x[[i]],"\"", sep="")}, x=nameSpace)
#
#
#
function(dtd = NULL, nameSpace= "", buf=NULL, nsURI=NULL,
         header="<?xml version=\"1.0\"?>")
{
    # If the user gave as an existing buffer and header is non-NULL,
    # we appendd it to the buffer. This can be used for adding things
    # like section breaks, etc.
    #
    # If the user did not give us a buffer, then we use the header.
    #
    # This is done immediately the function is called, rather than
    # in the calls to the functions of the closure after it is returned.
  if(is.null(buf))
    buf <- header
  else if(inherits(buf, "connection")) {
     if(!isOpen(buf)) {
       open(buf, rw = "w")
       on.exit(close(buf))
     }
  } else if(!is.null(header))
    cat(header,"\n", sep="", file=buf)


  if(missing(nameSpace) && !is.null(nsURI) && !is.null(names(nsURI))) {
    nameSpace <- names(nsURI)[1]
  }

  openTags <- NULL  #list()
  lastTag <- 0


   # This is called from addTag() when the tag being 
   # emitted into the stream is left open by that call.
   # We store the tag name, its namespace and the URI of the
   # namespace if there is one in this call.
   # This triple is appended as the last row of the openTags
   # matrix and lastTag is incremented.
  addOpenTag <- function(tag, ns, xmlns) {
    lastTag <<- lastTag+1
    if( lastTag == 1 ) {
      rval <- matrix(c(tag,ifelse(is.null(ns),"",ns),ifelse(is.null(xmlns),"",xmlns)), nr=1,
                     dimnames=list(NULL, c("tagname","nsprefix", "nsURI")) )
    } else
      rval <- rbind(openTags, c(tag, ifelse(is.null(ns),openTags[lastTag-1,2], ns), ifelse(is.null(xmlns),"",xmlns)))
    openTags <<- rval
  }


  checkNamespace <- function(ns) {
    return(TRUE)

## Ignored
    if( (lastTag == 0) )
      stop(paste("Namespace `",ns, "' is not defined\n",sep=""))
    m <- match(ns, openTags$nsprefix, NULL)
    if( any(!is.null(openTags[m,"nsURI"])) )
      return(FALSE)
    stop(paste("Namespace:",ns, "is not defined\n",sep=" "))
  }


  openTag <- function(tag, ..., attrs=NULL, sep="\n",
                       namespace=NULL, xmlns=NULL) {
    addTag(tag, ..., attrs = attrs, sep = sep, namespace = namespace, xmlns, close = FALSE)
  }

   # The namespace is the prefix for the tag name. 
   # For example, if the namespace is shelp and the tag is arg
   # the element is  shelp:tag.
   # In this function, we try to infer the ``current'' namespace
   # if the user doesn't specify it. We also have to ensure that 
   # the namespace has a definition before it is used.
   #
   # We also need to allow the user specify an empty namespace
   # so that tags 
  addTag <- function(tag, ..., attrs=NULL, sep="\n", close=TRUE,
                       namespace=NULL, xmlns=NULL) {

    tmp <- ""

      # Flag indicating whether this is the very first, top-level tag.
      # should be shared across these functions and part of the state of 
      # the output buffer instance ?
    startingTag <- is.null(getOpenTag())

      # The user didn't specify a namespace, then we need to check about the xmlns.
      # If the user specified that, then there is an inconsistency.
      # Otherwise, no namespace and no xmlns. So need to get the 
      # current nameSpace.
    if(is.null(namespace)) {
      if( !is.null(xmlns) ) {
         # Really want to look this up in the set of "global" namespaces.
        if(is.null(names(xmlns)))
           stop("you must specify the namespace as well as xmlns")
        namespace <- names(xmlns)[1]
      }
      else {
         # so there is no xmlns. 
         # We need to determine what the currently active
         # namespace is.
       cur <- getOpenTag()
       if(is.null(cur)) {
          # Use the default namespace  given when the buffer waas constructed
         namespace <- nameSpace
#         xmlns <- nsURI
       } else {
         startingTag <- FALSE
         namespace <- cur[["nsprefix"]]
       }
      }
    }

      # if you remap prefixes this could be a problem
    if(!startingTag && !is.null(namespace) && namespace == nameSpace && is.null(xmlns) ) {
      tmp1 <- getOpenTag()

      if(is.null(tmp1) && !is.null(nsURI)) { # || tmp1[["nsURI"]] != nsURI) {
        xmlns <- nsURI[1]
      } # else  namespace <- NULL
    }

   
      #if xmlns is given but not the namespace, then
      # check this.
    if( !is.null(namespace) && is.null(xmlns) )
      checkNamespace(namespace)


    if( !is.null(namespace) && !is.null(xmlns) ) {
      if(!is.null(names(xmlns))) {
         tmpp <- xmlns
         names(tmpp) <- paste("xmlns", names(tmpp), sep=":")
         attrs <- c(attrs, tmpp)
      } else
        attrs[[paste("xmlns", namespace, sep=":")]] <-  xmlns
    }

    if(startingTag && !is.null(nsURI)) {
       tmpp <- nsURI
       names(tmpp) <- paste("xmlns", names(nsURI), sep=":")
       attrs <- c(attrs, tmpp)
    }

     # if the namespace is non-trivial (null or ""), then concatenate with the
     # tag name. Also handle the case that this is the starting tag
     # and so no namespaces are defined at this point.

#    !startingTag &&
    tagName <- ifelse(!is.null(namespace) && namespace != "", paste(namespace,tag,sep=":"), tag)


    if(!is.null(attrs)) {
      tmp <- paste(" ", paste(names(attrs),
                              paste("\"",attrs,"\"",  sep=""),sep="=",
                              collapse=" "),sep="")  
    }


   
    add(paste("<", tagName, tmp, ">", sep=""))

    if(length(list(...)) > 0) {
      add(..., sep=sep)
    }

    if(close) 
      add(paste(ifelse(sep=="\n","","\n"), "</",tagName, ">", "\n", sep=""), sep="")
    else 
      addOpenTag(tag, namespace, xmlns)

    NULL
  }

   closeTag <- function(name=NULL, namespace=nameSpace) {
    if(is.null(name)) {
      tmp <- getOpenTag() 
      name <- tmp[1] 
      if(length(tmp)>1)
        namespace <- tmp[2] 

      openTags <<- openTags[-lastTag, ,drop = FALSE]
      lastTag <<- lastTag-1
    } else if(is.numeric(name)) {
      for(i in 1:name)
        closeTag()
      return()
    } 

    add("</", ifelse(!is.null(namespace) && namespace != "", paste(namespace,name,sep=":"), name),">\n", sep="")
   }



   # This returns the last entry in the matrix openTags
   # which should contain the currently open tag, namespace and 
   # associated URI.
  getOpenTag <-  function() {
    if(lastTag > 0)
      openTags[lastTag, ]
    else 
      NULL
  }


  # 


  paste0 <- function(..., sep="", collapse="") paste(..., sep = sep, collapse=collapse)

  reset <-  function() {
     buf <<- header
     openTags <<- list()
     lastTag <<- 0
  }

  addComment <- function(..., sep="\n") {
    add("<!--", ..., "-->", sep=sep)
  }

  add <- function(..., sep="\n") {
   if(is.character(buf))
     buf <<- paste(buf, paste0(..., collapse=sep), sep=sep) 
   else
     cat(paste0(..., collapse=sep), sep, sep="", file=buf)
  }


  addCData <- function(text) {
    add("<![CDATA[", text, "]]>", sep="\n")
  }

  addPI <- function(name, text) {
    add("<?", name, " ", text, "?>\n", sep="")
  }  

  tagString <- function(tag, ..., attrs, close=FALSE) {

    tmp <- ""

    if(!missing(attrs)) {
     tmp <- paste(" ", paste(names(attrs), paste("\"",attrs,"\"", sep=""), sep="=", collapse=" "),sep="")
    }
    return(paste0("<", tag,tmp, ">",...,"</",tag,">"))
  }

  con <- list( value=function() {buf},
               addTag = addTag,
               openTag = openTag,
               closeTag = closeTag,
               addEndTag = closeTag,
               reset = reset,
               tagString = tagString,
               add = add,
               addComment = addComment,
               addPI = addPI,
               addCData = addCData,
               getOpenTag=getOpenTag,
               addOpenTag=addOpenTag
              ) 

  class(con) <- c("XMLOutputBuffer", "XMLOutputStream")

  con 
}




xmlOutputDOM <-
function(tag="doc", attrs = NULL, dtd=NULL, nameSpace=NULL, nsURI=character(0))
{
 buf <- NULL
 current <- NULL

 reset <-
 function() {
  buf <<- xmlNode(tag, attrs = attrs, namespace = nameSpace)
  if(length(nsURI) > 0) {
   names(nsURI) <- paste("xmlns", names(nsURI), sep=":")
   buf$attributes <<- nsURI
  }
  current <<- integer(0)
  invisible(buf)
 }

 reset()


 addTag <- 
 function(tag, ..., attrs=NULL, close=TRUE, namespace=NULL) {
   if(missing(namespace))
     namespace <- nameSpace

   addNode(n <- xmlNode(tag, ..., attrs= attrs, namespace=namespace))
   if(close == FALSE) {
     current <<- c(current, xmlSize(getCurrent()))
   }

  invisible(n)
 }

 getCurrentExpr <- 
 function() {
   if(length(current) > 0) {
     p <- seq(2, length=length(current)-1)
     kall <- call("[[", as.name("buf"), current[1])
     for(i in p) {
       kall <- call("[[", kall, current[i])
     }
   } else
     kall <- as.name("buf")
     
   kall
 }

 getCurrent <- function() {
    eval(getCurrentExpr())
 }

  # We want to append this to the currently open (or active)
  # node as defined by `current'
  #   d[[1]] <- append.xmlNode(d[[1]], xmlNode("phone"))
 addNode <- 
 function(node) {
   kall <- getCurrentExpr()
  if(length(current) > 0){
   lhs <- kall
   kall <- call("append.xmlNode", kall, node)
   kall <- call("<<-", lhs, kall)
  } else {
   kall <- call("append.xmlNode", kall, node)
  }
   val <- eval(kall) 
   if(length(current) == 0)
     buf <<- val

  invisible(node)
 }

 addComment <- function(...) {
    addNode(xmlCommentNode(paste(as.character(), sep="")))
 }

 addCData <- function(text) {
    addNode(xmlCDataNode(text))
 }

 addPI <- function(name, text) {
    addNode(xmlPINode(name, text))  
 }   

 closeTag <-
 function(name="", namespace=NULL)  {
    # namespace is ignored since we already have the tag name!
   current <<- current[-length(current)]
 }

 con <- list( value=function() {buf},
              addTag = addTag,
              addEndTag = function(name){ closeTag(name)},
              closeTag = closeTag,
              reset = reset,
              addNode = addNode,
              add = function(...) {},
              addComment = addComment,
              addPI = addPI,
              addCData = addCData,             
              current = function(){current}
            ) 
  class(con) <- c("XMLOutputDOM", "XMLOutputStream")

 return(con)
}
xmlTree <-
function(tag=NULL, attrs = NULL, dtd=NULL, namespaces=list())
{
 doc <- newXMLDoc(dtd, namespaces)
 currentNodes <- list(doc)


 isXML2 <- libxmlVersion()$major != "1" 
 
 
 if(!is.null(dtd) && dtd != "") {
   if(isXML2) {
     node = .Call("R_newXMLDtd", doc, dtd, "", "")
     .Call("R_insertXMLNode", node, doc)
     currentNodes[[2]] <- node
   } else
     warning("DTDs not supported in R for libxml 1.*. Use libxml2 instead.")
 }
 
 definedNamespaces = list()
 
 asXMLNode <- function(x) {
        if(is.character(x)) {
          v <- .Call("R_newXMLTextNode", x)
        } else if(is.list(x)) {
          v <- lapply(x, asXMLNode)
        }  else {
          # Problem!
          browser()
        }

        v 
 }

 setNamespace <- function(node, namespace) {
     if(is.null(namespace))
       return(NULL)

     if(!is.na(match(namespace, names(namespaces))) && is.na(match(namespace, names(definedNamespaces)))) {
       ns <- .Call("R_xmlNewNs", node, namespaces[[namespace]], namespace, PACKAGE="XML")
       definedNamespaces[[namespace]] <<- ns
     }
     
     .Call("R_xmlSetNs", node, definedNamespaces[[namespace]], PACKAGE = "XML")
 }

 
 addTag <- function(name, ..., attrs=NULL, close=TRUE, namespace=NULL) {

   if(!is.null(attrs))
    storage.mode(attrs) <- "character"

   node <- .Call("R_newXMLNode", name, attrs, namespace, doc, PACKAGE = "XML")

   setNamespace(node, namespace)

   if(length(currentNodes) > 1)
     .Call("R_insertXMLNode", node, currentNodes[[1]])

   if(close == FALSE) {
    currentNodes <<- c(node, currentNodes)
   }

   kids <- list(...)
   if(length(kids)) {
    for(i in kids) {
      if(!inherits(i, "XMLNode")) {
        i <- asXMLNode(i)
      }
      .Call("R_insertXMLNode", i, node)
    }
   }

   invisible(return(node))
 }

 closeTag <- function(name="") {
  tmp <- currentNodes[[1]]
  currentNodes <<- currentNodes[-1]

  invisible(return(tmp))
 }

 addComment <- function(...) {
  node <- .Call("R_xmlNewComment", paste(as.character(list(...)), sep=""))
  .Call("R_insertXMLNode", node, currentNodes[[1]])   
 }


 addCData <- function(text) {
   node <- .Call("R_newXMLCDataNode", doc, as.character(text))
   if(length(currentNodes) > 1)
     .Call("R_insertXMLNode", node, currentNodes[[1]])
   node
 }

 addPI <- function(name, text) {
   node <- .Call("R_newXMLPINode", doc, as.character(name), as.character(text))
   if(length(currentNodes) > 1)
     .Call("R_insertXMLNode", node, currentNodes[[1]])
   node
 }  

 v <- list(
         addTag = addTag,
         addCData = addCData,
         addPI = addPI,
         closeTag = closeTag,
         addComment = addComment,
         value = function() doc,
         add = function(...){}
       )

 class(v) <- c("XMLInternalDOM", "XMLOutputStream")
 return(v)
}

newXMLDoc <-
#
# Creates internal C-level libxml object for representing
# an XML document/tree of nodes.
#
function(dtd, namespaces = NULL)
{
  .Call("R_newXMLDoc", dtd, namespaces)
}

newXMLNode <-
#
# Create an internal C-level libxml node
#
function(name, ..., attrs=NULL, namespace="", doc = NULL)
{
 if(!is.null(attrs)) {
   tmp <- names(attrs)
   attrs <- as.character(attrs)
   names(attrs) <- tmp
 }

 children <- list(...)

 node <- .Call("R_newXMLNode", as.character(name), attrs, as.character(namespace), doc)
 if(!is.null(children)) {
   for(i in children)
     .Call("R_insertXMLNode", i, node)
 }

 node
}


saveXML <-
function(doc, file=NULL, compression=0, indent=TRUE, prefix = '<?xml version="1.0"?>\n')
{
 UseMethod("saveXML")
}

saveXML.XMLInternalDocument <-
function(doc, file=NULL, compression=0, indent=TRUE, prefix = '<?xml version="1.0"?>\n')
{
  .Call("R_saveXMLDOM", doc, file, as.integer(compression), as.logical(indent), as.character(prefix))
}

saveXML.XMLInternalDOM <-
function(doc, file=NULL, compression=0, indent=TRUE, prefix = '<?xml version="1.0"?>\n')
{
  saveXML(doc$value(), file=file, compression=compression, indent=indent)
}


saveXML.XMLOutputStream =
function(doc, file = NULL, compression = 0, indent = TRUE, prefix = '<?xml version="1.0"?>\n')
{
  saveXML(doc$value(), file=file, compression=compression, indent=indent)
}

saveXML.XMLNode =
function(doc, file = NULL, compression = 0, indent = TRUE, prefix = '<?xml version="1.0"?>\n')
{
  sink(file)
  if(!is.null(prefix))
    cat(prefix)
  on.exit(sink())
  print(doc)
}


xmlTreeParse <- 
#
# XML parser that reads the entire `document' tree into memory
# and then converts it to an R/S object. 
# Uses the libxml from Daniel Veillard at W3.org. 
#
# asText  treat the value of file as XML text, not the name of a file containing
#       the XML text, and parse that.
# See also xml
#
function(file, ignoreBlanks = TRUE, handlers=NULL,
           replaceEntities=FALSE, asText=FALSE, trim=TRUE, validate=FALSE, getDTD=TRUE,
           isURL=FALSE, asTree = FALSE, addAttributeNamespaces = FALSE)
{
  if(missing(isURL)) {
    isURL <- length(grep("^http://",file)) | length(grep("^ftp://",file))
  }

    # check whether we are treating the file name as
    # a) the XML text itself, or b) as a URL.
    # Otherwise, check if the file exists and report an error.
 if(isURL == FALSE) {
  if(file.exists(file) == FALSE)
    if(!missing(asText) && asText == FALSE)
     stop(paste("File", file, "does not exist "))
    else
     asText <- TRUE
 }


 ans <- .Call("RS_XML_ParseTree", as.character(file), handlers, 
              as.logical(ignoreBlanks), as.logical(replaceEntities),
              as.logical(asText), as.logical(trim), as.logical(validate), as.logical(getDTD),
              as.logical(isURL), as.logical(addAttributeNamespaces))

 if(!missing(handlers) & !as.logical(asTree))
   return(handlers)

 ans
}
.First.lib <-
function(libname, pkgname)
{
 library.dynam("XML", pkgname, libname)

 if(exists("setMethod")) {
   .InitSAXMethods()
 }

}
#
#  Copyright (c) 1998, 1999 The Omega Project for Statistical Computing.
#       All rights reserved.#
