static const char *R_PromptString(int browselevel, int type)
{
if (R_Slave) {
BrowsePrompt[0] = '\0';
return BrowsePrompt;
}
else {
if(type == 1) {
if(browselevel) {
snprintf(BrowsePrompt, 20, "Browse[%d]> ", browselevel);
return BrowsePrompt;
}
return CHAR(STRING_ELT(GetOption1(install("prompt")), 0));
}
else {
return CHAR(STRING_ELT(GetOption1(install("continue")), 0));
}
}
}
Rboolean Rf_GetOptionDeviceAsk(void)
{
int ask;
ask = asLogical(GetOption1(install("device.ask.default")));
if(ask == NA_LOGICAL) {
warning(_("invalid value for \"device.ask.default\", using FALSE"));
return FALSE;
}
return ask != 0;
}
/* NB this is called by R.app even though it is in no public header, so
alter there if you alter this */
void PrintDefaults(void)
{
R_print.na_string = NA_STRING;
R_print.na_string_noquote = mkChar("<NA>");
R_print.na_width = (int) strlen(CHAR(R_print.na_string));
R_print.na_width_noquote = (int) strlen(CHAR(R_print.na_string_noquote));
R_print.quote = 1;
R_print.right = Rprt_adj_left;
R_print.digits = GetOptionDigits();
R_print.scipen = asInteger(GetOption1(install("scipen")));
if (R_print.scipen == NA_INTEGER) R_print.scipen = 0;
R_print.max = asInteger(GetOption1(install("max.print")));
if (R_print.max == NA_INTEGER || R_print.max < 0) R_print.max = 99999;
else if(R_print.max == INT_MAX) R_print.max--; // so we can add
R_print.gap = 1;
R_print.width = GetOptionWidth();
R_print.useSource = USESOURCE;
R_print.cutoff = GetOptionCutoff();
}
int GetOptionDigits(void)
{
int d;
d = asInteger(GetOption1(install("digits")));
if (d < R_MIN_DIGITS_OPT || d > R_MAX_DIGITS_OPT) {
warning(_("invalid printing digits, used 7"));
return 7;
}
return d;
}
int GetOptionWidth(void)
{
int w;
w = asInteger(GetOption1(install("width")));
if (w < R_MIN_WIDTH_OPT || w > R_MAX_WIDTH_OPT) {
warning(_("invalid printing width, used 80"));
return 80;
}
return w;
}
int GetOptionCutoff(void)
{
int w;
w = asInteger(GetOption1(install("deparse.cutoff")));
if (w == NA_INTEGER || w <= 0) {
warning(_("invalid 'deparse.cutoff', used 60"));
w = 60;
}
return w;
}
static void curlCommon(CURL *hnd, int redirect, int verify)
{
const char *capath = getenv("CURL_CA_BUNDLE");
if (verify) {
if (capath && capath[0])
curl_easy_setopt(hnd, CURLOPT_CAINFO, capath);
#ifdef Win32
else
curl_easy_setopt(hnd, CURLOPT_SSL_VERIFYPEER, 0L);
#endif
} else {
curl_easy_setopt(hnd, CURLOPT_SSL_VERIFYHOST, 0L);
curl_easy_setopt(hnd, CURLOPT_SSL_VERIFYPEER, 0L);
}
// for consistency, but all that does is look up an option.
SEXP sMakeUserAgent = install("makeUserAgent");
SEXP agentFun = PROTECT(lang2(sMakeUserAgent, ScalarLogical(0)));
SEXP utilsNS = PROTECT(R_FindNamespace(mkString("utils")));
SEXP sua = eval(agentFun, utilsNS);
UNPROTECT(1); /* utilsNS */
PROTECT(sua);
if(TYPEOF(sua) != NILSXP)
curl_easy_setopt(hnd, CURLOPT_USERAGENT, CHAR(STRING_ELT(sua, 0)));
UNPROTECT(2);
int timeout0 = asInteger(GetOption1(install("timeout")));
long timeout = timeout0 = NA_INTEGER ? 0 : 1000L * timeout0;
curl_easy_setopt(hnd, CURLOPT_CONNECTTIMEOUT_MS, timeout);
curl_easy_setopt(hnd, CURLOPT_TIMEOUT_MS, timeout);
if (redirect) {
curl_easy_setopt(hnd, CURLOPT_FOLLOWLOCATION, 1L);
curl_easy_setopt(hnd, CURLOPT_MAXREDIRS, 20L);
}
int verbosity = asInteger(GetOption1(install("internet.info")));
if (verbosity < 2) curl_easy_setopt(hnd, CURLOPT_VERBOSE, 1L);
// enable the cookie engine, keep cookies in memory
curl_easy_setopt(hnd, CURLOPT_COOKIEFILE, "");
}
static int
GuiReadConsole(const char *prompt, char *buf, int len, int addtohistory)
{
int res;
const char *NormalPrompt =
CHAR(STRING_ELT(GetOption1(install("prompt")), 0));
if(!R_is_running) {
R_is_running = 1;
Rconsolesetwidth(consolecols(RConsole));
}
ConsoleAcceptCmd = !strcmp(prompt, NormalPrompt);
res = consolereads(RConsole, prompt, buf, len, addtohistory);
ConsoleAcceptCmd = 0;
return !res;
}
pGEDevDesc GEcurrentDevice(void)
{
/* If there are no active devices
* check the options for a "default device".
* If there is one, start it up. */
if (NoDevices()) {
SEXP defdev = GetOption1(install("device"));
if (isString(defdev) && length(defdev) > 0) {
SEXP devName = install(CHAR(STRING_ELT(defdev, 0)));
/* Not clear where this should be evaluated, since
grDevices need not be in the search path.
So we look for it first on the global search path.
*/
defdev = findVar(devName, R_GlobalEnv);
if(defdev != R_UnboundValue) {
PROTECT(defdev = lang1(devName));
eval(defdev, R_GlobalEnv);
UNPROTECT(1);
} else {
/* Not globally visible:
try grDevices namespace if loaded.
The option is unlikely to be set if it is not loaded,
as the default setting is in grDevices:::.onLoad.
*/
SEXP ns = findVarInFrame(R_NamespaceRegistry,
install("grDevices"));
if(ns != R_UnboundValue &&
findVar(devName, ns) != R_UnboundValue) {
PROTECT(defdev = lang1(devName));
eval(defdev, ns);
UNPROTECT(1);
} else
error(_("no active or default device"));
}
} else if(TYPEOF(defdev) == CLOSXP) {
PROTECT(defdev = lang1(defdev));
eval(defdev, R_GlobalEnv);
UNPROTECT(1);
} else
error(_("no active or default device"));
}
return R_Devices[R_CurrentDevice];
}
HINSTANCE R_loadLibrary(const char *path, int asLocal, int now,
const char *search)
{
HINSTANCE tdlh;
unsigned int dllcw, rcw;
int useSearch = search && search[0];
rcw = _controlfp(0,0) & ~_MCW_IC; /* Infinity control is ignored */
_clearfp();
if(useSearch) setDLLSearchPath(search);
tdlh = LoadLibrary(path);
if(useSearch) setDLLSearchPath(NULL);
dllcw = _controlfp(0,0) & ~_MCW_IC;
if (dllcw != rcw) {
_controlfp(rcw, _MCW_EM | _MCW_IC | _MCW_RC | _MCW_PC);
if (LOGICAL(GetOption1(install("warn.FPU")))[0])
warning(_("DLL attempted to change FPU control word from %x to %x"),
rcw,dllcw);
}
return(tdlh);
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
/* These are defaulst that we always want to set */
void set_handle_defaults(reference *ref){
/* the actual curl handle */
CURL *handle = ref->handle;
assert(curl_easy_setopt(handle, CURLOPT_PRIVATE, ref));
/* set the response header collector */
reset_resheaders(ref);
curl_easy_setopt(handle, CURLOPT_HEADERFUNCTION, append_buffer);
curl_easy_setopt(handle, CURLOPT_HEADERDATA, &(ref->resheaders));
#ifdef _WIN32
if(CA_BUNDLE != NULL && strlen(CA_BUNDLE)){
/* on windows a cert bundle is included with R version 3.2.0 */
curl_easy_setopt(handle, CURLOPT_CAINFO, CA_BUNDLE);
} else {
/* disable cert validation for older versions of R */
curl_easy_setopt(handle, CURLOPT_SSL_VERIFYHOST, 0L);
curl_easy_setopt(handle, CURLOPT_SSL_VERIFYPEER, 0L);
}
#endif
/* needed to support compressed responses */
assert(curl_easy_setopt(handle, CURLOPT_ENCODING, "gzip, deflate"));
/* follow redirect */
assert(curl_easy_setopt(handle, CURLOPT_FOLLOWLOCATION, 1L));
assert(curl_easy_setopt(handle, CURLOPT_MAXREDIRS, 10L));
/* a sensible timeout (10s) */
assert(curl_easy_setopt(handle, CURLOPT_CONNECTTIMEOUT, 10L));
/* needed to start the cookie engine */
assert(curl_easy_setopt(handle, CURLOPT_COOKIEFILE, ""));
assert(curl_easy_setopt(handle, CURLOPT_FILETIME, 1L));
/* set the default user agent */
SEXP agent = GetOption1(install("HTTPUserAgent"));
if(isString(agent) && Rf_length(agent)){
assert(curl_easy_setopt(handle, CURLOPT_USERAGENT, CHAR(STRING_ELT(agent, 0))));
} else {
assert(curl_easy_setopt(handle, CURLOPT_USERAGENT, "r/curl/jeroen"));
}
/* allow all authentication methods */
assert(curl_easy_setopt(handle, CURLOPT_HTTPAUTH, CURLAUTH_ANY));
assert(curl_easy_setopt(handle, CURLOPT_UNRESTRICTED_AUTH, 1L));
assert(curl_easy_setopt(handle, CURLOPT_PROXYAUTH, CURLAUTH_ANY));
/* enables HTTP2 on HTTPS (match behavior of curl cmd util) */
#if defined(CURL_VERSION_HTTP2) && defined(HAS_HTTP_VERSION_2TLS)
if(curl_version_info(CURLVERSION_NOW)->features & CURL_VERSION_HTTP2)
assert(curl_easy_setopt(handle, CURLOPT_HTTP_VERSION, CURL_HTTP_VERSION_2TLS));
#endif
/* set an error buffer */
assert(curl_easy_setopt(handle, CURLOPT_ERRORBUFFER, ref->errbuf));
/* dummy readfunction because default can freeze R */
assert(curl_easy_setopt(handle, CURLOPT_READFUNCTION, dummy_read));
/* seems to be needed for native WinSSL */
#ifdef _WIN32
curl_easy_setopt(handle, CURLOPT_SSL_OPTIONS, CURLSSLOPT_NO_REVOKE);
#endif
/* set default headers (disables the Expect: http 100)*/
#ifdef HAS_CURLOPT_EXPECT_100_TIMEOUT_MS
assert(curl_easy_setopt(handle, CURLOPT_EXPECT_100_TIMEOUT_MS, 0L));
#endif
assert(curl_easy_setopt(handle, CURLOPT_HTTPHEADER, default_headers));
/* set default progress printer (disabled by default) */
#ifdef HAS_XFERINFOFUNCTION
assert(curl_easy_setopt(handle, CURLOPT_XFERINFOFUNCTION, xferinfo_callback));
#else
assert(curl_easy_setopt(handle, CURLOPT_PROGRESSFUNCTION, xferinfo_callback));
#endif
}
SEXP GetOption(SEXP tag, SEXP rho) {
return GetOption1(tag);
}
