Nothing
##
## XMLRPC-related functions
##
XMLRPCServer <- function(url, curl = NULL,
class = if(!is.null(curl))
"XMLRPCServerConnection"
else
"XMLRPCServer",
...,
.opts = list(...))
{
if(is.null(curl) && length(.opts) ||
(is.logical(curl) && curl))
curl = getCurlHandle(.opts = .opts)
ans = new(class, url)
if(!is.null(curl))
ans@curl = curl
ans
}
setMethod("$", "XMLRPCServer",
function(x, name) {
function(...)
xml.rpc(as(x, "character"), name, ...)
})
setMethod("$", "XMLRPCServerConnection",
function(x, name) {
function(...)
xml.rpc(as(x, "character"), name, ..., .curl = x@curl)
})
xml.rpc <- function(url, method, ..., .args = list(...),
.opts = list(),
.defaultOpts = list(httpheader = c('Content-Type' = "text/xml"), followlocation = TRUE, useragent = useragent),
.convert = TRUE, .curl = getCurlHandle(), useragent = "R-XMLRPC"){
# Turn the method and arguments to an RPC body.
body = createBody(method, .args)
# merge the .defaultOpts and the .opts into one list.
.defaultOpts[["postfields"]] = saveXML(body)
if(length(.opts))
.defaultOpts[names(.opts)] = .opts
rdr = dynCurlReader(.curl, baseURL = url)
.defaultOpts[["headerfunction"]] = rdr$update
ans = postForm(url, .opts = .defaultOpts, style = "POST", curl = .curl)
hdr = parseHTTPHeader(rdr$header())
if(as.integer(hdr[["status"]]) %/% 100 != 2) {
# call an RCurl error generator function.
stop("Problems")
}
ans = rdr$value()
# Now either convert using the default converter fnction (convertToR)
# or return as is or allow the caller to specify a function to use for conversion.
if(is.logical(.convert)) {
if(.convert)
convertToR(ans)
else
ans
} else if(is.function(.convert))
.convert(ans)
else
ans
}
createBody <- function(method, args){
top = newXMLNode("methodCall", newXMLNode("methodName", method))
params = newXMLNode("params", parent = top)
sapply(args, function(x) newXMLNode("param", rpc.serialize(x),
parent = params))
top
}
setGeneric("rpc.serialize", function(x, ...) standardGeneric("rpc.serialize"))
setMethod("rpc.serialize", "ANY",
function(x, ...) {
if(isS4(x))
return(rpc.serialize.S4Object(x, ...))
stop("Not sure how to convert this type of object to XMLRPC format")
})
rpc.serialize.S4Object <- function(x, ...){
els = slotNames(x)
rpc.serialize(structure(lapply(els, function(id) slot(x, id)), names = els), ...)
}
basicTypeMap <-
c("integer" = "i4",
"double" = "double",
"character" = "string",
"logical" = "boolean",
"POSIXt" = "dateTime.iso8601",
"POSIXct" = "dateTime.iso8601",
"Date" = "dateTime.iso8601",
"raw" = "base64")
cast <- function(x) {
if (is.logical(x))
as.integer(x)
else
x
}
setOldClass("AsIs")
setMethod("rpc.serialize", "AsIs",
function(x) {
type = basicTypeMap[typeof(x)]
vectorArray(x, type)
})
setMethod("rpc.serialize", "NULL",
function(x, ...) {
rpc.serialize(list())
})
setMethod("rpc.serialize", "raw",
function(x, ...) {
val = base64Encode(x)
newXMLNode("value", newXMLNode("base64", val))
})
setMethod("rpc.serialize", "Date",
function(x, ...) {
val = format(x, "%Y%m%dT%H:%H:%S")
if(length(x) == 1)
newXMLNode("value", newXMLNode("dateTime.iso8601", val))
else
vectorArray(val, basicTypeMap["Date"])
})
setMethod("rpc.serialize", "POSIXt",
function(x, ...) {
val = format(as.POSIXct(x), "%Y%m%dT%H:%H:%S")
if(length(x) == 1)
newXMLNode("value", newXMLNode("dateTime.iso8601", val))
else
vectorArray(val, basicTypeMap["POSIXt"])
})
setMethod("rpc.serialize", "vector",
function(x, ...) {
type <- basicTypeMap[typeof(x)]
x <- cast(x)
if(length(names(x))) {
warning("Skipping names on vector!")
names(x) = NULL
}
if(length(x) == 1){
newXMLNode("value", newXMLNode(type, if(type == "string")
newXMLCDataNode(x)
else x))
} else {
vectorArray(x, type)
}
})
FormatStrings <- c(numeric = "%f", int = "%d", integer = "%d", logical = "%s",
i4 = "%d", double = "%f",
string = "%s", Date = "%s", POSIXt = "%s", POSIXct = "%s")
vectorArray <- function(x, type){
top <- newXMLNode("value")
a <- newXMLNode("array", parent = top)
data <- newXMLNode("data", parent = a)
tmpl <- if(type == "string") ## is.character(x))
sprintf("<value><%s><![CDATA[%%s]]></%s></value>", type, type)
else if(type == "dateTime.iso8601") {
if(is(x, "Date"))
x = format(x, "%Y%m%dT00:00:00")
else
x = format(as.POSIXct(x), "%Y%m%dT%H:%H:%S")
sprintf("<value><%s>%%s</%s></value>", type, type)
} else {
if(type == "double") {
x = as.character(x)
pct = "%s"
} else
pct = FormatStrings[type]
if(is.na(pct)) pct = "%s"
sprintf("<value><%s>%s</%s></value>", type, pct, type)
}
txt <- sprintf(tmpl, x)
parseXMLAndAdd(txt, data)
top
}
setMethod("rpc.serialize", "list",
function(x, ...) {
if(length(names(x))) {
a = newXMLNode("struct")
sapply(names(x), function(id) {
type = basicTypeMap[typeof(x[[id]])]
newXMLNode("member", newXMLNode("name", id),
rpc.serialize(x[[id]]
),
parent = a)
})
a
} else {
a = newXMLNode("array")
data = newXMLNode("data", parent = a)
sapply(x, function(x) {
elName = basicTypeMap[typeof(x)]
newXMLNode("value", newXMLNode(elName, if(elName == "string") newXMLCDataNode(x) else x,
parent = data))
})
a
}
})
setGeneric("convertToR", function(node) standardGeneric('convertToR'))
setMethod("convertToR", 'XMLInternalDocument', function(node)
{
fault = getNodeSet(node,path="//methodResponse/fault/value/struct")
if (length(fault) > 0) {
fault = xmlRPCToR(fault[[1]])
e = simpleError(paste("faultCode: ", fault$faultCode, " faultString: ", fault$faultString))
class(e) = c("XMLRPCError", class(e))
stop(e)
}
a = xpathApply(node, "//param/value", xmlRPCToR)
if(length(a) == 1)
a[[1]]
else
a
})
setMethod("convertToR", "XMLInternalNode",
function(node)
{
if(length(getNodeSet(node, "./param/value"))) {
ans = xpathApply(node, "./param/value", xmlRPCToR, simplify = FALSE)
} else
xmlToList(node)
})
setMethod("convertToR", "character",
function(node)
{
convertToR(xmlParse(node, asText = TRUE))
})
xmlRPCToR <- function(node, ...){
if(is.null(node))
return(NULL)
if(xmlName(node) == "value")
node = node[[1]]
if(is(node, "XMLInternalTextNode"))
return(xmlValue(node))
type = xmlName(node)
switch(type,
'array' = xmlRPCToR.array(node, ...),
'struct' = xmlRPCToR.struct(node, ...),
'i4' = as.integer(xmlValue(node)),
'int' = as.integer(xmlValue(node)),
'boolean' = if(xmlValue(node) == "1") TRUE else FALSE,
'double' = as.numeric(xmlValue(node)),
'string' = xmlValue(node),
'dateTime.iso8601' = as.POSIXct(strptime(xmlValue(node), "%Y%m%dT%H:%M:%S")),
'base64' = base64(xmlValue(node), encode = FALSE),
xmlValue(node)
)
}
xmlRPCToR.struct <- function(node, ...){
ans <- xmlApply(node, function(x) xmlRPCToR(x[["value"]][[1]], ...))
names(ans) <- xmlSApply(node, function(x) xmlValue(x[["name"]]))
ans
}
xmlRPCToR.array <- function(node, ...){
ans = xmlApply(node[["data"]], function(x) xmlRPCToR(x[[1]]))
if(!is.list(ans[[1]]) && all(sapply(ans, typeof) == typeof(ans[[1]])))
structure(unlist(ans), names = NULL)
else
ans
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.