int attribute_hidden
Rstd_ShowFiles(int nfile, /* number of files */
const char **file, /* array of filenames */
const char **headers, /* the `headers' args of file.show.
Printed before each file. */
const char *wtitle, /* title for window
= `title' arg of file.show */
Rboolean del, /* should files be deleted after use? */
const char *pager) /* pager to be used */
{
/*
This function can be used to display the named files with the
given titles and overall title. On GUI platforms we could
use a read-only window to display the result. Here we just
make up a temporary file and invoke a pager on it.
*/
int c, i, res;
char *filename;
FILE *fp, *tfp;
char buf[1024];
if (nfile > 0) {
if (pager == NULL || strlen(pager) == 0) pager = "more";
filename = R_tmpnam(NULL, R_TempDir); /* mallocs result */
if ((tfp = R_fopen(filename, "w")) != NULL) {
for(i = 0; i < nfile; i++) {
if (headers[i] && *headers[i])
fprintf(tfp, "%s\n\n", headers[i]);
errno = 0; /* some systems require this */
/* File expansion is now done in file.show(), but
left here in case other callers assumed it */
if ((fp = R_fopen(R_ExpandFileName(file[i]), "r"))
!= NULL) {
while ((c = fgetc(fp)) != EOF)
fputc(c, tfp);
fprintf(tfp, "\n");
fclose(fp);
if(del)
unlink(R_ExpandFileName(file[i]));
}
else
fprintf(tfp, _("Cannot open file '%s': %s\n\n"),
file[i], strerror(errno));
}
fclose(tfp);
}
snprintf(buf, 1024, "'%s' < '%s'", pager, filename); //might contain spaces
res = R_system(buf);
unlink(filename);
free(filename);
return (res != 0);
}
return 1;
}
static int process_Renviron(const char *filename)
{
FILE *fp;
char *s, *p, sm[BUF_SIZE], *lhs, *rhs, msg[MSG_SIZE+50];
int errs = 0;
if (!filename || !(fp = R_fopen(filename, "r"))) return 0;
snprintf(msg, MSG_SIZE+50,
"\n File %s contains invalid line(s)", filename);
while(fgets(sm, BUF_SIZE, fp)) {
sm[BUF_SIZE-1] = '\0';
s = rmspace(sm);
if(strlen(s) == 0 || s[0] == '#') continue;
if(!(p = Rf_strchr(s, '='))) {
errs++;
if(strlen(msg) < MSG_SIZE) {
strcat(msg, "\n "); strcat(msg, s);
}
continue;
}
*p = '\0';
lhs = rmspace(s);
rhs = findterm(rmspace(p+1));
/* set lhs = rhs */
if(strlen(lhs) && strlen(rhs)) Putenv(lhs, rhs);
}
fclose(fp);
if (errs) {
strcat(msg, "\n They were ignored\n");
R_ShowMessage(msg);
}
return 1;
}
static void editor_save_file(editor c, const char *name, int enc)
{
textbox t = getdata(c);
FILE *f;
char buf[MAX_PATH+30];
const char *sname;
if (name == NULL)
return;
else {
if(enc == CE_UTF8) {
wchar_t wname[MAX_PATH+1];
Rf_utf8towcs(wname, name, MAX_PATH+1);
sname = reEnc(name, CE_UTF8, CE_NATIVE, 3);
f = R_wfopen(wname, L"w");
} else {
sname = name;
f = R_fopen(sname, "w");
}
if (f == NULL) {
snprintf(buf, MAX_PATH+30, G_("Could not save file '%s'"), sname);
askok(buf);
return;
}
fprintf(f, "%s", gettext(t));
fclose(f);
}
}
int optopenfile(const char *fname)
{
optclosefile();
if (!fname || !(ff = R_fopen(fname,"r"))) return 0;
strcpy(optfl,fname);
optln = 0;
return 1;
}
FILE *R_OpenInitFile(void)
{
char buf[256], *home;
FILE *fp;
fp = NULL;
if (LoadInitFile) {
if ((fp = R_fopen(".Rprofile", "r")))
return fp;
if ((home = getenv("HOME")) == NULL)
return NULL;
sprintf(buf, "%s/.Rprofile", home);
if ((fp = R_fopen(buf, "r")))
return fp;
}
return fp;
}
attribute_hidden
FILE *R_OpenSysInitFile(void)
{
char buf[PATH_MAX];
FILE *fp;
snprintf(buf, PATH_MAX, "%s/library/base/R/Rprofile", R_Home);
fp = R_fopen(buf, "r");
return fp;
}
attribute_hidden
FILE *R_OpenLibraryFile(const char *file)
{
char buf[PATH_MAX];
FILE *fp;
snprintf(buf, PATH_MAX, "%s/library/base/R/%s", R_Home, file);
fp = R_fopen(buf, "r");
return fp;
}
FILE *R_OpenInitFile(void)
{
char buf[PATH_MAX], *p = getenv("R_PROFILE_USER");
FILE *fp;
fp = NULL;
if (LoadInitFile) {
if(p) {
if(!*p) return NULL; /* set to "" */
return R_fopen(R_ExpandFileName(p), "r");
}
if ((fp = R_fopen(".Rprofile", "r")))
return fp;
snprintf(buf, PATH_MAX, "%s/.Rprofile", getenv("R_USER"));
if ((fp = R_fopen(buf, "r")))
return fp;
}
return fp;
}
int R_ShowFiles(int nfile, const char **file, const char **headers,
const char *wtitle, Rboolean del, const char *pager)
{
int i;
char buf[1024];
if (nfile > 0) {
if (pager == NULL || strlen(pager) == 0)
pager = "internal";
for (i = 0; i < nfile; i++) {
if(!access(file[i], R_OK)) {
if (!strcmp(pager, "internal")) {
newpager(wtitle, file[i], CE_NATIVE, headers[i], del);
} else if (!strcmp(pager, "console")) {
size_t len;
FILE *f;
f = R_fopen(file[i], "rt");
if(f) {
while((len = fread(buf, 1, 1023, f))) {
buf[len] = '\0';
R_WriteConsole(buf, strlen(buf));
}
fclose(f);
if (del) DeleteFile(file[i]);
/* add a blank line */
R_WriteConsole("", 0);
}
else {
snprintf(buf, 1024,
_("cannot open file '%s': %s"),
file[i], strerror(errno));
warning(buf);
}
} else {
/* Quote path if necessary */
if(pager[0] != '"' && Rf_strchr(pager, ' '))
snprintf(buf, 1024, "\"%s\" \"%s\"", pager, file[i]);
else
snprintf(buf, 1024, "%s \"%s\"", pager, file[i]);
runcmd(buf, CE_NATIVE, 0, 1, NULL, NULL, NULL);
}
} else {
snprintf(buf, 1024,
_("file.show(): file '%s' does not exist\n"),
file[i]);
warning(buf);
}
}
return 0;
}
return 1;
}
attribute_hidden
FILE *R_OpenSiteFile(void)
{
char buf[PATH_MAX];
FILE *fp;
fp = nullptr;
if (LoadSiteFile) {
char *p = getenv("R_PROFILE");
if (p) {
if (*p) return R_fopen(R_ExpandFileName(p), "r");
else return nullptr;
}
#ifdef R_ARCH
snprintf(buf, PATH_MAX, "%s/etc/%s/Rprofile.site", R_Home, R_ARCH);
if ((fp = R_fopen(buf, "r"))) return fp;
#endif
snprintf(buf, PATH_MAX, "%s/etc/Rprofile.site", R_Home);
if ((fp = R_fopen(buf, "r"))) return fp;
}
return fp;
}
static void editor_load_file(editor c, const char *name, int enc)
{
textbox t = getdata(c);
EditorData p = getdata(t);
FILE *f;
char *buffer = NULL, tmp[MAX_PATH+50], tname[MAX_PATH+1];
const char *sname;
long num = 1, bufsize;
if(enc == CE_UTF8) {
wchar_t wname[MAX_PATH+1];
Rf_utf8towcs(wname, name, MAX_PATH+1);
f = R_wfopen(wname, L"r");
reEnc2(name, tname, MAX_PATH+1, CE_UTF8, CE_NATIVE, 3);
sname = tname;
} else {
f = R_fopen(name, "r");
sname = name;
}
if (f == NULL) {
snprintf(tmp, MAX_PATH+50,
G_("unable to open file %s for reading"), sname);
R_ShowMessage(tmp);
return;
}
p->file = 1;
strncpy(p->filename, name, MAX_PATH+1);
bufsize = 0;
while (num > 0) {
buffer = realloc(buffer, bufsize + 3000 + 1);
num = fread(buffer + bufsize, 1, 3000 - 1, f);
if (num >= 0) {
bufsize += num;
buffer[bufsize] = '\0';
}
else {
snprintf(tmp, MAX_PATH+50,
G_("Could not read from file '%s'"), sname);
askok(tmp);
}
}
setlimittext(t, 2 * strlen(buffer));
settext(t, buffer);
gsetmodified(t, 0);
free(buffer);
fclose(f);
}
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;
}
static void BM_NewPage(const pGEcontext gc, pDevDesc dd)
{
pX11Desc xd = (pX11Desc) dd->deviceSpecific;
char buf[PATH_MAX];
cairo_status_t res;
xd->npages++;
if (xd->type == PNG || xd->type == JPEG || xd->type == BMP) {
if (xd->npages > 1) {
/* try to preserve the page we do have */
BM_Close_bitmap(xd);
if (xd->fp) fclose(xd->fp);
}
snprintf(buf, PATH_MAX, xd->filename, xd->npages);
xd->fp = R_fopen(R_ExpandFileName(buf), "wb");
if (!xd->fp)
error(_("could not open file '%s'"), buf);
}
else if(xd->type == PNGdirect || xd->type == TIFF) {
if (xd->npages > 1) {
xd->npages--;
BM_Close_bitmap(xd);
xd->npages++;
}
}
#ifdef HAVE_CAIRO_SVG
else if(xd->type == SVG) {
if (xd->npages > 1 && xd->cs) {
cairo_show_page(xd->cc);
if(!xd->onefile) {
cairo_surface_destroy(xd->cs);
cairo_destroy(xd->cc);
}
}
if(xd->npages == 1 || !xd->onefile) {
snprintf(buf, PATH_MAX, xd->filename, xd->npages);
xd->cs = cairo_svg_surface_create(R_ExpandFileName(buf),
(double)xd->windowWidth,
(double)xd->windowHeight);
res = cairo_surface_status(xd->cs);
if (res != CAIRO_STATUS_SUCCESS) {
xd->cs = NULL;
error("cairo error '%s'", cairo_status_to_string(res));
}
if(xd->onefile)
cairo_svg_surface_restrict_to_version(xd->cs, CAIRO_SVG_VERSION_1_2);
xd->cc = cairo_create(xd->cs);
res = cairo_status(xd->cc);
if (res != CAIRO_STATUS_SUCCESS) {
error("cairo error '%s'", cairo_status_to_string(res));
}
cairo_set_antialias(xd->cc, xd->antialias);
}
}
#endif
#ifdef HAVE_CAIRO_PDF
else if(xd->type == PDF) {
if (xd->npages > 1) {
cairo_show_page(xd->cc);
if(!xd->onefile) {
cairo_surface_destroy(xd->cs);
cairo_destroy(xd->cc);
}
}
if(xd->npages == 1 || !xd->onefile) {
snprintf(buf, PATH_MAX, xd->filename, xd->npages);
xd->cs = cairo_pdf_surface_create(R_ExpandFileName(buf),
(double)xd->windowWidth,
(double)xd->windowHeight);
res = cairo_surface_status(xd->cs);
if (res != CAIRO_STATUS_SUCCESS) {
error("cairo error '%s'", cairo_status_to_string(res));
}
xd->cc = cairo_create(xd->cs);
res = cairo_status(xd->cc);
if (res != CAIRO_STATUS_SUCCESS) {
error("cairo error '%s'", cairo_status_to_string(res));
}
cairo_set_antialias(xd->cc, xd->antialias);
}
}
#endif
#ifdef HAVE_CAIRO_PS
else if(xd->type == PS) {
if (xd->npages > 1 && !xd->onefile) {
cairo_show_page(xd->cc);
cairo_surface_destroy(xd->cs);
cairo_destroy(xd->cc);
}
if(xd->npages == 1 || !xd->onefile) {
snprintf(buf, PATH_MAX, xd->filename, xd->npages);
xd->cs = cairo_ps_surface_create(R_ExpandFileName(buf),
(double)xd->windowWidth,
(double)xd->windowHeight);
res = cairo_surface_status(xd->cs);
if (res != CAIRO_STATUS_SUCCESS) {
error("cairo error '%s'", cairo_status_to_string(res));
}
// We already require >= 1.2
#if CAIRO_VERSION_MAJOR > 2 || CAIRO_VERSION_MINOR >= 6
if(!xd->onefile)
cairo_ps_surface_set_eps(xd->cs, TRUE);
#endif
xd->cc = cairo_create(xd->cs);
res = cairo_status(xd->cc);
if (res != CAIRO_STATUS_SUCCESS) {
error("cairo error '%s'", cairo_status_to_string(res));
}
cairo_set_antialias(xd->cc, xd->antialias);
}
}
#endif
else
error(_("unimplemented cairo-based device"));
cairo_reset_clip(xd->cc);
if (xd->type == PNG || xd->type == TIFF|| xd->type == PNGdirect) {
/* First clear it */
cairo_set_operator (xd->cc, CAIRO_OPERATOR_CLEAR);
cairo_paint (xd->cc);
cairo_set_operator (xd->cc, CAIRO_OPERATOR_OVER);
xd->fill = gc->fill;
} else
xd->fill = R_OPAQUE(gc->fill) ? gc->fill: xd->canvas;
CairoColor(xd->fill, xd);
cairo_new_path(xd->cc);
cairo_paint(xd->cc);
}
int Rf_initialize_R(int ac, char **av)
{
int i, ioff = 1, j;
Rboolean useX11 = TRUE, useTk = FALSE;
char *p, msg[1024], cmdlines[10000], **avv;
structRstart rstart;
Rstart Rp = &rstart;
Rboolean force_interactive = FALSE;
#if defined(HAVE_SYS_RESOURCE_H) && defined(HAVE_GETRLIMIT)
{
struct rlimit rlim;
{
uintptr_t ii = dummy_ii();
/* 1 is downwards */
R_CStackDir = ((uintptr_t)&i > ii) ? 1 : -1;
}
if(getrlimit(RLIMIT_STACK, &rlim) == 0) {
unsigned long lim1, lim2;
lim1 = (unsigned long) rlim.rlim_cur;
lim2 = (unsigned long) rlim.rlim_max; /* Usually unlimited */
R_CStackLimit = lim1 < lim2 ? lim1 : lim2;
}
#if defined(HAVE_LIBC_STACK_END)
R_CStackStart = (uintptr_t) __libc_stack_end;
#elif defined(HAVE_KERN_USRSTACK)
{
/* Borrowed from mzscheme/gc/os_dep.c */
int nm[2] = {CTL_KERN, KERN_USRSTACK};
void * base;
size_t len = sizeof(void *);
(void) sysctl(nm, 2, &base, &len, NULL, 0);
R_CStackStart = (uintptr_t) base;
}
#else
if(R_running_as_main_program) {
/* This is not the main program, but unless embedded it is
near the top, 5540 bytes away when checked. */
R_CStackStart = (uintptr_t) &i + (6000 * R_CStackDir);
}
#endif
if(R_CStackStart == -1) R_CStackLimit = -1; /* never set */
/* printf("stack limit %ld, start %lx dir %d \n", R_CStackLimit,
R_CStackStart, R_CStackDir); */
}
#endif
ptr_R_Suicide = Rstd_Suicide;
ptr_R_ShowMessage = Rstd_ShowMessage;
ptr_R_ReadConsole = Rstd_ReadConsole;
ptr_R_WriteConsole = Rstd_WriteConsole;
ptr_R_ResetConsole = Rstd_ResetConsole;
ptr_R_FlushConsole = Rstd_FlushConsole;
ptr_R_ClearerrConsole = Rstd_ClearerrConsole;
ptr_R_Busy = Rstd_Busy;
ptr_R_CleanUp = Rstd_CleanUp;
ptr_R_ShowFiles = Rstd_ShowFiles;
ptr_R_ChooseFile = Rstd_ChooseFile;
ptr_R_loadhistory = Rstd_loadhistory;
ptr_R_savehistory = Rstd_savehistory;
ptr_R_addhistory = Rstd_addhistory;
ptr_R_EditFile = NULL; /* for future expansion */
R_timeout_handler = NULL;
R_timeout_val = 0;
R_GlobalContext = NULL; /* Make R_Suicide less messy... */
if((R_Home = R_HomeDir()) == NULL)
R_Suicide("R home directory is not defined");
BindDomain(R_Home);
process_system_Renviron();
R_setStartTime();
R_DefParams(Rp);
/* Store the command line arguments before they are processed
by the R option handler.
*/
R_set_command_line_arguments(ac, av);
cmdlines[0] = '\0';
/* first task is to select the GUI.
If run from the shell script, only Tk|tk|X11|x11 are allowed.
*/
for(i = 0, avv = av; i < ac; i++, avv++) {
if(!strncmp(*avv, "--gui", 5) || !strncmp(*avv, "-g", 2)) {
if(!strncmp(*avv, "--gui", 5) && strlen(*avv) >= 7)
p = &(*avv)[6];
else {
if(i+1 < ac) {
avv++; p = *avv; ioff++;
} else {
snprintf(msg, 1024,
_("WARNING: --gui or -g without value ignored"));
R_ShowMessage(msg);
p = "X11";
}
}
if(!strcmp(p, "none"))
useX11 = FALSE; // not allowed from R.sh
#ifdef HAVE_AQUA
else if(!strcmp(p, "aqua"))
useaqua = TRUE; // not allowed from R.sh but used by R.app
#endif
else if(!strcmp(p, "X11") || !strcmp(p, "x11"))
useX11 = TRUE;
else if(!strcmp(p, "Tk") || !strcmp(p, "tk"))
useTk = TRUE;
else {
#ifdef HAVE_X11
snprintf(msg, 1024,
_("WARNING: unknown gui '%s', using X11\n"), p);
#else
snprintf(msg, 1024,
_("WARNING: unknown gui '%s', using none\n"), p);
#endif
R_ShowMessage(msg);
}
/* now remove it/them */
for(j = i; j < ac - ioff; j++)
av[j] = av[j + ioff];
ac -= ioff;
break;
}
}
#ifdef HAVE_X11
if(useX11) R_GUIType = "X11";
#endif /* HAVE_X11 */
#ifdef HAVE_AQUA
if(useaqua) R_GUIType = "AQUA";
#endif
#ifdef HAVE_TCLTK
if(useTk) R_GUIType = "Tk";
#endif
R_common_command_line(&ac, av, Rp);
while (--ac) {
if (**++av == '-') {
if(!strcmp(*av, "--no-readline")) {
UsingReadline = FALSE;
} else if(!strcmp(*av, "-f")) {
ac--; av++;
Rp->R_Interactive = FALSE;
if(strcmp(*av, "-")) {
/* Undo the escaping done in the front end */
char path[PATH_MAX], *p = path, *q;
for(q = *av; *q; q++) {
if(*q == '~' && *(q+1) == '+' && *(q+2) == '~') {
q += 2;
*p++ = ' ';
} else *p++ = *q;
}
*p = '\0';
ifp = R_fopen(path, "r");
if(!ifp) {
snprintf(msg, 1024,
_("cannot open file '%s': %s"),
path, strerror(errno));
R_Suicide(msg);
}
}
} else if(!strncmp(*av, "--file=", 7)) {
Rp->R_Interactive = FALSE;
if(strcmp((*av)+7, "-")) {
/* Undo the escaping done in the front end */
char path[PATH_MAX], *p = path, *q;
for(q = (*av)+7; *q; q++) {
if(*q == '~' && *(q+1) == '+' && *(q+2) == '~') {
q += 2;
*p++ = ' ';
} else *p++ = *q;
}
*p = '\0';
ifp = R_fopen(path, "r");
if(!ifp) {
snprintf(msg, 1024,
_("cannot open file '%s': %s"),
path, strerror(errno));
R_Suicide(msg);
}
}
} else if(!strcmp(*av, "-e")) {
ac--; av++;
Rp->R_Interactive = FALSE;
if(strlen(cmdlines) + strlen(*av) + 2 <= 10000) {
char *p = cmdlines+strlen(cmdlines), *q;
/* Undo the escaping done in the front end */
for(q = *av; *q; q++) {
if(*q == '~' && *(q+1) == '+' && *(q+2) == '~') {
q += 2;
*p++ = ' ';
} else *p++ = *q;
}
*p++ = '\n'; *p = '\0';
} else {
snprintf(msg, 1024, _("WARNING: '-e %s' omitted as input is too long\n"), *av);
R_ShowMessage(msg);
}
} else if(!strcmp(*av, "--args")) {
break;
} else if(!strcmp(*av, "--interactive")) {
force_interactive = TRUE;
break;
} else {
#ifdef HAVE_AQUA
// r27492: in 2003 launching from 'Finder OSX' passed this
if(!strncmp(*av, "-psn", 4)) break; else
#endif
snprintf(msg, 1024, _("WARNING: unknown option '%s'\n"), *av);
R_ShowMessage(msg);
}
} else {
snprintf(msg, 1024, _("ARGUMENT '%s' __ignored__\n"), *av);
R_ShowMessage(msg);
}
}
if(strlen(cmdlines)) { /* had at least one -e option */
size_t res;
if(ifp) R_Suicide(_("cannot use -e with -f or --file"));
ifp = tmpfile();
if(!ifp) R_Suicide(_("creating temporary file for '-e' failed"));
res = fwrite(cmdlines, strlen(cmdlines)+1, 1, ifp);
if(res != 1) error("fwrite error in initialize_R");
fflush(ifp);
rewind(ifp);
}
if (ifp && Rp->SaveAction != SA_SAVE) Rp->SaveAction = SA_NOSAVE;
R_SetParams(Rp);
if(!Rp->NoRenviron) {
process_site_Renviron();
process_user_Renviron();
}
/* On Unix the console is a file; we just use stdio to write on it */
#ifdef HAVE_AQUA
if(useaqua)
R_Interactive = useaqua;
else
#endif
R_Interactive = R_Interactive && (force_interactive || isatty(0));
#ifdef HAVE_AQUA
/* for Aqua and non-dumb terminal use callbacks instead of connections
and pretty-print warnings/errors (ESS = dumb terminal) */
if(useaqua ||
(R_Interactive && getenv("TERM") && strcmp(getenv("TERM"), "dumb"))) {
R_Outputfile = NULL;
R_Consolefile = NULL;
ptr_R_WriteConsoleEx = Rstd_WriteConsoleEx;
ptr_R_WriteConsole = NULL;
} else {
#endif
R_Outputfile = stdout;
R_Consolefile = stderr;
#ifdef HAVE_AQUA
}
#endif
/*
* Since users' expectations for save/no-save will differ, we decided
* that they should be forced to specify in the non-interactive case.
*/
if (!R_Interactive && Rp->SaveAction != SA_SAVE &&
Rp->SaveAction != SA_NOSAVE)
R_Suicide(_("you must specify '--save', '--no-save' or '--vanilla'"));
R_setupHistory();
if (R_RestoreHistory)
Rstd_read_history(R_HistoryFile);
fpu_setup(1);
return(0);
}
void setup_Rmainloop(void)
{
volatile int doneit;
volatile SEXP baseEnv;
SEXP cmd;
char deferred_warnings[11][250];
volatile int ndeferred_warnings = 0;
/* In case this is a silly limit: 2^32 -3 has been seen and
* casting to intptr_r relies on this being smaller than 2^31 on a
* 32-bit platform. */
if(R_CStackLimit > 100000000U)
R_CStackLimit = (uintptr_t)-1;
/* make sure we have enough head room to handle errors */
if(R_CStackLimit != -1)
R_CStackLimit = (uintptr_t)(0.95 * R_CStackLimit);
InitConnections(); /* needed to get any output at all */
/* Initialize the interpreter's internal structures. */
#ifdef HAVE_LOCALE_H
#ifdef Win32
{
char *p, Rlocale[1000]; /* Windows' locales can be very long */
p = getenv("LC_ALL");
strncpy(Rlocale, p ? p : "", 1000);
Rlocale[1000 - 1] = '\0';
if(!(p = getenv("LC_CTYPE"))) p = Rlocale;
/* We'd like to use warning, but need to defer.
Also cannot translate. */
if(!setlocale(LC_CTYPE, p))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_CTYPE=%s failed\n", p);
if((p = getenv("LC_COLLATE"))) {
if(!setlocale(LC_COLLATE, p))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_COLLATE=%s failed\n", p);
} else setlocale(LC_COLLATE, Rlocale);
if((p = getenv("LC_TIME"))) {
if(!setlocale(LC_TIME, p))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_TIME=%s failed\n", p);
} else setlocale(LC_TIME, Rlocale);
if((p = getenv("LC_MONETARY"))) {
if(!setlocale(LC_MONETARY, p))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MONETARY=%s failed\n", p);
} else setlocale(LC_MONETARY, Rlocale);
/* Windows does not have LC_MESSAGES */
/* We set R_ARCH here: Unix does it in the shell front-end */
char Rarch[30];
strcpy(Rarch, "R_ARCH=/");
strcat(Rarch, R_ARCH);
putenv(Rarch);
}
#else /* not Win32 */
if(!setlocale(LC_CTYPE, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_CTYPE failed, using \"C\"\n");
if(!setlocale(LC_COLLATE, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_COLLATE failed, using \"C\"\n");
if(!setlocale(LC_TIME, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_TIME failed, using \"C\"\n");
#ifdef ENABLE_NLS
if(!setlocale(LC_MESSAGES, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MESSAGES failed, using \"C\"\n");
#endif
/* NB: we do not set LC_NUMERIC */
#ifdef LC_MONETARY
if(!setlocale(LC_MONETARY, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MONETARY failed, using \"C\"\n");
#endif
#ifdef LC_PAPER
if(!setlocale(LC_PAPER, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_PAPER failed, using \"C\"\n");
#endif
#ifdef LC_MEASUREMENT
if(!setlocale(LC_MEASUREMENT, ""))
snprintf(deferred_warnings[ndeferred_warnings++], 250,
"Setting LC_MEASUREMENT failed, using \"C\"\n");
#endif
#endif /* not Win32 */
#endif
/* make sure srand is called before R_tmpnam, PR#14381 */
srand(TimeToSeed());
InitArithmetic();
InitParser();
InitTempDir(); /* must be before InitEd */
InitMemory();
InitStringHash(); /* must be before InitNames */
InitNames();
InitBaseEnv();
InitGlobalEnv();
InitDynload();
InitOptions();
InitEd();
InitGraphics();
InitTypeTables(); /* must be before InitS3DefaultTypes */
InitS3DefaultTypes();
R_Is_Running = 1;
R_check_locale();
/* Initialize the global context for error handling. */
/* This provides a target for any non-local gotos */
/* which occur during error handling */
R_Toplevel.nextcontext = NULL;
R_Toplevel.callflag = CTXT_TOPLEVEL;
R_Toplevel.cstacktop = 0;
R_Toplevel.promargs = R_NilValue;
R_Toplevel.callfun = R_NilValue;
R_Toplevel.call = R_NilValue;
R_Toplevel.cloenv = R_BaseEnv;
R_Toplevel.sysparent = R_BaseEnv;
R_Toplevel.conexit = R_NilValue;
R_Toplevel.vmax = NULL;
R_Toplevel.nodestack = R_BCNodeStackTop;
#ifdef BC_INT_STACK
R_Toplevel.intstack = R_BCIntStackTop;
#endif
R_Toplevel.cend = NULL;
R_Toplevel.intsusp = FALSE;
R_Toplevel.handlerstack = R_HandlerStack;
R_Toplevel.restartstack = R_RestartStack;
R_Toplevel.srcref = R_NilValue;
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
R_ExitContext = NULL;
R_Warnings = R_NilValue;
/* This is the same as R_BaseEnv, but this marks the environment
of functions as the namespace and not the package. */
baseEnv = R_BaseNamespace;
/* Set up some global variables */
Init_R_Variables(baseEnv);
/* On initial entry we open the base language package and begin by
running the repl on it.
If there is an error we pass on to the repl.
Perhaps it makes more sense to quit gracefully?
*/
#ifdef RMIN_ONLY
/* This is intended to support a minimal build for experimentation. */
if (R_SignalHandlers) init_signal_handlers();
#else
FILE *fp = R_OpenLibraryFile("base");
if (fp == NULL)
R_Suicide(_("unable to open the base package\n"));
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (R_SignalHandlers) init_signal_handlers();
if (!doneit) {
doneit = 1;
R_ReplFile(fp, baseEnv);
}
fclose(fp);
#endif
/* This is where we source the system-wide, the site's and the
user's profile (in that order). If there is an error, we
drop through to further processing.
*/
R_IoBufferInit(&R_ConsoleIob);
R_LoadProfile(R_OpenSysInitFile(), baseEnv);
/* These are the same bindings, so only lock them once */
R_LockEnvironment(R_BaseNamespace, TRUE);
#ifdef NOTYET
/* methods package needs to trample here */
R_LockEnvironment(R_BaseEnv, TRUE);
#endif
/* At least temporarily unlock some bindings used in graphics */
R_unLockBinding(R_DeviceSymbol, R_BaseEnv);
R_unLockBinding(R_DevicesSymbol, R_BaseEnv);
R_unLockBinding(install(".Library.site"), R_BaseEnv);
/* require(methods) if it is in the default packages */
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
PROTECT(cmd = install(".OptRequireMethods"));
R_CurrentExpr = findVar(cmd, R_GlobalEnv);
if (R_CurrentExpr != R_UnboundValue &&
TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
}
if (strcmp(R_GUIType, "Tk") == 0) {
char buf[PATH_MAX];
snprintf(buf, PATH_MAX, "%s/library/tcltk/exec/Tk-frontend.R", R_Home);
R_LoadProfile(R_fopen(buf, "r"), R_GlobalEnv);
}
/* Print a platform and version dependent greeting and a pointer to
* the copyleft.
*/
if(!R_Quiet) PrintGreeting();
R_LoadProfile(R_OpenSiteFile(), baseEnv);
R_LockBinding(install(".Library.site"), R_BaseEnv);
R_LoadProfile(R_OpenInitFile(), R_GlobalEnv);
/* This is where we try to load a user's saved data.
The right thing to do here is very platform dependent.
E.g. under Unix we look in a special hidden file and on the Mac
we look in any documents which might have been double clicked on
or dropped on the application.
*/
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
R_InitialData();
}
else {
if (! SETJMP(R_Toplevel.cjmpbuf)) {
warning(_("unable to restore saved data in %s\n"), get_workspace_name());
}
}
/* Initial Loading is done.
At this point we try to invoke the .First Function.
If there is an error we continue. */
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
PROTECT(cmd = install(".First"));
R_CurrentExpr = findVar(cmd, R_GlobalEnv);
if (R_CurrentExpr != R_UnboundValue &&
TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
}
/* Try to invoke the .First.sys function, which loads the default packages.
If there is an error we continue. */
doneit = 0;
SETJMP(R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = R_SessionContext = &R_Toplevel;
if (!doneit) {
doneit = 1;
PROTECT(cmd = install(".First.sys"));
R_CurrentExpr = findVar(cmd, baseEnv);
if (R_CurrentExpr != R_UnboundValue &&
TYPEOF(R_CurrentExpr) == CLOSXP) {
PROTECT(R_CurrentExpr = lang1(cmd));
R_CurrentExpr = eval(R_CurrentExpr, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(1);
}
{
int i;
for(i = 0 ; i < ndeferred_warnings; i++)
warning(deferred_warnings[i]);
}
if (R_CollectWarnings) {
REprintf(_("During startup - "));
PrintWarnings();
}
/* trying to do this earlier seems to run into bootstrapping issues. */
R_init_jit_enabled();
R_Is_Running = 2;
}
static void save(button b)
{
char *file, buf[256], *p;
FILE *fp;
setuserfilter("All files (*.*)\0*.*\0\0");
strcpy(buf, getenv("R_USER"));
R_fixbackslash(buf);
file = askfilesavewithdir(G_("Select directory for file 'Rconsole'"),
"Rconsole", buf);
if(!file) return;
strcpy(buf, file);
p = buf + strlen(buf) - 2;
if(!strncmp(p, ".*", 2)) *p = '\0';
fp = R_fopen(buf, "w");
if(fp == NULL) {
MessageBox(0, "Cannot open file to fp",
"Configuration Save Error",
MB_TASKMODAL | MB_ICONSTOP | MB_OK);
return;
}
fprintf(fp, "%s\n%s\n%s\n\n%s\n%s\n",
"# Optional parameters for the console and the pager",
"# The system-wide copy is in rwxxxx/etc.",
"# A user copy can be installed in `R_USER'.",
"## Style",
"# This can be `yes' (for MDI) or `no' (for SDI).");
fprintf(fp, "MDI = %s\n", ischecked(rb_mdi)?"yes":"no");
fprintf(fp, "%s\n%s%s\n%s%s\n\n",
"# the next two are only relevant for MDI",
"toolbar = ", ischecked(toolbar)?"yes":"no",
"statusbar = ", ischecked(statusbar)?"yes":"no");
fprintf(fp, "%s\n%s\n%s\n%s\n%s\n",
"## Font.",
"# Please use only fixed width font.",
"# If font=FixedFont the system fixed font is used; in this case",
"# points and style are ignored. If font begins with \"TT \", only",
"# True Type fonts are searched for.");
fprintf(fp, "font = %s%s\npoints = %s\nstyle = %s # Style can be normal, bold, italic\n\n\n",
ischecked(tt_font)?"TT ":"",
gettext(f_font),
gettext(d_point),
gettext(f_style));
fprintf(fp, "# Dimensions (in characters) of the console.\n");
fprintf(fp, "rows = %s\ncolumns = %s\n",
gettext(f_crows), gettext(f_ccols));
fprintf(fp, "# Dimensions (in characters) of the internal pager.\n");
fprintf(fp, "pgrows = %s\npgcolumns = %s\n",
gettext(f_prows), gettext(f_pcols));
fprintf(fp, "# should options(width=) be set to the console width?\n");
fprintf(fp, "setwidthonresize = %s\n\n",
ischecked(c_resize) ? "yes" : "no");
fprintf(fp, "# memory limits for the console scrolling buffer, in chars and lines\n");
fprintf(fp, "bufbytes = %s\nbuflines = %s\n\n",
gettext(f_cbb), gettext(f_cbl));
fprintf(fp, "# Initial position of the console (pixels, relative to the workspace for MDI)\n");
fprintf(fp, "xconsole = %s\nyconsole = %s\n\n",
gettext(f_cx), gettext(f_cy));
fprintf(fp, "%s\n%s\n%s\n%s\n%s\n%s\n\n",
"# Dimension of MDI frame in pixels",
"# Format (w*h+xorg+yorg) or use -ve w and h for offsets from right bottom",
"# This will come up maximized if w==0",
"# MDIsize = 0*0+0+0",
"# MDIsize = 1000*800+100+0",
"# MDIsize = -50*-50+50+50 # 50 pixels space all round");
fprintf(fp, "%s\n%s\n%s\npagerstyle = %s\n\n\n",
"# The internal pager can displays help in a single window",
"# or in multiple windows (one for each topic)",
"# pagerstyle can be set to `singlewindow' or `multiplewindows'",
ischecked(rb_mwin) ? "multiplewindows" : "singlewindow");
fprintf(fp, "## Colours for console and pager(s)\n# (see rwxxxx/etc/rgb.txt for the known colours).\n");
for (int i=0; i<numGuiColors; i++)
fprintf(fp, "%s = %s\n", GuiElementNames[i], rgbtoname(dialogColors[i]));
fprintf(fp, "\n\n%s\n%s\nxgraphics = %s\nygraphics = %s\n",
"## Initial position of the graphics window",
"## (pixels, <0 values from opposite edge)",
gettext(f_grx), gettext(f_gry));
fprintf(fp, "\n\n%s\nlanguage = %s\n",
"## Language for messages",
gettext(f_lang));
fprintf(fp, "\n\n## Default setting for console buffering: 'yes' or 'no'\n");
fprintf(fp, "buffered = %s\n",
ischecked(c_buff) ? "yes" : "no");
fprintf(fp, "\n\n%s\ncursor_blink = %s\n",
"## Console cursor blink",
BlinkList[getlistitem(f_blink)]);
fclose(fp);
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ti, ed, t;
char *filename, *editcmd, *vmaxsave, *cmd;
FILE *fp;
#ifdef Win32
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) {
filename = R_alloc(strlen(CHAR(STRING_ELT(fn, 0))), sizeof(char));
strcpy(filename, CHAR(STRING_ELT(fn, 0)));
}
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(t = getAttrib(x, R_SourceSymbol)))
t = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(t); i++)
fprintf(fp, "%s\n", CHAR(STRING_ELT(t, i)));
fclose(fp);
}
ti = CAR(args); args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = CHAR(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, 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, 1, 1, "");
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);
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
R_ParseCnt = 0;
x = PROTECT(R_ParseFile(fp, -1, &status));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("an error occurred on line %d\n use a command like\n x <- edit()\n to recover"), 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(VECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(2);
vmaxset(vmaxsave);
return (x);
}
