getForm =
#
# The ... here are for the arguments to the form, not the curl options.
#
#
function(uri, ..., .params = character(), .opts = list(), curl = getCurlHandle(),
.encoding = integer(), binary = NA, .checkParams = TRUE)
{
# should we merge params with ....
# for now just one or the other.
if(missing(.params)) {
.params = list(...)
}
if(length(.params) == 0)
warning("No inputs passed to form")
else if(missing(.opts) && .checkParams)
testCurlOptionsInFormParameters(.params)
# Convert the arguments into a URL string.
els = mapply(function(id, val) {
# turn name=c("a", "b") into
# name=a&name=b
paste(curlEscape(id), curlEscape(val), sep="=", collapse="&")
}, names(.params), .params)
args = paste(els, collapse = "&")
uri = paste(uri, args, sep = if(grepl("\\?", uri)) "&" else "?")
getURLContent(uri, .opts = .opts, .encoding = .encoding, binary = binary, curl = curl)
}
testCurlOptionsInFormParameters =
function(.params)
{
if(any( w <- names(.params) %in% listCurlOptions())) {
warning("Found possible curl options in form parameters: ", paste(names(.params)[w], collapse = ", "))
TRUE
} else
FALSE
}
PostStyles = c('HTTPPOST' = NA,
'POST' = as.integer(47))
matchPostStyle =
function(style)
{
if(is.na(style))
return(style)
# The style of the post, i.e. HTTPPOST or regular POST,
# i.e. www-form-encoded or
if(is.character(style)) {
i = pmatch(tolower(style), tolower(names(PostStyles)))
if(is.na(i))
stop("POST style is not recognized: must be one of ", paste(names(PostStyles), collapse = ", "))
as.integer(PostStyles[i])
} else {
if(!(style %in% PostStyles))
warning("Unrecognized style value ", style)
as.integer(style)
}
}
.postForm =
function(curl, .opts, .params, style = 'HTTPPOST')
{
.Call("R_post_form", curl, .opts, .params, TRUE, matchPostStyle(style), PACKAGE = "RCurl")
}
postForm =
#
# The ... here are for the arguments to the form, not the curl options.
#
#
function(uri, ...,
.params = list(), .opts = curlOptions(url = uri),
curl = getCurlHandle(), style = 'HTTPPOST',
.encoding = integer(), binary = NA, .checkParams = TRUE,
.contentEncodeFun = curlEscape) # Should probably be curlPercentEncode !
{
isProtected = missing(curl)
write = NULL
noCurlOptions = missing(.opts)
style = matchPostStyle(style)
# merge the two sources of inputs
.params = merge(list(...), .params)
# Need to organize the types here into a structure.
hasOwnWrite = any(c("writefunction", "headerfunction") %in% names(.opts))
buf = NULL
header = basicTextGatherer()
if(!hasOwnWrite) {
write = dynCurlReader(curl, verbose = FALSE, binary = binary, baseURL = uri, encoding = .encoding)
# Defer the setting of the writefunction until we need to set it
# When we finish with the header, we'll set the writefunction.
# .opts[["writefunction"]] = write$update
.opts[["headerfunction"]] = write$update
on.exit(cleanupDynReader(NULL, curl))
isProtected = rep(isProtected, length(.opts))
isProtected[length(isProtected)] = TRUE
# .opts[["writefunction"]] = write$update
}
# Force the curlOptions to be resolved at this point, but not set. So pass curl = NULL
optionNames = names(.opts)
.opts = curlSetOpt(url = uri, .opts = .opts, curl = NULL, .encoding = .encoding)
# curlOptions[["httpost"]] <- .params
# curlPerform(curl, .opts = curlOptions)
if(!is.na(style) && style == PostStyles['POST']) {
tmp = as.list(.params)
.params = paste(
unlist(mapply(function(id, val)
paste(id, if(is(val, "AsIs")) val else .contentEncodeFun(val), sep = "="),
names(tmp), tmp)),
collapse = "&")
} else
.params = lapply(.params,
function(x)
if(is.atomic(x))
as.character(x)
else
x)
if(length(.params) == 0) {
postfields = getCurlOptionsConstants()["postfields"]
if(!(postfields %in% .opts$ids))
warning("No inputs passed to form")
} else if(noCurlOptions && .checkParams)
testCurlOptionsInFormParameters(.params)
# status = .Call("R_post_form", curl, .opts, .params, TRUE, as.integer(style), PACKAGE = "RCurl")
status = .postForm(curl, .opts, .params, style)
if(any(!isProtected)) {
# Reset the httppost field to NULL so we can release the values.
# curlSetOpt(httppost = FALSE, curl = curl)
curlSetOpt(httpget = TRUE, curl = curl)
}
if(!is.null(write)) {
http.header = parseHTTPHeader(write$header())
stop.if.HTTP.error(http.header, write$value())
}
if(!is.null(buf)) {
processContent( as(buf, "raw"), header, .encoding)
} else if(!is.null(write))
write$value()
#XXX what if write is NULL - what do we return?
}
cleanupDynReader =
function(fun, curl)
{
curlSetOpt(writefunction = NULL, curl = curl)
if(!is.null(fun))
.Call("R_global_releaseObject", fun)
TRUE
}
fileUpload =
function(filename = character(), contents = character(), contentType = character())
{
if(length(contents) == 0 && !file.exists(filename))
stop("specified file does not exist: ", filename, ". You must specify a valid file name or provide the contents to send.")
filename = path.expand(filename)
if(!typeof(contents) == "raw")
contents = as.character(contents)
structure(list(filename = as.character(filename),
contents = contents,
contentType = as.character(contentType)),
class = "FileUploadInfo")
}
buildPostForm =
#
#
#
function(args, curl, set = TRUE)
{
args = as(args, "list")
.Call("R_buildForm", args, curl, as.logical(set))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.