R/context.R

In omegahat/Sxslt: R interface to libxslt

xsltInsert =
function(ctx, ..., .nodes = list(...))
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltInsert can only be used with an active XSL XPath context")  

  lapply(.nodes,
         function(i)
            .Call("RXSLT_insert", ctx, i))
}  

xsltGetInsertNode =
function(ctx)
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltGetInsertNode can only be used with an active XSL XPath context")
  
  .Call("RXSLT_getInsertNode", ctx)
}

xsltGetXMLSourceNode =
function(context)
{
  .Call("RXSLT_getCurrentSourceNode", context)
}  


xsltGetXSLNode =
function(context, template = FALSE)  
{
  node = .Call("RXSLT_getCurrentTemplateNode", context)
  if(template) {
    p = node
    while(!is.null(p) && xmlName(p) != "template")
      p = xmlParent(p)
  }
  node
}

xsltProcessNode =
function(ctx, node)
{
  if(.Platform$OS.type == "windows")
    stop("the underlying C routine used in the xsltProcessNode function is unfortunately not accessible on Windows")
  
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltProcessNode can only be used with an active XSL XPath context") 

  if(!inherits(node, "XMLInternalNode")) {
    if(inherits(node, "XPathNodeSet"))
      stop("You probably wanted to call xsltProcessNode with the first element")
    stop("xsltProcessNode must be given an XMLInternalNode")
  }

  .Call("RXSLT_processOneNode", ctx, node)  
}

setOldClass("XMLXPathParserContext")

xsltGetStyleSheet =
  # Get the XSLStyleSheet, no longer the XML document that is the XSL style sheet!
function(ctx)
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltGetStylesheet can only be used with an active XSL XPath context")   

  sty = .Call("RXSLT_getStylesheetPtr", ctx)
#  if(!is.null(sty))
    new("XSLStyleSheet", ref = sty)
#  else
#    NULL
}


makeTemplate =
  #
  # fixes up the object returned from C that gives us the raw information from the template.
  #
function(ans)
{
  if(is.null(ans))
    return(ans)
  
  if(is(ans[[1]], "externalptr"))
     ans[[1]] = new("XSLStyleSheet", ref = ans[[1]])
  names(ans) = c("stylesheet", "match", "name", "node", "priority", "mode")

  class(ans) = "XSLTemplateDescription"
  ans
}  


xsltGetCurrentTemplate =
function(ctx)
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltGetStylesheet can only be used with an active XSL XPath context")

  makeTemplate(.Call("RXSLT_getCurrentTemplate", ctx))
}

xsltGetCurrentInputNode =
function(ctx)
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltGetStylesheet can only be used with an active XSL XPath context")

  .Call("RXSLT_getCurrentInputNode", ctx)
}  


# Get the style sheet pointer from the context
setAs("XMLXPathParserContext", "XSLStyleSheet",
      function(from) {
           xsltGetStyleSheet(from)
      })

# get the xmlDocPtr for the XSL file that corresponds to the style sheet
setAs("XMLXPathParserContext", "XMLInternalDocument",
      function(from) {
         .Call("RXSLT_getStylesheetDocument", from)
       })

# Get the xmlDocPtr from the style sheet that corresponds to the top-level XSL file
setAs("XSLStyleSheet", "XMLInternalDocument",
        function(from)
          .Call("RXSLT_getStyleSheetXMLDocument", from@ref))

xsltGetOutputDocument  =
  # Get the xmlDocPtr corresponding to the document being generated by this XSL transformation.
function(ctx)
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltGetOutputDocument can only be used with an active XSL XPath context")
  
  .Call("RXSLT_getOutputDocument", ctx)
}

xsltGetInputDocument =
  # Get the xmlDocPtr corresponding to the input document being transformed by this XSL transformation.  
  #
function(ctx)
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltGetDOM can only be used with an active XSL XPath context")   

  .Call("RXSLT_getXMLDocument", ctx)                                                
}  


getNamedTemplate =
function(ctx, template,  sh = xsltGetStyleSheet(ctx))
{
    if(length(grep("^/", template)) == 0)
      template = paste("//xsl:template[@name='", template, "']", sep = "")    
    temp = getNodeSet(sh, template, c(xsl="http://www.w3.org/1999/XSL/Transform"))

    if(length(temp) > 0)
      template = temp
    else
      stop("Cannot find template named ", template, " in stylesheet")    

    temp[[1]]  # get the first element of the node set.
}

xsltCallTemplate =
function(ctx, node, template, ..., .params = list(...))
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltGetDOM can only be used with an active XSL XPath context")

  if(is.character(template)) 
     template = getNamedTemplate(ctx, template)


  if(length(names(.params)) != length(.params) || any(names(.params) == ""))
      stop("All parameters must be named")

  .Call("RXSLT_callTemplate", ctx, node, template, .params)
}  


