The R Project SVN R-packages

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