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(T)
 }

 return(F)
}

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(F)
 }

 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(F)
 }

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

 return(F)
}

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(def)
{
 cat("<!ELEMENT",def$name," ")
 print(def$contents)
 cat(">\n")
 if(length(def$attributes)) {

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


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


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

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


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

 cat(def$name, xmlAttributeType(def), xmlAttributeType(def,T), dflt)
}

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

 if(defaultType == F & 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(ent)
{
 cat("<!ENTITY %", ent$name,paste("\"",ent$value,"\"",sep="",collapse=""), ">\n")
}


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

#
# 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)
{
  UseMethod("xmlName", node)
}

xmlName.XMLComment <-
function(node) {
 return("comment")
}

xmlName.XMLNode <-
#
# Get the XML tag name of an XMLNode object
#
function(node)
{
  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("[")
}

"[[.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(doc)
{
 return(length(doc$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.XMLNode <-
#
# displays a node and attributes (and its children)
# in its XML format.
# 
function(x,...)
{
 if(xmlName(x) == "text" || xmlName(x) == "comment") {
   cat(x$value,"\n", sep="")
   return()
 }

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

 cat(paste("<",xmlName(x),ifelse(!is.null(xmlAttrs(x))," ",""),tmp,">\n", sep=""))
  for(i in xmlChildren(x)) {
     print(i)
  }
 cat(paste("</",xmlName(x),">\n",sep=""))
}

print.XMLEntityRef <-
function(node)
{
 cat(node$value)
}


print.XMLCDataNode <-
function(node)
{
 cat("<![CDATA[\n")
 cat(node$value)
 cat("]]>\n")
}


print.XMLProcessingInstruction <-
function(node)
{
 cat(paste("<?", node$name," ", node$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, ...)
{
  xmlRoot(x$doc, ...)
}

xmlRoot.XMLDocumentContent <-
function(x, skip=T)
{
  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)
{
 UseMethod("xmlValue")
}

xmlValue.XMLNode <- 
function(x)
{
 x$value
}

xmlValue.XMLTextNode <- 
function(x)
{
 x$value
}

xmlValue.XMLCDataNode <- 
function(x)
{
 x$value
}

xmlValue.XMLProcessingInstruction <- 
function(x)
{
 x$value
}


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


xmlNamespace.XMLNode <-
function(x)
{
 x$namespace
}
"[<-.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
}

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")
}
parseDTD <- 
function(extId, asText=F, name="", isURL=F)
{
  if(missing(isURL)) {
    isURL <- length(grep("http://",extId)) | length(grep("ftp://",extId))
  }

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

supportsLibxml <-
function()
{
  TRUE
}

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=xmlHandler(), ignoreBlanks=F, addContext = T, useTagName = T,
           asText = F, trim=T, restartCounter=-1, useExpat = F, isURL=F) 
{
# restart(T)
# restartCounter <- restartCounter + 1

# if(restartCounter >= 0) {
#   return(handlers)
# }

  if(missing(isURL)) { 
        # check if this is a URL or regular file.
    isURL <- length(grep("http://",file)) | length(grep("ftp://",file))
  }

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

 handlers <- .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))
 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))
}
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="../XML/Docs/test.xml", ignoreBlanks = T, handlers=NULL,
           replaceEntities=F, asText=F, trim=T, validate=F, getDTD=T, isURL=F, asTree = F)
{
  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 == F & isURL == F) {
  if(file.exists(file) == F)
     stop(paste("File", file, "does not exist "))
 }

 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))

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

 ans
}
.First.lib <-
function(libname, pkgname)
{
 library.dynam("XML", pkgname, libname)
}
#
#  Copyright (c) 1998, 1999 The Omega Project for Statistical Computing.
#       All rights reserved.#