xsltCopyNodes =
  # make generic.
function(context, node)
{
    outDoc = xsltGetOutputDocument(context) 
    .Call("RS_XML_copyNodesToDoc", node, outDoc)
}  



createTransformContext =
function(style, doc = newXMLDoc())
{
  if(!is(style, "XSLStyleSheet"))
    stop("createTransformContext needs an XSLStyleSheet object")

  .Call("RXSLT_createTransformContext", style, doc)
}

setGeneric("getTemplate",
           function(ctxt, node, mode = character())
              standardGeneric("getTemplate"))

setOldClass("XSLTTransformContext")
setOldClass(c("XSLCopiedTemplateDescription", "XSLTTransformContext"))

setAs("XSLTemplateDescription", "XSLCopiedTemplateDescription",
      function(from) {
            #!!! note that we take the name of the style sheet, not the style sheet itself.
            # This will also be the local file name.
        from$stylesheet = docName(from$stylesheet)
        from$location = structure(getLineNumber(from$node), names = docName(from$node))
        from$node = saveXML(from$node)
        class(from) = "XSLCopiedTemplateDescription"
        from
      })


setAs("XSLTTransformContext", "XSLStyleSheet",
      function(from)
        .Call("RXSLT_getTransformContextStyle", from))

setMethod("getTemplate", c("XSLTTransformContext", "XMLInternalNode"),
          function(ctxt, node, mode = character())     {
            ans = .Call("RSXSLT_getTemplate", ctxt, node, as.character(mode))
            if(is.null(ans)) {
              warning("couldn't find template for ", xmlName(node), " in ", docName(as(ctxt, "XSLStyleSheet")))
              return(NULL)
            }
            makeTemplate(ans)
          })


setMethod("getTemplate", c("XSLTTransformContext", "missing"),
          function(ctxt, node, mode = character())     {
              xsltGetCurrentTemplate(ctxt)
          })


setMethod("getTemplate", c("XSLStyleSheet", "character"),
          function(ctxt, node, mode = character())     {
              getTemplate(ctxt, newXMLNode(node), mode)
          })


setMethod("getTemplate", c("XSLStyleSheet", "XMLInternalNode"),
          function(ctxt, node, mode = character())     {
             doc = as(node, "XMLInternalDocument")
             if(is.null(doc)) {
                 # XXX do we need to make a copy of the node?
                 # xmlDoc() does but newXMLDoc doesn't in the case that node has no doc value.
                 # Also need to make certain this new doc is not gc'ed while we are using it.
                doc = xmlDoc(node)   #  newXMLDoc(node = node)
                  # need to get the newly copied node which is different from node.
                node = xmlRoot(doc)
            }

             
                # The transform context will be gc()'ed. Will the template go away too?
             getTemplate(createTransformContext(ctxt, doc), node, mode)
          })          



setMethod("getTemplate", c("character", "character"),
          function(ctxt, node, mode = character())     {
             sty = xsltParseStyleSheet(ctxt)
                # The transform context will be gc()'ed. Will the template go away too?
                # That's why we bring the details into R. But the template node and stylesheet reference
                # are dangerous.
                #  Maybe we need to copy them out here into strings.
             ans = getTemplate(sty, node, mode)
             if(!is.null(ans))
                as(ans, "XSLCopiedTemplateDescription")             
             else
                ans
          })


setMethod("getTemplate", c("character", "XMLInternalNode"),
          function(ctxt, node, mode = character())     {
            doc = as(node, "XMLInternalDocument")
            if(is.null(doc)) {
                 # XXX do we need to make a copy of the node?
                 # xmlDoc() does but newXMLDoc doesn't in the case that node has no doc value.
                 # Also need to make certain this new doc is not gc'ed while we are using it.
                doc = xmlDoc(node)   #  newXMLDoc(node = node)
                  # need to get the newly copied node which is different from node.
                node = xmlRoot(doc)
            }

            sty = xsltParseStyleSheet(ctxt)
            ans = getTemplate(sty, node, mode)
            
            if(is.null(ans))
              NULL
            else
              as(ans, "XSLCopiedTemplateDescription")

          })






setMethod("docName", "XSLStyleSheet",
          function(doc, ...) {
            docName(as(doc, "XMLInternalDocument"))
          })


setMethod("docName", "XSLTemplateDescription",
          function(doc, ...) {
            docName(doc$stylesheet)
          })

setMethod("docName", "XSLCopiedTemplateDescription",
          function(doc, ...) {
            doc$stylesheet
          })




xslGlobalVariableNames = xslGlobalParameterNames =
function(ctx)
{
  if(!inherits(ctx, "XMLXPathParserContext"))
    stop("xsltGetInsertNode can only be used with an active XSL XPath context")

  .Call("R_xslGetGlobalVariableNames", ctx)
}