/* try user Renviron: ./.Renviron, then ~/.Renviron */
void process_user_Renviron()
{
const char *s = getenv("R_ENVIRON_USER");
if(s) {
if (*s) process_Renviron(R_ExpandFileName(s));
return;
}
#ifdef R_ARCH
char buff[100];
snprintf(buff, 100, ".Renviron.%s", R_ARCH);
if( process_Renviron(buff)) return;
#endif
if(process_Renviron(".Renviron")) return;
#ifdef Unix
s = R_ExpandFileName("~/.Renviron");
#endif
#ifdef Win32
{
char buf[1024]; /* MAX_PATH is less than this */
/* R_USER is not necessarily set yet, so we have to work harder */
s = getenv("R_USER");
if(!s) s = getenv("HOME");
if(!s) return;
snprintf(buf, 1024, "%s/.Renviron", s);
s = buf;
}
#endif
#ifdef R_ARCH
snprintf(buff, 100, "%s.%s", s, R_ARCH);
if( process_Renviron(buff)) return;
#endif
process_Renviron(s);
}
SEXP
read_mtp(SEXP fname)
{
FILE *f;
char buf[MTP_BUF_SIZE], blank[1], *pres;
MTB *mtb, thisRec;
int i, j, res, nMTB = MTB_INITIAL_ENTRIES;
PROTECT(fname = asChar(fname));
#ifdef WIN32 /* force text-mode read */
if ((f = fopen(R_ExpandFileName(CHAR(fname)), "rt")) == NULL)
#else
if ((f = fopen(R_ExpandFileName(CHAR(fname)), "r")) == NULL)
#endif
error(_("unable to open file '%s': '%s'"),
CHAR(fname), strerror(errno));
if ((fgets(buf, MTP_BUF_SIZE, f) == NULL) ||
strncmp(buf, "Minitab Portable Worksheet ", 27) != 0)
error(_("file '%s' is not in Minitab Portable Worksheet format"),
CHAR(fname));
pres = fgets(buf, MTP_BUF_SIZE, f);
if(pres != buf) error(_("file read error"));
UNPROTECT(1);
mtb = Calloc(nMTB, MTB);
for (i = 0; !feof(f); i++) {
if (i >= nMTB) {
nMTB *= 2;
mtb = Realloc(mtb, nMTB, MTB);
}
thisRec = mtb[i] = Calloc(1, MTBDATC);
if (sscanf(buf, "%%%7d%7d%7d%7d%c%8c", &(thisRec->type),
&(thisRec->cnum), &(thisRec->len),
&(thisRec->dtype), blank, thisRec->name) != 6)
error(_("first record for entry %d is corrupt"), i+1);
thisRec->name[8] = '\0';
strtrim(thisRec->name); /* trim trailing white space on name */
switch (thisRec->dtype) {
case 0: /* numeric data */
thisRec->dat.ndat = Calloc(thisRec->len, double);
for (j = 0; j < thisRec->len; j++) {
res = fscanf(f, "%lg", thisRec->dat.ndat + j);
if(res == EOF) error(_("file read error"));
}
break;
default:
if (thisRec->type == 4) { /* we have a matrix so dtype is number of columns */
thisRec->dat.ndat = Calloc(thisRec->len, double);
for (j = 0; j < thisRec->len; j++) {
res = fscanf(f, "%lg", thisRec->dat.ndat + j);
if(res == EOF) error(_("file read error"));
}
} else {
error(_("non-numeric data types are not yet implemented"));
}
}
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;
}
void R_nc4_create( char **filename, int *cmode, int *ncid, int *retval )
{
int nc_cmode, flag_NC_NOCLOBBER, flag_NC_SHARE, flag_NC_64BIT_OFFSET,
flag_NC_NETCDF4;
flag_NC_NOCLOBBER = 1;
flag_NC_SHARE = 2;
flag_NC_64BIT_OFFSET = 4;
flag_NC_NETCDF4 = 8;
/* cmode is passed in our own R bit values, not the actual
netcdf file values. Convert to netcdf values.
*/
nc_cmode = 0;
if( *cmode & flag_NC_NOCLOBBER )
nc_cmode += NC_NOCLOBBER;
if( *cmode & flag_NC_SHARE )
nc_cmode += NC_SHARE;
if( *cmode & flag_NC_64BIT_OFFSET )
nc_cmode += NC_64BIT_OFFSET;
if( *cmode & flag_NC_NETCDF4 )
nc_cmode += NC_NETCDF4;
*retval = nc_create(R_ExpandFileName(filename[0]), nc_cmode, ncid);
if( *retval != NC_NOERR )
Rprintf( "Error in R_nc4_create: %s (creation mode was %d)\n",
nc_strerror(*retval), nc_cmode );
}
SVGDesc(std::string filename_, bool standalone_):
filename(filename_),
pageno(0),
standalone(standalone_),
cc(gdtools::context_create()) {
file = fopen(R_ExpandFileName(filename.c_str()), "w");
}
void attribute_hidden Rstd_savehistory(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile;
char file[PATH_MAX];
const char *p;
sfile = CAR(args);
if (!isString(sfile) || LENGTH(sfile) < 1)
errorcall(call, _("invalid '%s' argument"), "file");
p = R_ExpandFileName(translateChar(STRING_ELT(sfile, 0)));
if(strlen(p) > PATH_MAX - 1)
errorcall(call, _("'file' argument is too long"));
strcpy(file, p);
#if defined(HAVE_LIBREADLINE) && defined(HAVE_READLINE_HISTORY_H)
if(R_Interactive && UsingReadline) {
int err;
err = write_history(file);
if(err) error(_("problem in saving the history file '%s'"), file);
/* Note that q() uses stifle_history, but here we do not want
* to truncate the active history when saving during a session */
#ifdef HAVE_HISTORY_TRUNCATE_FILE
R_setupHistory(); /* re-read the history size */
err = history_truncate_file(file, R_HistorySize);
if(err) warning(_("problem in truncating the history file"));
#endif
} else errorcall(call, _("no history available to save"));
#else
errorcall(call, _("no history available to save"));
#endif
}
SEXP
do_read_SPSS(SEXP file)
{
const char *filename = CHAR(PROTECT(asChar(file)));
FILE *fp = fopen(R_ExpandFileName(filename), "rb");
char buf[5];
SEXP ans;
if(!fp)
error(_("unable to open file: '%s'"), strerror(errno));
if(fread_pfm(buf, sizeof(char), 4, fp) != 4) {
fclose(fp);
error(_("problem in reading file '%s'"), filename);
}
buf[4] = '\0';
if (0 == strncmp("$FL2", buf, 4)) {
fclose(fp);
ans = read_SPSS_SAVE(filename);
} else {
if (!is_PORT(fp)) {
fclose(fp);
error(_("file '%s' is not in any supported SPSS format"),
filename);
}
fclose(fp);
ans = read_SPSS_PORT(filename);
}
UNPROTECT(1);
return ans;
}
static void BM_Close_bitmap(pX11Desc xd)
{
if (xd->type == PNGdirect) {
char buf[PATH_MAX];
snprintf(buf, PATH_MAX, xd->filename, xd->npages);
cairo_surface_write_to_png(xd->cs, buf);
return;
}
void *xi = cairo_image_surface_get_data(xd->cs);
if (!xi) {
warning("BM_Close_bitmap called on non-surface");
return;
}
stride = cairo_image_surface_get_stride(xd->cs)/4;
if (xd->type == PNG)
R_SaveAsPng(xi, xd->windowWidth, xd->windowHeight,
Cbitgp, 0, xd->fp, 0, xd->res_dpi);
else if(xd->type == JPEG)
R_SaveAsJpeg(xi, xd->windowWidth, xd->windowHeight,
Cbitgp, 0, xd->quality, xd->fp, xd->res_dpi);
else if(xd->type == BMP)
R_SaveAsBmp(xi, xd->windowWidth, xd->windowHeight,
Cbitgp, 0, xd->fp, xd->res_dpi);
else {
char buf[PATH_MAX];
snprintf(buf, PATH_MAX, xd->filename, xd->npages);
R_SaveAsTIFF(xi, xd->windowWidth, xd->windowHeight,
Cbitgp, 0, R_ExpandFileName(buf), xd->res_dpi,
xd->quality);
}
}
double attribute_hidden R_FileMtime(const char *path)
{
struct stat sb;
if (stat(R_ExpandFileName(path), &sb) != 0)
error(_("cannot determine file modification time of '%s'"), path);
return (double) sb.st_mtime;
}
void R_nc_create( char **filename, int *cmode, int *ncid, int *retval )
{
*retval = nc_create(R_ExpandFileName(filename[0]), *cmode, ncid);
if( *retval != NC_NOERR )
REprintf( "Error in R_nc_create: %s\n",
nc_strerror(*retval) );
}
wchar_t *filenameToWchar_wcc(const SEXP fn, const Rboolean expand){
static wchar_t filename[BSIZE + 1];
void *obj;
const char *from = "", *inbuf;
char *outbuf;
size_t inb, outb, res;
if(!strlen(CHAR(fn))){
wcscpy(filename, L"");
return filename;
}
if(IS_LATIN1(fn)) from = "latin1";
if(IS_UTF8(fn)) from = "UTF-8";
if(IS_BYTES(fn)) REprintf("encoding of a filename cannot be 'bytes'");
obj = Riconv_open("UCS-2LE", from);
if(obj == (void *)(-1))
REprintf("unsupported conversion from '%s' in shellexec_wcc.c",
from);
if(expand) inbuf = R_ExpandFileName(CHAR(fn)); else inbuf = CHAR(fn);
inb = strlen(inbuf)+1; outb = 2*BSIZE;
outbuf = (char *) filename;
res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
Riconv_close(obj);
if(inb > 0) REprintf("file name conversion problem -- name too long?");
if(res == -1) REprintf("file name conversion problem");
return filename;
} /* End of filenameToWchar_wcc(). */
SEXP R_nc_create (SEXP filename, SEXP type)
{
int cmode;
int ncid;
int status;
SEXP retlist, retlistnames;
/*-- Create output object and initialize return values --------------------*/
PROTECT(retlist = allocVector(VECSXP, 3));
SET_VECTOR_ELT(retlist, 0, allocVector(REALSXP, 1));
SET_VECTOR_ELT(retlist, 1, allocVector(STRSXP, 1));
SET_VECTOR_ELT(retlist, 2, allocVector(REALSXP, 1));
PROTECT(retlistnames = allocVector(STRSXP, 3));
SET_STRING_ELT(retlistnames, 0, mkChar("status"));
SET_STRING_ELT(retlistnames, 1, mkChar("errmsg"));
SET_STRING_ELT(retlistnames, 2, mkChar("ncid"));
setAttrib(retlist, R_NamesSymbol, retlistnames);
ncid = -1;
status = -1;
REAL(VECTOR_ELT(retlist, 0))[0] = (double)status;
SET_VECTOR_ELT (retlist, 1, mkString(""));
REAL(VECTOR_ELT(retlist, 2))[0] = (double)ncid;
if (strcmp(CHAR(STRING_ELT(type, 0)), "NC_NOCLOBBER" ) == 0)
cmode = NC_NOCLOBBER;
else if (strcmp(CHAR(STRING_ELT(type, 0)), "NC_NOCLOBBER|NC_64BIT_OFFSET" ) == 0)
cmode = NC_NOCLOBBER|NC_64BIT_OFFSET;
else if (strcmp(CHAR(STRING_ELT(type, 0)), "NC_NOCLOBBER|NC_NETCDF4" ) == 0)
cmode = NC_NOCLOBBER|NC_NETCDF4;
else if (strcmp(CHAR(STRING_ELT(type, 0)), "NC_NOCLOBBER|NC_NETCDF4|NC_CLASSIC_MODEL" ) == 0)
cmode = NC_NOCLOBBER|NC_NETCDF4|NC_CLASSIC_MODEL;
else if (strcmp(CHAR(STRING_ELT(type, 0)), "NC_SHARE" ) == 0)
cmode = NC_SHARE;
else if (strcmp(CHAR(STRING_ELT(type, 0)), "NC_64BIT_OFFSET" ) == 0)
cmode = NC_64BIT_OFFSET;
else if (strcmp(CHAR(STRING_ELT(type, 0)), "NC_NETCDF4" ) == 0)
cmode = NC_NETCDF4;
else if (strcmp(CHAR(STRING_ELT(type, 0)), "NC_CLASSIC_MODEL" ) == 0)
cmode = NC_CLASSIC_MODEL;
else {
SET_VECTOR_ELT (retlist, 1, mkString("Unknown NC_File type"));
REAL(VECTOR_ELT(retlist, 0))[0] = -1;
UNPROTECT(2);
return(retlist);
}
status = nc_create(R_ExpandFileName(CHAR(STRING_ELT(filename, 0))),
cmode, &ncid);
REAL(VECTOR_ELT(retlist, 0))[0] = (double)status;
REAL(VECTOR_ELT(retlist, 2))[0] = (double)ncid;
UNPROTECT(2);
return(retlist);
}
FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand)
{
const void *vmax = vmaxget();
const char *filename = translateChar(fn), *res;
if(fn == NA_STRING || !filename) return NULL;
if(expand) res = R_ExpandFileName(filename);
else res = filename;
vmaxset(vmax);
return fopen(res, mode);
}
SEXP attribute_hidden do_readEnviron(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
SEXP x = CAR(args);
if (!isString(x) || LENGTH(x) != 1)
errorcall(call, _("argument '%s' must be a character string"), "x");
const char *fn = R_ExpandFileName(translateChar(STRING_ELT(x, 0)));
int res = process_Renviron(fn);
if (!res)
warningcall(call, _("file '%s' cannot be opened for reading"), fn);
return ScalarLogical(res != 0);
}
/* The following is a version of R_ExpandFileName that assumes
s is in UTF-8 and returns the final result in that encoding as well. */
const char *R_ExpandFileNameUTF8(const char *s)
{
if (s[0] !='~' || (s[0] && isalpha(s[1]))) return s;
else {
char home[PATH_MAX];
reEnc2(R_ExpandFileName("~"), home, PATH_MAX, CE_NATIVE, CE_UTF8, 3);
if (strlen(home) + strlen(s+1) < PATH_MAX) {
strcpy(newFileName, home);
strcat(newFileName, s+1);
return newFileName;
} else return s;
}
}
static Rboolean SWF_Open( pDevDesc deviceInfo ){
/*
* Shortcut pointers to variables of interest.
* It seems like there HAS to be a more elegent way of accesing
* these...
*/
swfDevDesc *swfInfo = (swfDevDesc *) deviceInfo->deviceSpecific;
//Debug log
if( swfInfo->debug == TRUE ){
if( !( swfInfo->logFile =
fopen(R_ExpandFileName(swfInfo->logFileName), "w") ) )
return FALSE;
fprintf(swfInfo->logFile,
"SWF_Open: Begin swf output\n");
fprintf(swfInfo->logFile,
"SWF_Open: Setting dimensions %6.1f by %6.1f\n",
deviceInfo->right, deviceInfo->top);
fprintf(swfInfo->logFile,
"SWF_Open: Setting background %3d, %3d, %3d\n",
R_RED(deviceInfo->startfill),
R_GREEN(deviceInfo->startfill),
R_BLUE(deviceInfo->startfill));
fflush(swfInfo->logFile);
//Rprintf("%s",dashTo);
}
// Set the background color for the movie
SWFMovie_setBackground(swfInfo->m,
R_RED(deviceInfo->startfill),
R_GREEN(deviceInfo->startfill),
R_BLUE(deviceInfo->startfill));
SWFMovie_setDimension(swfInfo->m, deviceInfo->right, deviceInfo->top);
// Set the frame rate for the movie
SWFMovie_setRate(swfInfo->m, swfInfo->frameRate);
// Set the total number of frames in the movie to 1
SWFMovie_setNumberOfFrames(swfInfo->m, 1);
return TRUE;
}
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;
}
SEXP chooseDir(SEXP def, SEXP caption)
{
const char *p;
char path[MAX_PATH];
if(!isString(def) || length(def) != 1 )
error(_("'default' must be a character string"));
p = translateChar(STRING_ELT(def, 0));
if(strlen(p) >= MAX_PATH) error(_("'default' is overlong"));
strcpy(path, R_ExpandFileName(p));
R_fixbackslash(path);
if(!isString(caption) || length(caption) != 1 )
error(_("'caption' must be a character string"));
p = askcdstring(translateChar(STRING_ELT(caption, 0)), path);
SEXP ans = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, p ? mkChar(p): NA_STRING);
UNPROTECT(1);
return ans;
}
/* cmode is 0 for read only, 1 for write access.
*/
void R_nc_open( char **filename, int *cmode, int *ncid, int *retval )
{
int nc_mode;
if( *cmode == 0 )
nc_mode = 0;
else if( *cmode == 1 )
nc_mode = NC_WRITE;
else
{
REprintf( "Error in R_nc_open: bad mode passed. Must be 0 (read) or 1 (write)\n");
*retval = -1;
return;
}
*retval = nc_open(R_ExpandFileName(filename[0]), nc_mode, ncid);
if( *retval != NC_NOERR )
REprintf( "Error in R_nc_open: %s\n",
nc_strerror(*retval) );
}
SEXP R_nc_open(SEXP NAME, SEXP mode)
{
int status;
int ncid;
SEXP retlist, retlistnames;
/*-- Create output object and initialize return values --------------------*/
PROTECT(retlist = allocVector(VECSXP, 3));
SET_VECTOR_ELT(retlist, 0, allocVector(REALSXP, 1));
SET_VECTOR_ELT(retlist, 1, allocVector(STRSXP, 1));
SET_VECTOR_ELT(retlist, 2, allocVector(REALSXP, 1));
PROTECT(retlistnames = allocVector(STRSXP, 3));
SET_STRING_ELT(retlistnames, 0, mkChar("status"));
SET_STRING_ELT(retlistnames, 1, mkChar("errmsg"));
SET_STRING_ELT(retlistnames, 2, mkChar("ncid"));
setAttrib(retlist, R_NamesSymbol, retlistnames);
ncid = -1;
status = -1;
REAL(VECTOR_ELT(retlist, 0))[0] = (double)status;
SET_VECTOR_ELT (retlist, 1, mkString(""));
REAL(VECTOR_ELT(retlist, 2))[0] = (double)ncid;
int cmode;
if (strcmp(CHAR(STRING_ELT(mode, 0)), "NC_NOWRITE" ) == 0)
cmode = NC_NOWRITE;
else if (strcmp(CHAR(STRING_ELT(mode, 0)), "NC_WRITE" ) == 0)
cmode = NC_WRITE;
status = nc_open(R_ExpandFileName(CHAR(STRING_ELT(NAME, 0))), cmode, &ncid);
REAL(VECTOR_ELT(retlist, 0))[0] = (double)status;
REAL(VECTOR_ELT(retlist, 2))[0] = (double)ncid;
UNPROTECT(2);
return(retlist);
}
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;
}
void attribute_hidden Rstd_loadhistory(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile;
char file[PATH_MAX];
const char *p;
sfile = CAR(args);
if (!isString(sfile) || LENGTH(sfile) < 1)
errorcall(call, _("invalid '%s' argument"), "file");
p = R_ExpandFileName(translateChar(STRING_ELT(sfile, 0)));
if(strlen(p) > PATH_MAX - 1)
errorcall(call, _("'file' argument is too long"));
strcpy(file, p);
#if defined(HAVE_LIBREADLINE) && defined(HAVE_READLINE_HISTORY_H)
if(R_Interactive && UsingReadline) {
clear_history();
read_history(file);
} else errorcall(call, _("no history mechanism available"));
#else
errorcall(call, _("no history mechanism available"));
#endif
}
DOCX_dev(std::string filename_,
Rcpp::List& aliases_,
bool editable_, int id_,
std::string raster_prefix_,
int rel_last_id_, int standalone_,
double width_, double height_ ):
filename(filename_),
pageno(0),
id(id_),
raster_prefix(raster_prefix_), img_last_id(rel_last_id_),
system_aliases(Rcpp::wrap(aliases_["system"])),
user_aliases(Rcpp::wrap(aliases_["user"])),
editable(editable_),
standalone(standalone_),
cc(gdtools::context_create()){
file = fopen(R_ExpandFileName(filename.c_str()), "w");
clipleft = 0.0;
clipright = width_;
cliptop = 0.0;
clipbottom = height_;
clp = new clipper();
}
SEXP freadR(
// params passed to freadMain
SEXP inputArg,
SEXP sepArg,
SEXP decArg,
SEXP quoteArg,
SEXP headerArg,
SEXP nrowLimitArg,
SEXP skipArg,
SEXP NAstringsArg,
SEXP stripWhiteArg,
SEXP skipEmptyLinesArg,
SEXP fillArg,
SEXP showProgressArg,
SEXP nThreadArg,
SEXP verboseArg,
SEXP warnings2errorsArg,
// extras needed by callbacks from freadMain
SEXP selectArg,
SEXP dropArg,
SEXP colClassesArg,
SEXP integer64Arg,
SEXP encodingArg
) {
verbose = LOGICAL(verboseArg)[0];
warningsAreErrors = LOGICAL(warnings2errorsArg)[0];
freadMainArgs args;
protecti=0;
ncol = 0;
const char *ch, *ch2;
if (!isString(inputArg) || LENGTH(inputArg)!=1)
error("fread input must be a single character string: a filename or the data itself");
ch = ch2 = (const char *)CHAR(STRING_ELT(inputArg,0));
while (*ch2!='\n' && *ch2!='\0') ch2++;
args.input = (*ch2=='\n') ? ch : R_ExpandFileName(ch); // for convenience so user doesn't have to call path.expand()
ch = args.input;
while (*ch!='\0' && *ch!='\n') ch++;
if (*ch=='\n' || args.input[0]=='\0') {
if (verbose) DTPRINT("Input contains a \\n (or is \"\"). Taking this to be text input (not a filename)\n");
args.filename = NULL;
} else {
if (verbose) DTPRINT("Input contains no \\n. Taking this to be a filename to open\n");
args.filename = args.input;
args.input = NULL;
}
if (!isString(sepArg) || LENGTH(sepArg)!=1 || strlen(CHAR(STRING_ELT(sepArg,0)))>1)
error("CfreadR: sep must be 'auto' or a single character ('\\n' is an acceptable single character)");
args.sep = CHAR(STRING_ELT(sepArg,0))[0]; // '\0' when default "auto" was replaced by "" at R level
if (!(isString(decArg) && LENGTH(decArg)==1 && strlen(CHAR(STRING_ELT(decArg,0)))==1))
error("CfreadR: dec must be a single character such as '.' or ','");
args.dec = CHAR(STRING_ELT(decArg,0))[0];
if (!isString(quoteArg) || LENGTH(quoteArg)!=1 || strlen(CHAR(STRING_ELT(quoteArg,0))) > 1)
error("CfreadR: quote must be a single character or empty \"\"");
args.quote = CHAR(STRING_ELT(quoteArg,0))[0];
// header is the only boolean where NA is valid and means 'auto'.
// LOGICAL in R is signed 32 bits with NA_LOGICAL==INT_MIN, currently.
args.header = FALSE;
if (LOGICAL(headerArg)[0]==NA_LOGICAL) args.header = NA_BOOL8;
else if (LOGICAL(headerArg)[0]==TRUE) args.header = TRUE;
args.nrowLimit = INT64_MAX;
// checked at R level
if (isReal(nrowLimitArg)) {
if (R_FINITE(REAL(nrowLimitArg)[0]) && REAL(nrowLimitArg)[0]>=0.0) args.nrowLimit = (int64_t)(REAL(nrowLimitArg)[0]);
} else {
if (INTEGER(nrowLimitArg)[0]>=0) args.nrowLimit = (int64_t)INTEGER(nrowLimitArg)[0];
}
args.skipNrow=0;
args.skipString=NULL;
if (isString(skipArg)) {
args.skipString = CHAR(STRING_ELT(skipArg,0)); // LENGTH==1 was checked at R level
} else if (isReal(skipArg)) {
if (R_FINITE(REAL(skipArg)[0]) && REAL(skipArg)[0]>0.0) args.skipNrow = (uint64_t)REAL(skipArg)[0];
} else if (isInteger(skipArg)) {
if (INTEGER(skipArg)[0]>0) args.skipNrow = (uint64_t)INTEGER(skipArg)[0];
} else error("skip must be a single positive numeric (integer or double), or a string to search for");
if (!isNull(NAstringsArg) && !isString(NAstringsArg))
error("'na.strings' is type '%s'. Must be either NULL or a character vector.", type2char(TYPEOF(NAstringsArg)));
int nnas = length(NAstringsArg);
if (nnas>100) // very conservative limit
error("length(na.strings)==%d. This is too many to allocate pointers for on stack", nnas);
const char **NAstrings = alloca((nnas + 1) * sizeof(char*));
for (int i=0; i<nnas; i++)
NAstrings[i] = CHAR(STRING_ELT(NAstringsArg,i));
NAstrings[nnas] = NULL;
args.NAstrings = NAstrings;
// here we use _Bool and rely on fread at R level to check these do not contain NA_LOGICAL
args.stripWhite = LOGICAL(stripWhiteArg)[0];
args.skipEmptyLines = LOGICAL(skipEmptyLinesArg)[0];
args.fill = LOGICAL(fillArg)[0];
args.showProgress = LOGICAL(showProgressArg)[0];
if (INTEGER(nThreadArg)[0]<1) error("nThread(%d)<1", INTEGER(nThreadArg)[0]);
args.nth = (uint32_t)INTEGER(nThreadArg)[0];
args.verbose = verbose;
args.warningsAreErrors = warningsAreErrors;
// === extras used for callbacks ===
if (!isString(integer64Arg) || LENGTH(integer64Arg)!=1) error("'integer64' must be a single character string");
const char *tt = CHAR(STRING_ELT(integer64Arg,0));
if (strcmp(tt, "integer64")==0) {
readInt64As = CT_INT64;
} else if (strcmp(tt, "character")==0) {
readInt64As = CT_STRING;
} else if (strcmp(tt,"double")==0 || strcmp(tt,"numeric")==0) {
readInt64As = CT_FLOAT64;
} else STOP("Invalid value integer64='%s'. Must be 'integer64', 'character', 'double' or 'numeric'", tt);
colClassesSxp = colClassesArg; // checked inside userOverride where it is used.
if (!isNull(selectArg) && !isNull(dropArg)) STOP("Use either select= or drop= but not both.");
selectSxp = selectArg;
dropSxp = dropArg;
// Encoding, #563: Borrowed from do_setencoding from base R
// https://github.com/wch/r-source/blob/ca5348f0b5e3f3c2b24851d7aff02de5217465eb/src/main/util.c#L1115
// Check for mkCharLenCE function to locate as to where where this is implemented.
tt = CHAR(STRING_ELT(encodingArg, 0));
if (strcmp(tt, "unknown")==0) ienc = CE_NATIVE;
else if (strcmp(tt, "Latin-1")==0) ienc = CE_LATIN1;
else if (strcmp(tt, "UTF-8")==0) ienc = CE_UTF8;
else STOP("encoding='%s' invalid. Must be 'unknown', 'Latin-1' or 'UTF-8'", tt);
// === end extras ===
DT = R_NilValue; // created by callback
freadMain(args);
UNPROTECT(protecti);
return DT;
}
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);
}
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 Rboolean
BM_Open(pDevDesc dd, pX11Desc xd, int width, int height)
{
char buf[PATH_MAX];
cairo_status_t res;
if (xd->type == PNG || xd->type == JPEG ||
xd->type == TIFF || xd->type == BMP ||
xd->type == PNGdirect) {
xd->cs = cairo_image_surface_create(CAIRO_FORMAT_ARGB32,
xd->windowWidth,
xd->windowHeight);
res = cairo_surface_status(xd->cs);
if (res != CAIRO_STATUS_SUCCESS) {
warning("cairo error '%s'", cairo_status_to_string(res));
return FALSE;
}
xd->cc = cairo_create(xd->cs);
res = cairo_status(xd->cc);
if (res != CAIRO_STATUS_SUCCESS) {
warning("cairo error '%s'", cairo_status_to_string(res));
return FALSE;
}
cairo_set_operator(xd->cc, CAIRO_OPERATOR_OVER);
cairo_reset_clip(xd->cc);
cairo_set_antialias(xd->cc, xd->antialias);
}
#ifdef HAVE_CAIRO_SVG
else if(xd->type == SVG) {
snprintf(buf, PATH_MAX, xd->filename, xd->npages + 1);
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;
warning("cairo error '%s'", cairo_status_to_string(res));
return FALSE;
}
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) {
warning("cairo error '%s'", cairo_status_to_string(res));
return FALSE;
}
cairo_set_antialias(xd->cc, xd->antialias);
}
#endif
#ifdef HAVE_CAIRO_PDF
else if(xd->type == PDF) {
snprintf(buf, PATH_MAX, xd->filename, xd->npages + 1);
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) {
warning("cairo error '%s'", cairo_status_to_string(res));
return FALSE;
}
cairo_surface_set_fallback_resolution(xd->cs, xd->fallback_dpi,
xd->fallback_dpi);
xd->cc = cairo_create(xd->cs);
res = cairo_status(xd->cc);
if (res != CAIRO_STATUS_SUCCESS) {
warning("cairo error '%s'", cairo_status_to_string(res));
return FALSE;
}
cairo_set_antialias(xd->cc, xd->antialias);
}
#endif
#ifdef HAVE_CAIRO_PS
else if(xd->type == PS) {
snprintf(buf, PATH_MAX, xd->filename, xd->npages + 1);
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) {
warning("cairo error '%s'", cairo_status_to_string(res));
return FALSE;
}
// 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
cairo_surface_set_fallback_resolution(xd->cs, xd->fallback_dpi,
xd->fallback_dpi);
xd->cc = cairo_create(xd->cs);
res = cairo_status(xd->cc);
if (res != CAIRO_STATUS_SUCCESS) {
warning("cairo error '%s'", cairo_status_to_string(res));
return FALSE;
}
cairo_set_antialias(xd->cc, xd->antialias);
}
#endif
else
error(_("unimplemented cairo-based device"));
return TRUE;
}
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);
}
std::string expandFileName(const std::string& name)
{
return std::string(R_ExpandFileName(name.c_str()));
}
Rboolean R_FileExists(const char *path)
{
struct stat sb;
return stat(R_ExpandFileName(path), &sb) == 0;
}
