Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: fb8e36f8be
Fetching contributors…

Cannot retrieve contributors at this time

5674 lines (5146 sloc) 162.831 kB
/*
* R : A Computer Language for Statistical Data Analysis
* Copyright (C) 2000-12 The R Core Team.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, a copy is available at
* http://www.r-project.org/Licenses/
*/
/* Notes on so-called 'Large File Support':
The C stdio functions such as fseek and ftell are defined using
'long' for file positioning: also fread/fwrite use size_t for size
and number of items. (The latter can cause problems with
reading/writing large blocks, but not in R.) POSIX introduced
off_t and fseeko/ftello to allow larger file sizes, since 'long'
may limit file positioning to 2GB. (C99 introduced fpos_t and
f[gs]etpos.)
Note that the issue really only arises if 'long' is 32-bit, which
is not the case on all known 64-bit platforms except Windows.
However, off_t (defined in sys/types.h) is itself often 32-bit,
which has led to workarounds. On Linux systems, the macros
__USE_FILE_OFFSET64
__USE_LARGEFILE64
select between __off_t and __off64_t. Since these are different
types, the functions using them have to be remapped, and the
__off64_t versions call fopen64, fseeko64, ftello64 and so on.
These macros are not intended to be used directly but via (features.h)
_FILE_OFFSET_BITS=N Select default filesystem interface.
_LARGEFILE_SOURCE Some more functions for correct standard I/O.
_LARGEFILE64_SOURCE Additional functionality from LFS for large files.
The last makes system calls like open64 visible directly, and so
should not be needed in R.
This is commonly known as LFS; _but_ 'LFS Linux' is something else.
See http://en.wikipedia.org/wiki/Large_file_support and
http://www.suse.de/~aj/linux_lfs.html
Solaris has a similar scheme: see 'man lf64', 'man lfcompile' and
'man lfcompile64'.
On Mac OS X, off_t is typedef-ed to __darwin_off_t, which is
__int64_t, so the issue never arises. Similarly on FreeBSD.
The situation with Windows is similar, but off64_t, fseeko64 etc
need to be selected explicitly (even on Win64).
There are also issues with the glob(), readdir(), stat() system
calls: see platform.c and sysutils.c
saveload.c uses f[gs]etpos: they have 64-bit versions on LFS Linux
and Solaris. But this only used for pre-1.4.0 formats, and fpos_t
is 64-bit on Windows.
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#define R_USE_SIGNALS 1
#include <Defn.h>
#include <Internal.h>
#include <Fileio.h>
#include <Rconnections.h>
#include <R_ext/Complex.h>
#include <R_ext/R-ftp-http.h>
#include <R_ext/RS.h> /* R_chk_calloc and Free */
#include <R_ext/Riconv.h>
#include <R_ext/Print.h> // REprintf, REvprintf
#undef ERROR /* for compilation on Windows */
#ifdef Win32
int trio_vsnprintf(char *buffer, size_t bufferSize, const char *format,
va_list args);
# define vsnprintf trio_vsnprintf
#endif
int attribute_hidden R_OutputCon; /* used in printutils.c */
static void con_destroy(int i);
#include <errno.h>
#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif
#ifdef HAVE_FCNTL_H
# include <fcntl.h>
/* Solaris and AIX define open as open64 under some circumstances */
# undef open
/* AIX defines truncate as truncate64 under some circumstances */
# undef truncate
#endif
/* This works on Win64 where long is 4 bytes but long long is 8 bytes. */
#if defined __GNUC__ && __GNUC__ >= 2
__extension__ typedef long long int _lli_t;
#else
typedef long long int _lli_t;
#endif
/* Win32 does have popen, but it does not work in GUI applications,
so test that later */
#ifdef Win32
# include <R_ext/RStartup.h>
extern UImode CharacterMode;
#endif
#define NCONNECTIONS 128 /* snow needs one per slave node */
#define NSINKS 21
static Rconnection Connections[NCONNECTIONS];
static SEXP OutTextData;
static int R_SinkNumber;
static int SinkCons[NSINKS], SinkConsClose[NSINKS], R_SinkSplit[NSINKS];
/* We need a unique id for a connection to ensure that the finalizer
does not try to close it after it is already closed. And that id
will be passed as a pointer, so it seemed easiest to use void *.
*/
static void * current_id = NULL;
/* ------------- admin functions (see also at end) ----------------- */
static int NextConnection(void)
{
int i;
for(i = 3; i < NCONNECTIONS; i++)
if(!Connections[i]) break;
if(i >= NCONNECTIONS) {
R_gc(); /* Try to reclaim unused ones */
for(i = 3; i < NCONNECTIONS; i++)
if(!Connections[i]) break;
if(i >= NCONNECTIONS)
error(_("all connections are in use"));
}
return i;
}
static int ConnIndex(Rconnection con)
{
int i;
for(i = 0; i < NCONNECTIONS; i++)
if(Connections[i] == con) break;
if(i >= NCONNECTIONS)
error(_("connection not found"));
return i;
}
/* internal, not the same as R function getConnection */
Rconnection getConnection(int n)
{
Rconnection con = NULL;
if(n < 0 || n >= NCONNECTIONS || n == NA_INTEGER ||
!(con = Connections[n]))
error(_("invalid connection"));
return con;
}
attribute_hidden
int getActiveSink(int n)
{
if (n >= R_SinkNumber || n < 0)
return 0;
if (R_SinkSplit[R_SinkNumber - n])
return SinkCons[R_SinkNumber - n - 1];
else
return 0;
}
static void conFinalizer(SEXP ptr)
{
int i, ncon;
void *cptr = R_ExternalPtrAddr(ptr);
if(!cptr) return;
for(i = 3; i < NCONNECTIONS; i++)
if(Connections[i] && Connections[i]->id == cptr) {
ncon = i;
break;
}
if(i >= NCONNECTIONS) return;
{
Rconnection this = getConnection(ncon);
if(strcmp(this->class, "textConnection"))
warning(_("closing unused connection %d (%s)\n"),
ncon, this->description);
}
con_destroy(ncon);
R_ClearExternalPtr(ptr); /* not really needed */
}
/* for use in REvprintf */
attribute_hidden
Rconnection getConnection_no_err(int n)
{
Rconnection con = NULL;
if(n < 0 || n >= NCONNECTIONS || n == NA_INTEGER ||
!(con = Connections[n]))
return NULL;
return con;
}
static void set_iconv_error(Rconnection con, char* from, char* to)
{
char buf[100];
snprintf(buf, 100, _("unsupported conversion from '%s' to '%s'"), from, to);
con_destroy(ConnIndex(con));
error(buf);
}
void set_iconv(Rconnection con)
{
void *tmp;
/* need to test if this is text, open for reading to writing or both,
and set inconv and/or outconv */
if(!con->text || !strlen(con->encname) ||
strcmp(con->encname, "native.enc") == 0) {
con->UTF8out = FALSE;
return;
}
if(con->canread) {
size_t onb = 50;
char *ob = con->oconvbuff;
/* UTF8out is set in readLines() and scan()
Was Windows-only until 2.12.0, but we now require iconv.
*/
Rboolean useUTF8 = !utf8locale && con->UTF8out;
tmp = Riconv_open(useUTF8 ? "UTF-8" : "", con->encname);
if(tmp != (void *)-1) con->inconv = tmp;
else set_iconv_error(con, con->encname, useUTF8 ? "UTF-8" : "");
con->EOF_signalled = FALSE;
/* initialize state, and prepare any initial bytes */
Riconv(tmp, NULL, NULL, &ob, &onb);
con->navail = (short)(50-onb); con->inavail = 0;
/* libiconv can handle BOM marks on Windows Unicode files, but
glibc's iconv cannot. Aargh ... */
if(streql(con->encname, "UCS-2LE") ||
streql(con->encname, "UTF-16LE")) con->inavail = -2;
}
if(con->canwrite) {
size_t onb = 25;
char *ob = con->init_out;
tmp = Riconv_open(con->encname, "");
if(tmp != (void *)-1) con->outconv = tmp;
else set_iconv_error(con, con->encname, "");
/* initialize state, and prepare any initial bytes */
Riconv(tmp, NULL, NULL, &ob, &onb);
ob[25-onb] = '\0';
}
}
/* ------------------- null connection functions --------------------- */
static Rboolean null_open(Rconnection con)
{
error(_("%s not enabled for this connection"), "open");
return FALSE; /* -Wall */
}
static void null_close(Rconnection con)
{
con->isopen = FALSE;
}
static void null_destroy(Rconnection con)
{
if(con->private) free(con->private);
}
static int null_vfprintf(Rconnection con, const char *format, va_list ap)
{
error(_("%s not enabled for this connection"), "printing");
return 0; /* -Wall */
}
/* va_copy is C99, but a draft standard had __va_copy. Glibc has
__va_copy declared uncondiitonally */
#if defined(HAVE_VASPRINTF) && !HAVE_DECL_VASPRINTF
int vasprintf(char **strp, const char *fmt, va_list ap);
#endif
# define BUFSIZE 10000
int dummy_vfprintf(Rconnection con, const char *format, va_list ap)
{
char buf[BUFSIZE], *b = buf;
int res;
const void *vmax = vmaxget();
int usedRalloc = FALSE, usedVasprintf = FALSE;
va_list aq;
va_copy(aq, ap);
res = vsnprintf(buf, BUFSIZE, format, aq);
va_end(aq);
#ifdef HAVE_VASPRINTF
if(res >= BUFSIZE || res < 0) {
res = vasprintf(&b, format, ap);
if (res < 0) {
b = buf;
buf[BUFSIZE-1] = '\0';
warning(_("printing of extremely long output is truncated"));
} else usedVasprintf = TRUE;
}
#else
if(res >= BUFSIZE) { /* res is the desired output length */
usedRalloc = TRUE;
/* apparently some implementations count short,
<http://unixpapa.com/incnote/stdio.html>
so add some margin here */
b = R_alloc(res + 101, sizeof(char));
vsnprintf(b, res+100, format, ap);
} else if(res < 0) { /* just a failure indication */
usedRalloc = TRUE;
b = R_alloc(10*BUFSIZE, sizeof(char));
res = vsnprintf(b, 10*BUFSIZE, format, ap);
if (res < 0) {
b[10*BUFSIZE - 1] = '\0';
warning(_("printing of extremely long output is truncated"));
res = 10*BUFSIZE;
}
}
#endif /* HAVE_VASPRINTF */
if(con->outconv) { /* translate the buffer */
char outbuf[BUFSIZE+1], *ob;
const char *ib = b;
size_t inb = res, onb, ires;
Rboolean again = FALSE;
size_t ninit = strlen(con->init_out);
do {
onb = BUFSIZE; /* leave space for nul */
ob = outbuf;
if(ninit) {
strcpy(ob, con->init_out);
ob += ninit; onb -= ninit; ninit = 0;
}
errno = 0;
ires = Riconv(con->outconv, &ib, &inb, &ob, &onb);
if(ires == (size_t)(-1) && errno == E2BIG) again = TRUE;
if(ires == (size_t)(-1) && errno != E2BIG)
/* is this safe? */
warning(_("invalid char string in output conversion"));
*ob = '\0';
con->write(outbuf, 1, strlen(outbuf), con);
} while(again && inb > 0); /* it seems some iconv signal -1 on
zero-length input */
} else
con->write(b, 1, res, con);
if(usedRalloc) vmaxset(vmax);
if(usedVasprintf) free(b);
return res;
}
int dummy_fgetc(Rconnection con)
{
int c;
Rboolean checkBOM = FALSE;
if(con->inconv) {
if(con->navail <= 0) {
unsigned int i, inew = 0;
char *p, *ob;
const char *ib;
size_t inb, onb, res;
if(con->EOF_signalled) return R_EOF;
if(con->inavail == -2) {
con->inavail = 0;
checkBOM = TRUE;
}
p = con->iconvbuff + con->inavail;
for(i = con->inavail; i < 25; i++) {
c = con->fgetc_internal(con);
if(c == R_EOF){ con->EOF_signalled = TRUE; break; }
*p++ = (char) c;
con->inavail++;
inew++;
}
if(inew == 0) return R_EOF;
if(checkBOM && con->inavail >= 2 &&
((int)con->iconvbuff[0] & 0xff) == 255 &&
((int)con->iconvbuff[1] & 0xff) == 254) {
con->inavail -= (short) 2;
memmove(con->iconvbuff, con->iconvbuff+2, con->inavail);
}
ib = con->iconvbuff; inb = con->inavail;
ob = con->oconvbuff; onb = 50;
errno = 0;
res = Riconv(con->inconv, &ib, &inb, &ob, &onb);
con->inavail = (short) inb;
if(res == (size_t)-1) { /* an error condition */
if(errno == EINVAL || errno == E2BIG) {
/* incomplete input char or no space in output buffer */
memmove(con->iconvbuff, ib, inb);
} else {/* EILSEQ invalid input */
warning(_("invalid input found on input connection '%s'"),
con->description);
con->inavail = 0;
con->EOF_signalled = TRUE;
}
}
con->next = con->oconvbuff;
con->navail = (short)(50 - onb);
}
con->navail--;
return *con->next++;
} else
return con->fgetc_internal(con);
}
static int null_fgetc(Rconnection con)
{
error(_("%s not enabled for this connection"), "'getc'");
return 0; /* -Wall */
}
static double null_seek(Rconnection con, double where, int origin, int rw)
{
error(_("%s not enabled for this connection"), "'seek'");
return 0.; /* -Wall */
}
static void null_truncate(Rconnection con)
{
error(_("%s not enabled for this connection"), "truncation");
}
static int null_fflush(Rconnection con)
{
return 0;
}
static size_t null_read(void *ptr, size_t size, size_t nitems,
Rconnection con)
{
error(_("%s not enabled for this connection"), "'read'");
return 0; /* -Wall */
}
static size_t null_write(const void *ptr, size_t size, size_t nitems,
Rconnection con)
{
error(_("%s not enabled for this connection"), "'write'");
return 0; /* -Wall */
}
void init_con(Rconnection new, const char *description, int enc,
const char * const mode)
{
strcpy(new->description, description);
new->enc = enc;
strncpy(new->mode, mode, 4); new->mode[4] = '\0';
new->isopen = new->incomplete = new->blocking = new->isGzcon = FALSE;
new->canread = new->canwrite = TRUE; /* in principle */
new->canseek = FALSE;
new->text = TRUE;
new->open = &null_open;
new->close = &null_close;
new->destroy = &null_destroy;
new->vfprintf = &null_vfprintf;
new->fgetc = new->fgetc_internal = &null_fgetc;
new->seek = &null_seek;
new->truncate = &null_truncate;
new->fflush = &null_fflush;
new->read = &null_read;
new->write = &null_write;
new->nPushBack = 0;
new->save = new->save2 = -1000;
new->private = NULL;
new->inconv = new->outconv = NULL;
new->UTF8out = FALSE;
/* increment id, avoid NULL */
current_id = (void *)((size_t) current_id+1);
if(!current_id) current_id = (void *) 1;
new->id = current_id;
new->ex_ptr = NULL;
}
/* ------------------- file connections --------------------- */
#ifdef Win32
# define f_seek fseeko64
# define f_tell ftello64
# define OFF_T off64_t
#elif defined(HAVE_OFF_T) && defined(HAVE_FSEEKO)
# define f_seek fseeko
# define f_tell ftello
# define OFF_T off_t
#else
# define f_seek fseek
# define f_tell ftell
# define OFF_T long
#endif
#ifdef Win32
size_t Rf_utf8towcs(wchar_t *wc, const char *s, size_t n);
#endif
typedef struct fileconn {
FILE *fp;
OFF_T rpos, wpos;
Rboolean last_was_write;
Rboolean raw;
#ifdef Win32
Rboolean anon_file;
char name[PATH_MAX+1];
#endif
} *Rfileconn;
static Rboolean file_open(Rconnection con)
{
const char *name;
FILE *fp = NULL;
Rfileconn this = con->private;
Rboolean temp = FALSE;
#ifdef HAVE_FCNTL
int fd, flags;
#endif
int mlen = (int) strlen(con->mode); // short
if(strlen(con->description) == 0) {
temp = TRUE;
name = R_tmpnam("Rf", R_TempDir);
} else name = R_ExpandFileName(con->description);
errno = 0; /* some systems require this */
if(strcmp(name, "stdin")) {
#ifdef Win32
if(con->enc == CE_UTF8) {
int n = strlen(name);
wchar_t wname[2 * (n+1)], wmode[10];
R_CheckStack();
Rf_utf8towcs(wname, name, n+1);
mbstowcs(wmode, con->mode, 10);
fp = _wfopen(wname, wmode);
} else
#endif
fp = R_fopen(name, con->mode);
} else { /* use file("stdin") to refer to the file and not the console */
#ifdef HAVE_FDOPEN
fp = fdopen(0, con->mode);
#else
warning(_("cannot open file '%s': %s"), name,
"fdopen is not supported on this platform");
#endif
}
if(!fp) {
warning(_("cannot open file '%s': %s"), name, strerror(errno));
return FALSE;
}
if(temp) {
/* This will fail on Windows, so arrange to remove in
* file_close. An alternative strategy would be to manipulate
* the underlying file handle to add FILE_SHARE_DELETE (so the
* unlink is valid) or FILE_FLAG_DELETE_ON_CLOSE. E.g. create
* via CreateFile, get an fd by _open_osfhandle and a file
* stream by fdopen. See
* e.g. http://www.codeproject.com/KB/files/handles.aspx
*/
unlink(name);
#ifdef Win32
strncpy(this->name, name, PATH_MAX);
#endif
free((char *) name); /* only free if allocated by R_tmpnam */
}
#ifdef Win32
this->anon_file = temp;
#endif
this->fp = fp;
con->isopen = TRUE;
con->canwrite = (con->mode[0] == 'w' || con->mode[0] == 'a');
con->canread = !con->canwrite;
if(mlen >= 2 && con->mode[1] == '+')
con->canread = con->canwrite = TRUE;
this->last_was_write = !con->canread;
this->rpos = 0;
if(con->canwrite) this->wpos = f_tell(fp);
if(mlen >= 2 && con->mode[mlen-1] == 'b') con->text = FALSE;
else con->text = TRUE;
con->save = -1000;
set_iconv(con);
#ifdef HAVE_FCNTL
if(!con->blocking) {
fd = fileno(fp);
flags = fcntl(fd, F_GETFL);
flags |= O_NONBLOCK;
fcntl(fd, F_SETFL, flags);
}
#endif
return TRUE;
}
static void file_close(Rconnection con)
{
Rfileconn this = con->private;
if(con->isopen && strcmp(con->description, "stdin")) fclose(this->fp);
con->isopen = FALSE;
#ifdef Win32
if(this->anon_file) unlink(this->name);
#endif
}
static int file_vfprintf(Rconnection con, const char *format, va_list ap)
{
Rfileconn this = con->private;
if(!this->last_was_write) {
this->rpos = f_tell(this->fp);
this->last_was_write = TRUE;
f_seek(this->fp, this->wpos, SEEK_SET);
}
if(con->outconv) return dummy_vfprintf(con, format, ap);
else return vfprintf(this->fp, format, ap);
}
static int file_fgetc_internal(Rconnection con)
{
Rfileconn this = con->private;
FILE *fp = this->fp;
int c;
if(this->last_was_write) {
this->wpos = f_tell(this->fp);
this->last_was_write = FALSE;
f_seek(this->fp, this->rpos, SEEK_SET);
}
c =fgetc(fp);
return feof(fp) ? R_EOF : c;
}
static double file_seek(Rconnection con, double where, int origin, int rw)
{
Rfileconn this = con->private;
FILE *fp = this->fp;
OFF_T pos;
int whence = SEEK_SET;
/* make sure both positions are set */
pos = f_tell(fp);
if(this->last_was_write) this->wpos = pos; else this->rpos = pos;
if(rw == 1) {
if(!con->canread) error(_("connection is not open for reading"));
pos = this->rpos;
this->last_was_write = FALSE;
}
if(rw == 2) {
if(!con->canwrite) error(_("connection is not open for writing"));
pos = this->wpos;
this->last_was_write = TRUE;
}
if(ISNA(where)) return (double) pos;
switch(origin) {
case 2: whence = SEEK_CUR; break;
case 3: whence = SEEK_END;
//#ifdef Win32
/* work around a bug in MinGW runtime 3.8 fseeko64, PR#7896
seems no longer to be needed */
// if(con->canwrite) fflush(fp);
//#endif
break;
default: whence = SEEK_SET;
}
f_seek(fp, (OFF_T) where, whence);
if(this->last_was_write) this->wpos = f_tell(this->fp);
else this->rpos = f_tell(this->fp);
return (double) pos;
}
static void file_truncate(Rconnection con)
{
Rfileconn this = con->private;
#ifdef HAVE_FTRUNCATE
FILE *fp = this->fp;
int fd = fileno(fp);
/* ftruncate64 is in Mingw-64 trunk, but not in current toolkit */
# ifdef W64_to_come
off64_t size = lseek64(fd, 0, SEEK_CUR);
# else
OFF_T size = lseek(fd, 0, SEEK_CUR);
# endif
#endif
if(!con->isopen || !con->canwrite)
error(_("can only truncate connections open for writing"));
if(!this->last_was_write) this->rpos = f_tell(this->fp);
#ifdef W64_to_come
if(ftruncate64(fd, size)) error(_("file truncation failed"));
#elif defined(HAVE_FTRUNCATE)
if(ftruncate(fd, size)) error(_("file truncation failed"));
#else
error(_("file truncation unavailable on this platform"));
#endif
this->last_was_write = TRUE;
this->wpos = f_tell(this->fp);
}
static int file_fflush(Rconnection con)
{
FILE *fp = ((Rfileconn)(con->private))->fp;
return fflush(fp);
}
static size_t file_read(void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rfileconn this = con->private;
FILE *fp = this->fp;
if(this->last_was_write) {
this->wpos = f_tell(this->fp);
this->last_was_write = FALSE;
f_seek(this->fp, this->rpos, SEEK_SET);
}
return fread(ptr, size, nitems, fp);
}
static size_t file_write(const void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rfileconn this = con->private;
FILE *fp = this->fp;
if(!this->last_was_write) {
this->rpos = f_tell(this->fp);
this->last_was_write = TRUE;
f_seek(this->fp, this->wpos, SEEK_SET);
}
return fwrite(ptr, size, nitems, fp);
}
static Rconnection newfile(const char *description, int enc, const char *mode,
int raw)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of file connection failed"));
new->class = (char *) malloc(strlen("file") + 1);
if(!new->class) {
free(new);
error(_("allocation of file connection failed"));
}
strcpy(new->class, "file");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of file connection failed"));
}
init_con(new, description, enc, mode);
new->open = &file_open;
new->close = &file_close;
new->vfprintf = &file_vfprintf;
new->fgetc_internal = &file_fgetc_internal;
new->fgetc = &dummy_fgetc;
new->seek = &file_seek;
new->truncate = &file_truncate;
new->fflush = &file_fflush;
new->read = &file_read;
new->write = &file_write;
new->canseek = (raw == 0);
new->private = (void *) malloc(sizeof(struct fileconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of file connection failed"));
}
((Rfileconn)(new->private))->raw = raw;
return new;
}
/* file() is now implemented as an op of do_url */
/* ------------------- fifo connections --------------------- */
#if defined(HAVE_MKFIFO) && defined(HAVE_FCNTL_H)
#ifdef HAVE_SYS_TYPES_H
# include <sys/types.h>
#endif
#ifdef HAVE_SYS_STAT_H
# include <sys/stat.h>
#endif
# include <errno.h>
typedef struct fifoconn {
int fd;
} *Rfifoconn;
static Rboolean fifo_open(Rconnection con)
{
const char *name;
Rfifoconn this = con->private;
int fd, flags, res;
int mlen = (int) strlen(con->mode); // short
struct stat sb;
Rboolean temp = FALSE;
if(strlen(con->description) == 0) {
temp = TRUE;
name = R_tmpnam("Rf", R_TempDir);
} else name = R_ExpandFileName(con->description);
con->canwrite = (con->mode[0] == 'w' || con->mode[0] == 'a');
con->canread = !con->canwrite;
if(mlen >= 2 && con->mode[1] == '+') con->canread = TRUE;
/* if we are to write, create the fifo if needed */
if(con->canwrite) {
res = stat(name, &sb);
if(res) { /* error, does not exist? */
errno = 0;
res = mkfifo(name, 00644);
if(res) {
warning(_("cannot create fifo '%s', reason '%s'"), name,
strerror(errno));
}
if(res) return FALSE;
} else {
if(!(sb.st_mode & S_IFIFO)) {
warning(_("'%s' exists but is not a fifo"), name);
return FALSE;
}
}
}
if(con->canread && con->canwrite) flags = O_RDWR;
else if(con->canread) flags = O_RDONLY;
else flags = O_WRONLY;
if(!con->blocking) flags |= O_NONBLOCK;
if(con->mode[0] == 'a') flags |= O_APPEND;
errno = 0; /* precaution */
fd = open(name, flags);
if(fd < 0) {
if(errno == ENXIO) warning(_("fifo '%s' is not ready"), name);
else warning(_("cannot open fifo '%s'"), name);
return FALSE;
}
if(temp) {
unlink(name);
free((char *) name); /* allocated by R_tmpnam */
}
this->fd = fd;
con->isopen = TRUE;
if(mlen >= 2 && con->mode[mlen-1] == 'b') con->text = FALSE;
else con->text = TRUE;
set_iconv(con);
con->save = -1000;
return TRUE;
}
static void fifo_close(Rconnection con)
{
close(((Rfifoconn)(con->private))->fd);
con->isopen = FALSE;
}
static int fifo_fgetc_internal(Rconnection con)
{
Rfifoconn this = con->private;
unsigned char c;
ssize_t n;
n = read(this->fd, (char *)&c, 1);
return (n == 1) ? c : R_EOF;
}
static size_t fifo_read(void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rfifoconn this = con->private;
/* uses 'size_t' for len */
if ((double) size * (double) nitems > SSIZE_MAX)
error(_("too large a block specified"));
return read(this->fd, ptr, size * nitems)/size;
}
static size_t fifo_write(const void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rfifoconn this = con->private;
/* uses 'size_t' for len */
if ((double) size * (double) nitems > SSIZE_MAX)
error(_("too large a block specified"));
return write(this->fd, ptr, size * nitems)/size;
}
static Rconnection newfifo(const char *description, const char *mode)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of fifo connection failed"));
new->class = (char *) malloc(strlen("fifo") + 1);
if(!new->class) {
free(new);
error(_("allocation of fifo connection failed"));
}
strcpy(new->class, "fifo");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of fifo connection failed"));
}
init_con(new, description, CE_NATIVE, mode);
new->open = &fifo_open;
new->close = &fifo_close;
new->vfprintf = &dummy_vfprintf;
new->fgetc_internal = &fifo_fgetc_internal;
new->fgetc = &dummy_fgetc;
new->seek = &null_seek;
new->truncate = &null_truncate;
new->fflush = &null_fflush;
new->read = &fifo_read;
new->write = &fifo_write;
new->private = (void *) malloc(sizeof(struct fifoconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of fifo connection failed"));
}
return new;
}
#endif
SEXP attribute_hidden do_fifo(SEXP call, SEXP op, SEXP args, SEXP env)
{
#if defined(HAVE_MKFIFO) && defined(HAVE_FCNTL_H)
SEXP sfile, sopen, ans, class, enc;
const char *file, *open;
int ncon, block;
Rconnection con = NULL;
checkArity(op, args);
sfile = CAR(args);
if(!isString(sfile) || length(sfile) != 1)
error(_("invalid '%s' argument"), "description");
if(length(sfile) > 1)
warning(_("only first element of 'description' argument used"));
file = translateChar(STRING_ELT(sfile, 0)); /* for now, like fopen */
sopen = CADR(args);
if(!isString(sopen) || length(sopen) != 1)
error(_("invalid '%s' argument"), "open");
block = asLogical(CADDR(args));
if(block == NA_LOGICAL)
error(_("invalid '%s' argument"), "block");
enc = CADDDR(args);
if(!isString(enc) || length(enc) != 1 ||
strlen(CHAR(STRING_ELT(enc, 0))) > 100) /* ASCII */
error(_("invalid '%s' argument"), "encoding");
open = CHAR(STRING_ELT(sopen, 0)); /* ASCII */
if(strlen(file) == 0) {
if(!strlen(open)) open ="w+";
if(strcmp(open, "w+") != 0 && strcmp(open, "w+b") != 0) {
open ="w+";
warning(_("fifo(\"\") only supports open = \"w+\" and open = \"w+b\": using the former"));
}
}
ncon = NextConnection();
con = Connections[ncon] = newfifo(file, strlen(open) ? open : "r");
con->blocking = block;
strncpy(con->encname, CHAR(STRING_ELT(enc, 0)), 100); /* ASCII */
con->ex_ptr = PROTECT(R_MakeExternalPtr(con->id, install("connection"), R_NilValue));
/* open it if desired */
if(strlen(open)) {
Rboolean success = con->open(con);
if(!success) {
con_destroy(ncon);
error(_("cannot open the connection"));
}
}
PROTECT(ans = ScalarInteger(ncon));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar("fifo"));
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
setAttrib(ans, R_ConnIdSymbol, con->ex_ptr);
R_RegisterCFinalizerEx(con->ex_ptr, conFinalizer, FALSE);
UNPROTECT(3);
return ans;
#else
error(_("fifo connections are not available on this system"));
return R_NilValue; /* -Wall */
#endif
}
/* ------------------- pipe connections --------------------- */
static Rboolean pipe_open(Rconnection con)
{
FILE *fp;
char mode[3];
#ifdef Win32
strncpy(mode, con->mode, 2);
mode[2] = '\0';
#else
mode[0] = con->mode[0];
mode[1] = '\0';
#endif
errno = 0;
#ifdef Win32
if(con->enc == CE_UTF8) {
int n = strlen(con->description);
wchar_t wname[2 * (n+1)], wmode[10];
R_CheckStack();
Rf_utf8towcs(wname, con->description, n+1);
mbstowcs(wmode, con->mode, 10);
fp = _wpopen(wname, wmode);
} else
#endif
fp = R_popen(con->description, mode);
if(!fp) {
warning(_("cannot open pipe() cmd '%s': %s"), con->description,
strerror(errno));
return FALSE;
}
((Rfileconn)(con->private))->fp = fp;
con->isopen = TRUE;
con->canwrite = (con->mode[0] == 'w');
con->canread = !con->canwrite;
if(strlen(con->mode) >= 2 && con->mode[1] == 'b') con->text = FALSE;
else con->text = TRUE;
set_iconv(con);
con->save = -1000;
return TRUE;
}
static void pipe_close(Rconnection con)
{
pclose(((Rfileconn)(con->private))->fp);
con->isopen = FALSE;
}
static Rconnection
newpipe(const char *description, int ienc, const char *mode)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of pipe connection failed"));
new->class = (char *) malloc(strlen("pipe") + 1);
if(!new->class) {
free(new);
error(_("allocation of pipe connection failed"));
}
strcpy(new->class, "pipe");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of pipe connection failed"));
}
init_con(new, description, ienc, mode);
new->open = &pipe_open;
new->close = &pipe_close;
new->vfprintf = &file_vfprintf;
new->fgetc_internal = &file_fgetc_internal;
new->fgetc = &dummy_fgetc;
new->fflush = &file_fflush;
new->read = &file_read;
new->write = &file_write;
new->private = (void *) malloc(sizeof(struct fileconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of pipe connection failed"));
}
return new;
}
#ifdef Win32
extern Rconnection
newWpipe(const char *description, int enc, const char *mode);
#endif
SEXP attribute_hidden do_pipe(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP scmd, sopen, ans, class, enc;
const char *file, *open;
int ncon;
cetype_t ienc = CE_NATIVE;
Rconnection con = NULL;
checkArity(op, args);
scmd = CAR(args);
if(!isString(scmd) || length(scmd) != 1)
error(_("invalid '%s' argument"), "description");
if(length(scmd) > 1)
warning(_("only first element of 'description' argument used"));
#ifdef Win32
if( !IS_ASCII(STRING_ELT(scmd, 0)) ) {
ienc = CE_UTF8;
file = translateCharUTF8(STRING_ELT(scmd, 0));
} else {
ienc = CE_NATIVE;
file = translateChar(STRING_ELT(scmd, 0));
}
#else
file = translateChar(STRING_ELT(scmd, 0));
#endif
sopen = CADR(args);
if(!isString(sopen) || length(sopen) != 1)
error(_("invalid '%s' argument"), "open");
open = CHAR(STRING_ELT(sopen, 0)); /* ASCII */
enc = CADDR(args);
if(!isString(enc) || length(enc) != 1 ||
strlen(CHAR(STRING_ELT(enc, 0))) > 100) /* ASCII */
error(_("invalid '%s' argument"), "encoding");
ncon = NextConnection();
#ifdef Win32
if(CharacterMode != RTerm)
con = newWpipe(file, ienc, strlen(open) ? open : "r");
else
#endif
con = newpipe(file, ienc, strlen(open) ? open : "r");
Connections[ncon] = con;
strncpy(con->encname, CHAR(STRING_ELT(enc, 0)), 100); /* ASCII */
con->ex_ptr = PROTECT(R_MakeExternalPtr(con->id, install("connection"), R_NilValue));
/* open it if desired */
if(strlen(open)) {
Rboolean success = con->open(con);
if(!success) {
con_destroy(ncon);
error(_("cannot open the connection"));
}
}
PROTECT(ans = ScalarInteger(ncon));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar("pipe"));
#ifdef Win32
if(CharacterMode != RTerm)
SET_STRING_ELT(class, 0, mkChar("pipeWin32"));
#endif
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
setAttrib(ans, R_ConnIdSymbol, con->ex_ptr);
R_RegisterCFinalizerEx(con->ex_ptr, conFinalizer, FALSE);
UNPROTECT(3);
return ans;
}
/* ------------------- [bgx]zipped file connections --------------------- */
#include "gzio.h"
/* needs to be declared before con_close1 */
typedef struct gzconn {
Rconnection con;
int cp; /* compression level */
z_stream s;
int z_err, z_eof;
uLong crc;
Byte buffer[Z_BUFSIZE];
int nsaved;
char saved[2];
Rboolean allow;
} *Rgzconn;
typedef struct gzfileconn {
void *fp;
int compress;
} *Rgzfileconn;
static Rboolean gzfile_open(Rconnection con)
{
gzFile fp;
char mode[6];
Rgzfileconn gzcon = con->private;
strcpy(mode, con->mode);
/* Must open as binary */
if(strchr(con->mode, 'w')) sprintf(mode, "wb%1d", gzcon->compress);
else if (con->mode[0] == 'a') sprintf(mode, "ab%1d", gzcon->compress);
else strcpy(mode, "rb");
errno = 0; /* precaution */
fp = R_gzopen(R_ExpandFileName(con->description), mode);
if(!fp) {
warning(_("cannot open compressed file '%s', probable reason '%s'"),
R_ExpandFileName(con->description), strerror(errno));
return FALSE;
}
((Rgzfileconn)(con->private))->fp = fp;
con->isopen = TRUE;
con->canwrite = (con->mode[0] == 'w' || con->mode[0] == 'a');
con->canread = !con->canwrite;
con->text = strchr(con->mode, 'b') ? FALSE : TRUE;
set_iconv(con);
con->save = -1000;
return TRUE;
}
static void gzfile_close(Rconnection con)
{
R_gzclose(((Rgzfileconn)(con->private))->fp);
con->isopen = FALSE;
}
static int gzfile_fgetc_internal(Rconnection con)
{
gzFile fp = ((Rgzfileconn)(con->private))->fp;
unsigned char c;
return R_gzread(fp, &c, 1) == 1 ? c : R_EOF;
}
/* This can only seek forwards when writing (when it writes nul bytes).
When reading, it either seeks forwards of rewinds and reads again */
static double gzfile_seek(Rconnection con, double where, int origin, int rw)
{
gzFile fp = ((Rgzfileconn)(con->private))->fp;
Rz_off_t pos = R_gztell(fp);
int res, whence = SEEK_SET;
if (ISNA(where)) return (double) pos;
switch(origin) {
case 2: whence = SEEK_CUR; break;
case 3: error(_("whence = \"end\" is not implemented for gzfile connections"));
default: whence = SEEK_SET;
}
res = R_gzseek(fp, (z_off_t) where, whence);
if(res == -1)
warning(_("seek on a gzfile connection returned an internal error"));
return (double) pos;
}
static int gzfile_fflush(Rconnection con)
{
return 0;
}
static size_t gzfile_read(void *ptr, size_t size, size_t nitems,
Rconnection con)
{
gzFile fp = ((Rgzfileconn)(con->private))->fp;
/* uses 'unsigned' for len */
if ((double) size * (double) nitems > UINT_MAX)
error(_("too large a block specified"));
return R_gzread(fp, ptr, (unsigned int)(size*nitems))/size;
}
static size_t gzfile_write(const void *ptr, size_t size, size_t nitems,
Rconnection con)
{
gzFile fp = ((Rgzfileconn)(con->private))->fp;
/* uses 'unsigned' for len */
if ((double) size * (double) nitems > UINT_MAX)
error(_("too large a block specified"));
return R_gzwrite(fp, (voidp)ptr, (unsigned int)(size*nitems))/size;
}
static Rconnection newgzfile(const char *description, const char *mode,
int compress)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of gzfile connection failed"));
new->class = (char *) malloc(strlen("gzfile") + 1);
if(!new->class) {
free(new);
error(_("allocation of gzfile connection failed"));
}
strcpy(new->class, "gzfile");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of gzfile connection failed"));
}
init_con(new, description, CE_NATIVE, mode);
new->canseek = TRUE;
new->open = &gzfile_open;
new->close = &gzfile_close;
new->vfprintf = &dummy_vfprintf;
new->fgetc_internal = &gzfile_fgetc_internal;
new->fgetc = &dummy_fgetc;
new->seek = &gzfile_seek;
new->fflush = &gzfile_fflush;
new->read = &gzfile_read;
new->write = &gzfile_write;
new->private = (void *) malloc(sizeof(struct gzfileconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of gzfile connection failed"));
}
((Rgzfileconn)new->private)->compress = compress;
return new;
}
#include <bzlib.h>
typedef struct bzfileconn {
FILE *fp;
BZFILE *bfp;
int compress;
} *Rbzfileconn;
static Rboolean bzfile_open(Rconnection con)
{
Rbzfileconn bz = (Rbzfileconn) con->private;
FILE* fp;
BZFILE* bfp;
int bzerror;
char mode[] = "rb";
con->canwrite = (con->mode[0] == 'w' || con->mode[0] == 'a');
con->canread = !con->canwrite;
/* regardless of the R view of the file, the file must be opened in
binary mode where it matters */
mode[0] = con->mode[0];
errno = 0; /* precaution */
fp = R_fopen(R_ExpandFileName(con->description), mode);
if(!fp) {
warning(_("cannot open bzip2-ed file '%s', probable reason '%s'"),
R_ExpandFileName(con->description), strerror(errno));
return FALSE;
}
if(con->canread) {
bfp = BZ2_bzReadOpen(&bzerror, fp, 0, 0, NULL, 0);
if(bzerror != BZ_OK) {
BZ2_bzReadClose(&bzerror, bfp);
fclose(fp);
warning(_("file '%s' appears not to be compressed by bzip2"),
R_ExpandFileName(con->description));
return FALSE;
}
} else {
bfp = BZ2_bzWriteOpen(&bzerror, fp, bz->compress, 0, 0);
if(bzerror != BZ_OK) {
BZ2_bzWriteClose(&bzerror, bfp, 0, NULL, NULL);
fclose(fp);
warning(_("initializing bzip2 compression for file '%s' failed"),
R_ExpandFileName(con->description));
return FALSE;
}
}
bz->fp = fp;
bz->bfp = bfp;
con->isopen = TRUE;
con->text = strchr(con->mode, 'b') ? FALSE : TRUE;
set_iconv(con);
con->save = -1000;
return TRUE;
}
static void bzfile_close(Rconnection con)
{
int bzerror;
Rbzfileconn bz = con->private;
if(con->canread)
BZ2_bzReadClose(&bzerror, bz->bfp);
else
BZ2_bzWriteClose(&bzerror, bz->bfp, 0, NULL, NULL);
fclose(bz->fp);
con->isopen = FALSE;
}
static size_t bzfile_read(void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rbzfileconn bz = con->private;
int nread = 0, nleft;
int bzerror;
/* BZ2 uses 'int' for len */
if ((double) size * (double) nitems > INT_MAX)
error(_("too large a block specified"));
nleft = (int)(size * nitems);
/* we try to fill the buffer, because fgetc can interact with the stream boundaries
resulting in truncated text streams while binary streams work fine */
while (nleft > 0) {
/* Need a cast as 'nread' needs to be interpreted in bytes */
int n = BZ2_bzRead(&bzerror, bz->bfp, (char *)ptr + nread, nleft);
if (bzerror == BZ_STREAM_END) { /* this could mean multiple streams so we need to check */
char *unused, *next_unused = NULL;
int nUnused;
BZ2_bzReadGetUnused(&bzerror, bz->bfp, (void**) &unused, &nUnused);
if (bzerror == BZ_OK) {
if (nUnused > 0) { /* unused bytes present - need to retain them */
/* given that this should be rare I don't want to add that overhead
to the entire bz structure so we allocate memory temporarily */
next_unused = (char*) malloc(nUnused);
if (!next_unused)
error(_("allocation of overflow buffer for bzfile failed"));
memcpy(next_unused, unused, nUnused);
}
if (nUnused > 0 || !feof(bz->fp)) {
BZ2_bzReadClose(&bzerror, bz->bfp);
bz->bfp = BZ2_bzReadOpen(&bzerror, bz->fp, 0, 0, next_unused, nUnused);
if(bzerror != BZ_OK)
warning(_("file '%s' has trailing content that appears not to be compressed by bzip2"),
R_ExpandFileName(con->description));
}
if (next_unused) free(next_unused);
}
} else if (bzerror != BZ_OK) {
/* bzlib docs say in this case n is invalid - but historically
we still used n in that case, so I keep it for now */
nread += n;
break;
}
nread += n;
nleft -= n;
}
return nread / size;
}
static int bzfile_fgetc_internal(Rconnection con)
{
char buf[1];
size_t size;
size = bzfile_read(buf, 1, 1, con);
return (size < 1) ? R_EOF : (buf[0] % 256);
}
static size_t bzfile_write(const void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rbzfileconn bz = con->private;
int bzerror;
/* uses 'int' for len */
if ((double) size * (double) nitems > INT_MAX)
error(_("too large a block specified"));
BZ2_bzWrite(&bzerror, bz->bfp, (voidp) ptr, (int)(size*nitems));
if(bzerror != BZ_OK) return 0;
else return nitems;
}
static Rconnection newbzfile(const char *description, const char *mode,
int compress)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of bzfile connection failed"));
new->class = (char *) malloc(strlen("bzfile") + 1);
if(!new->class) {
free(new);
error(_("allocation of bzfile connection failed"));
}
strcpy(new->class, "bzfile");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of bzfile connection failed"));
}
init_con(new, description, CE_NATIVE, mode);
new->canseek = FALSE;
new->open = &bzfile_open;
new->close = &bzfile_close;
new->vfprintf = &dummy_vfprintf;
new->fgetc_internal = &bzfile_fgetc_internal;
new->fgetc = &dummy_fgetc;
new->seek = &null_seek;
new->fflush = &null_fflush;
new->read = &bzfile_read;
new->write = &bzfile_write;
new->private = (void *) malloc(sizeof(struct bzfileconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of bzfile connection failed"));
}
((Rbzfileconn)new->private)->compress = compress;
return new;
}
#include <lzma.h>
typedef struct xzfileconn {
FILE *fp;
lzma_stream stream;
lzma_action action;
int compress;
int type;
lzma_filter filters[2];
lzma_options_lzma opt_lzma;
unsigned char buf[BUFSIZE];
} *Rxzfileconn;
static Rboolean xzfile_open(Rconnection con)
{
Rxzfileconn xz = con->private;
lzma_ret ret;
char mode[] = "rb";
con->canwrite = (con->mode[0] == 'w' || con->mode[0] == 'a');
con->canread = !con->canwrite;
/* regardless of the R view of the file, the file must be opened in
binary mode where it matters */
mode[0] = con->mode[0];
errno = 0; /* precaution */
xz->fp = R_fopen(R_ExpandFileName(con->description), mode);
if(!xz->fp) {
warning(_("cannot open compressed file '%s', probable reason '%s'"),
R_ExpandFileName(con->description), strerror(errno));
return FALSE;
}
if(con->canread) {
xz->action = LZMA_RUN;
/* probably about 80Mb is required, but 512Mb seems OK as a limit */
if (xz->type == 1)
ret = lzma_alone_decoder(&xz->stream, 536870912);
else
ret = lzma_stream_decoder(&xz->stream, 536870912,
LZMA_CONCATENATED);
if (ret != LZMA_OK) {
warning(_("cannot initialize lzma decoder, error %d"), ret);
return FALSE;
}
xz->stream.avail_in = 0;
} else {
lzma_stream *strm = &xz->stream;
uint32_t preset_number = abs(xz->compress);
if(xz->compress < 0) preset_number |= LZMA_PRESET_EXTREME;
if(lzma_lzma_preset(&xz->opt_lzma, preset_number))
error("problem setting presets");
xz->filters[0].id = LZMA_FILTER_LZMA2;
xz->filters[0].options = &(xz->opt_lzma);
xz->filters[1].id = LZMA_VLI_UNKNOWN;
ret = lzma_stream_encoder(strm, xz->filters, LZMA_CHECK_CRC32);
if (ret != LZMA_OK) {
warning(_("cannot initialize lzma encoder, error %d"), ret);
return FALSE;
}
}
con->isopen = TRUE;
con->text = strchr(con->mode, 'b') ? FALSE : TRUE;
set_iconv(con);
con->save = -1000;
return TRUE;
}
static void xzfile_close(Rconnection con)
{
Rxzfileconn xz = con->private;
if(con->canwrite) {
lzma_ret ret;
lzma_stream *strm = &(xz->stream);
size_t nout, res;
unsigned char buf[BUFSIZE];
while(1) {
strm->avail_out = BUFSIZE; strm->next_out = buf;
ret = lzma_code(strm, LZMA_FINISH);
nout = BUFSIZE - strm->avail_out;
res = fwrite(buf, 1, nout, xz->fp);
if (res != nout) error("fwrite error");
if (ret != LZMA_OK) break;
}
}
lzma_end(&(xz->stream));
fclose(xz->fp);
con->isopen = FALSE;
}
static size_t xzfile_read(void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rxzfileconn xz = con->private;
lzma_stream *strm = &(xz->stream);
lzma_ret ret;
size_t s = size*nitems, have, given = 0;
unsigned char *p = ptr;
if (!s) return 0;
while(1) {
if (strm->avail_in == 0 && xz->action != LZMA_FINISH) {
strm->next_in = xz->buf;
strm->avail_in = fread(xz->buf, 1, BUFSIZ, xz->fp);
if (feof(xz->fp)) xz->action = LZMA_FINISH;
}
strm->avail_out = s; strm->next_out = p;
ret = lzma_code(strm, xz->action);
have = s - strm->avail_out; given += have;
//printf("available: %d, ready: %d/%d\n", strm->avail_in, given, s);
if (ret != LZMA_OK) {
if (ret != LZMA_STREAM_END) {
switch(ret) {
case LZMA_MEM_ERROR:
case LZMA_MEMLIMIT_ERROR:
warning("lzma decoder needed more memory");
break;
case LZMA_FORMAT_ERROR:
warning("lzma decoder format error");
break;
case LZMA_DATA_ERROR:
warning("lzma decoder corrupt data");
break;
default:
warning("lzma decoding result %d", ret);
}
}
return given/size;
}
s -= have;
if (!s) return nitems;
p += have;
}
}
static int xzfile_fgetc_internal(Rconnection con)
{
char buf[1];
size_t size = xzfile_read(buf, 1, 1, con);
return (size < 1) ? R_EOF : (buf[0] % 256);
}
static size_t xzfile_write(const void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rxzfileconn xz = con->private;
lzma_stream *strm = &(xz->stream);
lzma_ret ret;
size_t s = size*nitems, nout, res;
const unsigned char *p = ptr;
unsigned char buf[BUFSIZE];
if (!s) return 0;
strm->avail_in = s;
strm->next_in = p;
while(1) {
strm->avail_out = BUFSIZE; strm->next_out = buf;
ret = lzma_code(strm, LZMA_RUN);
if (ret > 1) {
switch(ret) {
case LZMA_MEM_ERROR:
warning("lzma encoder needed more memory");
break;
default:
warning("lzma encoding result %d", ret);
}
return 0;
}
nout = BUFSIZE - strm->avail_out;
res = fwrite(buf, 1, nout, xz->fp);
if (res != nout) error("fwrite error");
if (strm->avail_in == 0) return nitems;
}
}
static Rconnection
newxzfile(const char *description, const char *mode, int type, int compress)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of xzfile connection failed"));
new->class = (char *) malloc(strlen("xzfile") + 1);
if(!new->class) {
free(new);
error(_("allocation of xzfile connection failed"));
}
strcpy(new->class, "xzfile");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of xzfile connection failed"));
}
init_con(new, description, CE_NATIVE, mode);
new->canseek = FALSE;
new->open = &xzfile_open;
new->close = &xzfile_close;
new->vfprintf = &dummy_vfprintf;
new->fgetc_internal = &xzfile_fgetc_internal;
new->fgetc = &dummy_fgetc;
new->seek = &null_seek;
new->fflush = &null_fflush;
new->read = &xzfile_read;
new->write = &xzfile_write;
new->private = (void *) malloc(sizeof(struct xzfileconn));
memset(new->private, 0, sizeof(struct xzfileconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of xzfile connection failed"));
}
((Rxzfileconn) new->private)->type = type;
((Rxzfileconn) new->private)->compress = compress;
return new;
}
/* op 0 is gzfile, 1 is bzfile, 2 is xv/lzma */
SEXP attribute_hidden do_gzfile(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile, sopen, ans, class, enc;
const char *file, *open;
int ncon, compress = 9;
Rconnection con = NULL;
int type = PRIMVAL(op);
int subtype = 0;
checkArity(op, args);
sfile = CAR(args);
if(!isString(sfile) || length(sfile) != 1)
error(_("invalid '%s' argument"), "description");
if(length(sfile) > 1)
warning(_("only first element of 'description' argument used"));
file = translateChar(STRING_ELT(sfile, 0));
sopen = CADR(args);
if(!isString(sopen) || length(sopen) != 1)
error(_("invalid '%s' argument"), "open");
enc = CADDR(args);
if(!isString(enc) || length(enc) != 1 ||
strlen(CHAR(STRING_ELT(enc, 0))) > 100) /* ASCII */
error(_("invalid '%s' argument"), "encoding");
if(type < 2) {
compress = asInteger(CADDDR(args));
if(compress == NA_LOGICAL || compress < 0 || compress > 9)
error(_("invalid '%s' argument"), "compress");
}
if(type == 2) {
compress = asInteger(CADDDR(args));
if(compress == NA_LOGICAL || abs(compress) > 9)
error(_("invalid '%s' argument"), "compress");
}
open = CHAR(STRING_ELT(sopen, 0)); /* ASCII */
if (type == 0 && (!open[0] || open[0] == 'r')) {
/* check magic no */
FILE *fp = fopen(R_ExpandFileName(file), "rb");
char buf[7];
if (fp) {
size_t res;
memset(buf, 0, 7); res = fread(buf, 5, 1, fp); fclose(fp);
if(res == 1) {
if(!strncmp(buf, "BZh", 3)) type = 1;
if((buf[0] == '\xFD') && !strncmp(buf+1, "7zXZ", 4)) type = 2;
if((buf[0] == '\xFF') && !strncmp(buf+1, "LZMA", 4)) {
type = 2; subtype = 1;
}
if(!memcmp(buf, "]\0\0\200\0", 5)) {
type = 2; subtype = 1;
}
if((buf[0] == '\x89') && !strncmp(buf+1, "LZO", 3))
error(_("this is a %s-compressed file which this build of R does not support"), "lzop");
}
}
}
switch(type) {
case 0:
con = newgzfile(file, strlen(open) ? open : "rb", compress);
break;
case 1:
con = newbzfile(file, strlen(open) ? open : "rb", compress);
break;
case 2:
con = newxzfile(file, strlen(open) ? open : "rb", subtype, compress);
break;
}
ncon = NextConnection();
Connections[ncon] = con;
strncpy(con->encname, CHAR(STRING_ELT(enc, 0)), 100); /* ASCII */
/* see the comment in do_url */
if (con->encname[0] && !streql(con->encname, "native.enc"))
con->canseek = 0;
con->ex_ptr = PROTECT(R_MakeExternalPtr(con->id, install("connection"), R_NilValue));
/* open it if desired */
if(strlen(open)) {
Rboolean success = con->open(con);
if(!success) {
con_destroy(ncon);
error(_("cannot open the connection"));
}
}
PROTECT(ans = ScalarInteger(ncon));
PROTECT(class = allocVector(STRSXP, 2));
switch(type) {
case 0:
SET_STRING_ELT(class, 0, mkChar("gzfile"));
break;
case 1:
SET_STRING_ELT(class, 0, mkChar("bzfile"));
break;
case 2:
SET_STRING_ELT(class, 0, mkChar("xzfile"));
break;
}
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
setAttrib(ans, R_ConnIdSymbol, con->ex_ptr);
R_RegisterCFinalizerEx(con->ex_ptr, conFinalizer, FALSE);
UNPROTECT(3);
return ans;
}
/* ------------------- clipboard connections --------------------- */
#ifdef Win32
# define WIN32_LEAN_AND_MEAN 1
#include <windows.h>
extern int GA_clipboardhastext(void); /* from ga.h */
#endif
#ifdef Unix
Rboolean R_ReadClipboard(Rclpconn clpcon, char *type);
#endif
static Rboolean clp_open(Rconnection con)
{
Rclpconn this = con->private;
con->isopen = TRUE;
con->canwrite = (con->mode[0] == 'w' || con->mode[0] == 'a');
con->canread = !con->canwrite;
this->pos = 0;
if(con->canread) {
/* copy the clipboard contents now */
#ifdef Win32
HGLOBAL hglb;
char *pc;
if(GA_clipboardhastext() &&
OpenClipboard(NULL) &&
(hglb = GetClipboardData(CF_TEXT)) &&
(pc = (char *)GlobalLock(hglb))) {
int len = (int) strlen(pc); // will be fairly small
this->buff = (char *)malloc(len + 1);
this->last = this->len = len;
if(this->buff) {
strcpy(this->buff, pc);
GlobalUnlock(hglb);
CloseClipboard();
} else {
GlobalUnlock(hglb);
CloseClipboard();
this->buff = NULL; this->last = this->len = 0;
warning(_("memory allocation to copy clipboard failed"));
return FALSE;
}
} else {
this->buff = NULL; this->last = this->len = 0;
warning(_("clipboard cannot be opened or contains no text"));
return FALSE;
}
#else
Rboolean res = R_ReadClipboard(this, con->description);
if(!res) return FALSE;
#endif
} else {
int len = (this->sizeKB)*1024;
this->buff = (char *) malloc(len + 1);
if(!this->buff) {
warning(_("memory allocation to open clipboard failed"));
return FALSE;
}
this->len = len;
this->last = 0;
}
con->text = TRUE;
set_iconv(con);
con->save = -1000;
this->warned = FALSE;
return TRUE;
}
static void clp_writeout(Rconnection con)
{
#ifdef Win32
Rclpconn this = con->private;
HGLOBAL hglb;
char *s, *p;
if ( (hglb = GlobalAlloc(GHND, this->len)) &&
(s = (char *)GlobalLock(hglb)) ) {
p = this->buff;
while(p < this->buff + this->pos) *s++ = *p++;
*s = '\0';
GlobalUnlock(hglb);
if (!OpenClipboard(NULL) || !EmptyClipboard()) {
warning(_("unable to open the clipboard"));
GlobalFree(hglb);
} else {
if(!SetClipboardData(CF_TEXT, hglb)) {
warning(_("unable to write to the clipboard"));
GlobalFree(hglb);
}
CloseClipboard();
}
}
#endif
}
static void clp_close(Rconnection con)
{
Rclpconn this = con->private;
con->isopen = FALSE;
if(con->canwrite)
clp_writeout(con);
if(this-> buff) free(this->buff);
}
static int clp_fgetc_internal(Rconnection con)
{
Rclpconn this = con->private;
if (this->pos >= this->len) return R_EOF;
return this->buff[this->pos++];
}
static double clp_seek(Rconnection con, double where, int origin, int rw)
{
Rclpconn this = con->private;
int newpos, oldpos = this->pos;
if(ISNA(where)) return oldpos;
switch(origin) {
case 2: newpos = this->pos + (int) where; break;
case 3: newpos = this->last + (int) where; break;
default: newpos = (int) where;
}
if(newpos < 0 || newpos >= this->last)
error(_("attempt to seek outside the range of the clipboard"));
else this->pos = newpos;
return (double) oldpos;
}
static void clp_truncate(Rconnection con)
{
Rclpconn this = con->private;
if(!con->isopen || !con->canwrite)
error(_("can only truncate connections open for writing"));
this->last = this->pos;
}
static int clp_fflush(Rconnection con)
{
if(!con->isopen || !con->canwrite) return 1;
clp_writeout(con);
return 0;
}
static size_t clp_read(void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rclpconn this = con->private;
int available = this->len - this->pos, request = (int)(size*nitems), used;
if ((double) size * (double) nitems > INT_MAX)
error(_("too large a block specified"));
used = (request < available) ? request : available;
strncpy(ptr, this->buff, used);
this->pos += used;
return (size_t) used/size;
}
static size_t clp_write(const void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rclpconn this = con->private;
int i, len = (int)(size * nitems), used = 0;
char c, *p = (char *) ptr, *q = this->buff + this->pos;
if(!con->canwrite)
error(_("clipboard connection is open for reading only"));
if ((double) size * (double) nitems > INT_MAX)
error(_("too large a block specified"));
for(i = 0; i < len; i++) {
if(this->pos >= this->len) break;
c = *p++;
#ifdef Win32
/* clipboard requires CRLF termination */
if(c == '\n') {
*q++ = '\r';
this->pos++;
if(this->pos >= this->len) break;
}
#endif
*q++ = c;
this->pos++;
used++;
}
if (used < len && !this->warned) {
warning(_("clipboard buffer is full and output lost"));
this->warned = TRUE;
}
if(this->last < this->pos) this->last = this->pos;
return (size_t) used/size;
}
static Rconnection newclp(const char *url, const char *inmode)
{
Rconnection new;
const char *description;
int sizeKB = 32;
char mode[4];
mode[3] = '\0';
strncpy(mode, inmode, 3);
if(strlen(mode) == 2 && mode[1] == 't') mode[1] = '\0';
if(strlen(mode) != 1 ||
(mode[0] != 'r' && mode[0] != 'w'))
error(_("'mode' for the clipboard must be 'r' or 'w'"));
#ifdef Unix
if(mode[0] != 'r')
error(_("'mode' for the clipboard must be 'r' on Unix"));
#endif
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of clipboard connection failed"));
if(strncmp(url, "clipboard", 9) == 0) description = "clipboard";
else description = url;
new->class = (char *) malloc(strlen(description) + 1);
if(!new->class) {
free(new);
error(_("allocation of clipboard connection failed"));
}
strcpy(new->class, description);
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of clipboard connection failed"));
}
init_con(new, description, CE_NATIVE, mode);
new->open = &clp_open;
new->close = &clp_close;
new->vfprintf = &dummy_vfprintf;
new->fgetc_internal = &clp_fgetc_internal;
new->fgetc = &dummy_fgetc;
new->seek = &clp_seek;
new->truncate = &clp_truncate;
new->fflush = &clp_fflush;
new->read = &clp_read;
new->write = &clp_write;
new->canseek = TRUE;
new->private = (void *) malloc(sizeof(struct clpconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of clipboard connection failed"));
}
((Rclpconn)new->private)->buff = NULL;
if (strncmp(url, "clipboard-", 10) == 0) {
sizeKB = atoi(url+10);
if(sizeKB < 32) sizeKB = 32;
/* Rprintf("setting clipboard size to %dKB\n", sizeKB); */
}
((Rclpconn)new->private)->sizeKB = sizeKB;
return new;
}
/* ------------------- terminal connections --------------------- */
static unsigned char ConsoleBuf[CONSOLE_BUFFER_SIZE+1];
static unsigned char *ConsoleBufp;
static int ConsoleBufCnt;
static int ConsoleGetchar(void)
{
if (--ConsoleBufCnt < 0) {
ConsoleBuf[CONSOLE_BUFFER_SIZE] = '\0';
if (R_ReadConsole("", ConsoleBuf, CONSOLE_BUFFER_SIZE, 0) == 0) {
R_ClearerrConsole();
return R_EOF;
}
ConsoleBufp = ConsoleBuf;
ConsoleBufCnt = (int) strlen((char *)ConsoleBuf); // must be short
ConsoleBufCnt--;
}
return *ConsoleBufp++;
}
static int stdin_fgetc(Rconnection con)
{
return ConsoleGetchar();
}
static int stdout_vfprintf(Rconnection con, const char *format, va_list ap)
{
if(R_Outputfile) vfprintf(R_Outputfile, format, ap);
else Rcons_vprintf(format, ap);
return 0;
}
static int stdout_fflush(Rconnection con)
{
if(R_Outputfile) return fflush(R_Outputfile);
return 0;
}
static int stderr_vfprintf(Rconnection con, const char *format, va_list ap)
{
REvprintf(format, ap);
return 0;
}
static int stderr_fflush(Rconnection con)
{
/* normally stderr and hence unbuffered, but it needs not be,
e.g. it is stdout on Win9x */
if(R_Consolefile) return fflush(R_Consolefile);
return 0;
}
static Rconnection newterminal(const char *description, const char *mode)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of terminal connection failed"));
new->class = (char *) malloc(strlen("terminal") + 1);
if(!new->class) {
free(new);
error(_("allocation of terminal connection failed"));
}
strcpy(new->class, "terminal");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of terminal connection failed"));
}
init_con(new, description, CE_NATIVE, mode);
new->isopen = TRUE;
new->canread = (strcmp(mode, "r") == 0);
new->canwrite = (strcmp(mode, "w") == 0);
new->destroy = &null_close;
new->private = NULL;
return new;
}
SEXP attribute_hidden do_stdin(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, class;
Rconnection con = getConnection(0);
checkArity(op, args);
PROTECT(ans = ScalarInteger(0));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar(con->class));
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_stdout(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, class;
Rconnection con = getConnection(R_OutputCon);
checkArity(op, args);
PROTECT(ans = ScalarInteger(R_OutputCon));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar(con->class));
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_stderr(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, class;
Rconnection con = getConnection(2);
checkArity(op, args);
PROTECT(ans = ScalarInteger(2));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar(con->class));
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
UNPROTECT(2);
return ans;
}
/* isatty is in unistd.h, or io.h on Windows */
#ifdef Win32
# include <io.h>
#endif
SEXP attribute_hidden do_isatty(SEXP call, SEXP op, SEXP args, SEXP env)
{
int con;
/* FIXME: is this correct for consoles? */
checkArity(op, args);
con = asInteger(CAR(args));
return ScalarLogical(con == NA_LOGICAL ? FALSE : isatty(con) );
}
/* ------------------- raw connections --------------------- */
/* Possible future redesign: store nbytes as TRUELENGTH */
typedef struct rawconn {
SEXP data; /* all the data, stored as a raw vector */
/* replace nbytes by TRUELENGTH in due course? */
size_t pos, nbytes; /* current pos and number of bytes
(same pos for read and write) */
} *Rrawconn;
/* copy a raw vector into a buffer */
static void raw_init(Rconnection con, SEXP raw)
{
Rrawconn this = con->private;
this->data = NAMED(raw) ? duplicate(raw) : raw;
R_PreserveObject(this->data);
this->nbytes = XLENGTH(this->data);
this->pos = 0;
}
static Rboolean raw_open(Rconnection con)
{
return TRUE;
}
static void raw_close(Rconnection con)
{
}
static void raw_destroy(Rconnection con)
{
Rrawconn this = con->private;
R_ReleaseObject(this->data);
free(this);
}
static void raw_resize(Rrawconn this, size_t needed)
{
size_t nalloc = 64;
SEXP tmp;
if (needed > 8192) nalloc = (size_t)(1.2*(double)needed); /* 20% over-allocation */
else while(nalloc < needed) nalloc *= 2; /* use powers of 2 if small */
PROTECT(tmp = allocVector(RAWSXP, nalloc));
memcpy(RAW(tmp), RAW(this->data), this->nbytes);
R_ReleaseObject(this->data);
this->data = tmp;
R_PreserveObject(this->data);
UNPROTECT(1);
}
static size_t raw_write(const void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rrawconn this = con->private;
size_t freespace = XLENGTH(this->data) - this->pos, bytes = size*nitems;
if ((double) size * (double) nitems + (double) this->pos > R_LEN_T_MAX)
error(_("attempting to add too many elements to raw vector"));
/* resize may fail, when this will give an error */
if(bytes >= freespace) raw_resize(this, bytes + this->pos);
/* the source just might be this raw vector */
memmove(RAW(this->data) + this->pos, ptr, bytes);
this->pos += bytes;
if(this->nbytes < this->pos) this->nbytes = this->pos;
return nitems;
}
static void raw_truncate(Rconnection con)
{
Rrawconn this = con->private;
this->nbytes = this->pos;
}
static size_t raw_read(void *ptr, size_t size, size_t nitems,
Rconnection con)
{
Rrawconn this = con->private;
size_t available = this->nbytes - this->pos, request = size*nitems, used;
if ((double) size * (double) nitems + (double) this->pos > R_LEN_T_MAX)
error(_("too large a block specified"));
used = (request < available) ? request : available;
memmove(ptr, RAW(this->data) + this->pos, used);
this->pos += used;
return used/size;
}
static int raw_fgetc(Rconnection con)
{
Rrawconn this = con->private;
if(this->pos >= this->nbytes) return R_EOF;
else return (int) RAW(this->data)[this->pos++];
}
static double raw_seek(Rconnection con, double where, int origin, int rw)
{
Rrawconn this = con->private;
double newpos;
size_t oldpos = this->pos;
if(ISNA(where)) return (double) oldpos;
/* Do the calculations here as double to avoid integer overflow */
switch(origin) {
case 2: newpos = (double) this->pos + where; break;
case 3: newpos = (double) this->nbytes + where; break;
default: newpos = where;
}
if(newpos < 0 || newpos > this->nbytes)
error(_("attempt to seek outside the range of the raw connection"));
else this->pos = (size_t) newpos;
return (double) oldpos;
}
static Rconnection newraw(const char *description, SEXP raw, const char *mode)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of raw connection failed"));
new->class = (char *) malloc(strlen("rawConnection") + 1);
if(!new->class) {
free(new);
error(_("allocation of raw connection failed"));
}
strcpy(new->class, "rawConnection");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of raw connection failed"));
}
init_con(new, description, CE_NATIVE, mode);
new->isopen = TRUE;
new->text = FALSE;
new->blocking = TRUE;
new->canseek = TRUE;
new->canwrite = (mode[0] == 'w' || mode[0] == 'a');
new->canread = mode[0] == 'r';
if(strlen(mode) >= 2 && mode[1] == '+') new->canread = new->canwrite = TRUE;
new->open = &raw_open;
new->close = &raw_close;
new->destroy = &raw_destroy;
if(new->canwrite) {
new->write = &raw_write;
new->vfprintf = &dummy_vfprintf;
new->truncate = &raw_truncate;
}
if(new->canread) {
new->read = &raw_read;
new->fgetc = &raw_fgetc;
}
new->seek = &raw_seek;
new->private = (void*) malloc(sizeof(struct rawconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of raw connection failed"));
}
raw_init(new, raw);
if(mode[0] == 'a') raw_seek(new, 0, 3, 0);
return new;
}
SEXP attribute_hidden do_rawconnection(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile, sraw, sopen, ans, class;
const char *desc, *open;
int ncon;
Rconnection con = NULL;
checkArity(op, args);
sfile = CAR(args);
if(!isString(sfile) || length(sfile) != 1)
error(_("invalid '%s' argument"), "description");
desc = translateChar(STRING_ELT(sfile, 0));
sraw = CADR(args);
sopen = CADDR(args);
if(!isString(sopen) || length(sopen) != 1)
error(_("invalid '%s' argument"), "open");
open = CHAR(STRING_ELT(sopen, 0)); /* ASCII */
if(strchr(open, 't'))
error(_("invalid '%s' argument"), "open");
ncon = NextConnection();
if(TYPEOF(sraw) != RAWSXP)
error(_("invalid '%s' argument"), "raw");
con = Connections[ncon] = newraw(desc, sraw, open);
/* already opened */
PROTECT(ans = ScalarInteger(ncon));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar("rawConnection"));
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
con->ex_ptr = R_MakeExternalPtr(con->id, install("connection"), R_NilValue);
setAttrib(ans, R_ConnIdSymbol, con->ex_ptr);
R_RegisterCFinalizerEx(con->ex_ptr, conFinalizer, FALSE);
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_rawconvalue(SEXP call, SEXP op, SEXP args, SEXP env)
{
Rconnection con=NULL;
Rrawconn this;
SEXP ans;
checkArity(op, args);
if(!inherits(CAR(args), "rawConnection"))
error(_("'con' is not a rawConnection"));
con = getConnection(asInteger(CAR(args)));
if(!con->canwrite)
error(_("'con' is not an output rawConnection"));
this = con->private;
ans = allocVector(RAWSXP, this->nbytes); /* later, use TRUELENGTH? */
memcpy(RAW(ans), RAW(this->data), this->nbytes);
return ans;
}
/* ------------------- text connections --------------------- */
typedef struct textconn {
char *data; /* all the data */
size_t cur, nchars; /* current pos and number of chars */
char save; /* pushback */
} *Rtextconn;
typedef struct outtextconn {
size_t len; /* number of lines */
SEXP namesymbol;
SEXP data;
char *lastline;
int lastlinelength; /* buffer size */
} *Routtextconn;
/* read a R character vector into a buffer */
static void text_init(Rconnection con, SEXP text, int type)
{
R_xlen_t i, nlines = xlength(text); // not very plausible that this is long
size_t nchars = 0; /* -Wall */
double dnc = 0.0;
Rtextconn this = con->private;
for(i = 0; i < nlines; i++)
dnc +=
(double) strlen(type == 1 ? translateChar(STRING_ELT(text, i))
: ((type == 3) ?translateCharUTF8(STRING_ELT(text, i))
: CHAR(STRING_ELT(text, i))) ) + 1;
if (dnc >= SIZE_MAX)
error(_("too many characters for text connection"));
else nchars = (size_t) dnc;
this->data = (char *) malloc(nchars+1);
if(!this->data) {
free(this); free(con->description); free(con->class); free(con);
error(_("cannot allocate memory for text connection"));
}
*(this->data) = '\0';
for(i = 0; i < nlines; i++) {
strcat(this->data,
type == 1 ? translateChar(STRING_ELT(text, i))
: ((type == 3) ?translateCharUTF8(STRING_ELT(text, i))
: CHAR(STRING_ELT(text, i))) );
strcat(this->data, "\n");
}
this->nchars = nchars;
this->cur = this->save = 0;
}
static Rboolean text_open(Rconnection con)
{
con->save = -1000;
return TRUE;
}
static void text_close(Rconnection con)
{
}
static void text_destroy(Rconnection con)
{
Rtextconn this = con->private;
free(this->data);
/* this->cur = this->nchars = 0; */
free(this);
}
static int text_fgetc(Rconnection con)
{
Rtextconn this = con->private;
if(this->save) {
int c;
c = this->save;
this->save = 0;
return c;
}
if(this->cur >= this->nchars) return R_EOF;
else return (int) (this->data[this->cur++]);
}
static double text_seek(Rconnection con, double where, int origin, int rw)
{
if(where >= 0) error(_("seek is not relevant for text connection"));
return 0; /* if just asking, always at the beginning */
}
static Rconnection newtext(const char *description, SEXP text, int type)
{
Rconnection new;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of text connection failed"));
new->class = (char *) malloc(strlen("textConnection") + 1);
if(!new->class) {
free(new);
error(_("allocation of text connection failed"));
}
strcpy(new->class, "textConnection");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of text connection failed"));
}
init_con(new, description, CE_NATIVE, "r");
new->isopen = TRUE;
new->canwrite = FALSE;
new->open = &text_open;
new->close = &text_close;
new->destroy = &text_destroy;
new->fgetc = &text_fgetc;
new->seek = &text_seek;
new->private = (void*) malloc(sizeof(struct textconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of text connection failed"));
}
text_init(new, text, type);
return new;
}
static SEXP mkCharLocal(const char *s)
{
int ienc = CE_NATIVE;
if(known_to_be_latin1) ienc = CE_LATIN1;
if(known_to_be_utf8) ienc = CE_UTF8;
return mkCharCE(s, ienc);
}
static void outtext_close(Rconnection con)
{
Routtextconn this = con->private;
int idx = ConnIndex(con);
SEXP tmp, env = VECTOR_ELT(OutTextData, idx);
if(this->namesymbol &&
findVarInFrame3(env, this->namesymbol, FALSE) != R_UnboundValue)
R_unLockBinding(this->namesymbol, env);
if(strlen(this->lastline) > 0) {
PROTECT(tmp = xlengthgets(this->data, ++this->len));
SET_STRING_ELT(tmp, this->len - 1, mkCharLocal(this->lastline));
if(this->namesymbol) defineVar(this->namesymbol, tmp, env);
SET_NAMED(tmp, 2);
this->data = tmp;
UNPROTECT(1);
}
}
static void outtext_destroy(Rconnection con)
{
Routtextconn this = con->private;
int idx = ConnIndex(con);
/* OutTextData is preserved, and that implies that the environment
we are writing it and hence the character vector is protected.
However, this could be quite expensive.
*/
SET_VECTOR_ELT(OutTextData, idx, R_NilValue);
if(!this->namesymbol) R_ReleaseObject(this->data);
free(this->lastline); free(this);
}
#define LAST_LINE_LEN 256
static int text_vfprintf(Rconnection con, const char *format, va_list ap)
{
Routtextconn this = con->private;
char buf[BUFSIZE], *b = buf, *p, *q;
const void *vmax = vmaxget();
int res = 0, usedRalloc = FALSE, buffree,
already = (int) strlen(this->lastline); // we do not allow longer lines
SEXP tmp;
va_list aq;
va_copy(aq, ap);
if(already >= BUFSIZE) {
/* This will fail so just call vsnprintf to get the length of
the new piece */
res = vsnprintf(buf, 0, format, aq);
if(res > 0) res += already;
buffree = 0;
} else {
strcpy(b, this->lastline);
p = b + already;
buffree = BUFSIZE - already; // checked < BUFSIZE above
res = vsnprintf(p, buffree, format, aq);
}
va_end(aq);
if(res >= buffree) { /* res is the desired output length */
usedRalloc = TRUE;
b = R_alloc(res + already + 1, sizeof(char));
strcpy(b, this->lastline);
p = b + already;
vsprintf(p, format, ap);
} else if(res < 0) { /* just a failure indication */
#define NBUFSIZE (already + 100*BUFSIZE)
usedRalloc = TRUE;
b = R_alloc(NBUFSIZE, sizeof(char));
strncpy(b, this->lastline, NBUFSIZE);
*(b + NBUFSIZE - 1) = '\0';
p = b + already;
res = vsnprintf(p, NBUFSIZE - already, format, ap);
if (res < 0) {
*(b + NBUFSIZE - 1) = '\0';
warning(_("printing of extremely long output is truncated"));
}
}
/* copy buf line-by-line to object */
for(p = b; ; p = q+1) {
q = Rf_strchr(p, '\n');
if(q) {
int idx = ConnIndex(con);
SEXP env = VECTOR_ELT(OutTextData, idx);
*q = '\0';
PROTECT(tmp = xlengthgets(this->data, ++this->len));
SET_STRING_ELT(tmp, this->len - 1, mkCharLocal(p));
if(this->namesymbol) {
if(findVarInFrame3(env, this->namesymbol, FALSE)
!= R_UnboundValue) R_unLockBinding(this->namesymbol, env);
defineVar(this->namesymbol, tmp, env);
R_LockBinding(this->namesymbol, env);
} else {
R_ReleaseObject(this->data);
R_PreserveObject(tmp);
}
this->data = tmp;
SET_NAMED(tmp, 2);
UNPROTECT(1);
} else {
/* retain the last line */
if(strlen(p) >= this->lastlinelength) {
size_t newlen = strlen(p) + 1;
if (newlen > INT_MAX) error("last line is too long");
void * tmp = realloc(this->lastline, newlen);
if (tmp) {
this->lastline = tmp;
this->lastlinelength = (int) newlen;
} else {
warning("allocation problem for last line");
this->lastline = NULL;
this->lastlinelength = 0;
}
}
strcpy(this->lastline, p);
con->incomplete = strlen(this->lastline) > 0;
break;
}
}
if(usedRalloc) vmaxset(vmax);
return res;
}
static void outtext_init(Rconnection con, SEXP stext, const char *mode, int idx)
{
Routtextconn this = con->private;
SEXP val;
if(stext == R_NilValue) {
this->namesymbol = NULL;
/* create variable pointed to by con->description */
val = allocVector(STRSXP, 0);
R_PreserveObject(val);
} else {
this->namesymbol = install(con->description);
if(strcmp(mode, "w") == 0) {
/* create variable pointed to by con->description */
PROTECT(val = allocVector(STRSXP, 0));
defineVar(this->namesymbol, val, VECTOR_ELT(OutTextData, idx));
/* Not clear if this is needed, but be conservative */
SET_NAMED(val, 2);
UNPROTECT(1);
} else {
/* take over existing variable */
val = findVar1(this->namesymbol, VECTOR_ELT(OutTextData, idx),
STRSXP, FALSE);
if(val == R_UnboundValue) {
warning(_("text connection: appending to a non-existent char vector"));
PROTECT(val = allocVector(STRSXP, 0));
defineVar(this->namesymbol, val, VECTOR_ELT(OutTextData, idx));
SET_NAMED(val, 2);
UNPROTECT(1);
}
R_LockBinding(this->namesymbol, VECTOR_ELT(OutTextData, idx));
}
}
this->len = LENGTH(val);
this->data = val;
this->lastline[0] = '\0';
this->lastlinelength = LAST_LINE_LEN;
}
static Rconnection newouttext(const char *description, SEXP stext,
const char *mode, int idx)
{
Rconnection new;
void *tmp;
new = (Rconnection) malloc(sizeof(struct Rconn));
if(!new) error(_("allocation of text connection failed"));
new->class = (char *) malloc(strlen("textConnection") + 1);
if(!new->class) {
free(new);
error(_("allocation of text connection failed"));
}
strcpy(new->class, "textConnection");
new->description = (char *) malloc(strlen(description) + 1);
if(!new->description) {
free(new->class); free(new);
error(_("allocation of text connection failed"));
}
init_con(new, description, CE_NATIVE, mode);
new->isopen = TRUE;
new->canread = FALSE;
new->open = &text_open;
new->close = &outtext_close;
new->destroy = &outtext_destroy;
new->vfprintf = &text_vfprintf;
new->seek = &text_seek;
new->private = (void*) malloc(sizeof(struct outtextconn));
if(!new->private) {
free(new->description); free(new->class); free(new);
error(_("allocation of text connection failed"));
}
((Routtextconn)new->private)->lastline = tmp = malloc(LAST_LINE_LEN);
if(!tmp) {
free(new->private);
free(new->description); free(new->class); free(new);
error(_("allocation of text connection failed"));
}
outtext_init(new, stext, mode, idx);
return new;
}
SEXP attribute_hidden do_textconnection(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile, stext, sopen, ans, class, venv;
const char *desc, *open;
int ncon, type;
Rconnection con = NULL;
checkArity(op, args);
sfile = CAR(args);
if(!isString(sfile) || length(sfile) != 1)
error(_("invalid '%s' argument"), "description");
desc = translateChar(STRING_ELT(sfile, 0));
stext = CADR(args);
sopen = CADDR(args);
if(!isString(sopen) || length(sopen) != 1)
error(_("invalid '%s' argument"), "open");
open = CHAR(STRING_ELT(sopen, 0)); /* ASCII */
venv = CADDDR(args);
if (isNull(venv))
error(_("use of NULL environment is defunct"));
if (!isEnvironment(venv))
error(_("invalid '%s' argument"), "environment");
type = asInteger(CAD4R(args));
if (type == NA_INTEGER)
error(_("invalid '%s' argument"), "encoding");
ncon = NextConnection();
if(!strlen(open) || strncmp(open, "r", 1) == 0) {
if(!isString(stext))
error(_("invalid '%s' argument"), "text");
con = Connections[ncon] = newtext(desc, stext, type);
} else if (strncmp(open, "w", 1) == 0 || strncmp(open, "a", 1) == 0) {
if (OutTextData == NULL) {
OutTextData = allocVector(VECSXP, NCONNECTIONS);
R_PreserveObject(OutTextData);
}
SET_VECTOR_ELT(OutTextData, ncon, venv);
if(stext == R_NilValue)
con = Connections[ncon] = newouttext("NULL", stext, open, ncon);
else if(isString(stext) && length(stext) == 1)
con = Connections[ncon] =
newouttext(translateChar(STRING_ELT(stext, 0)), stext,
open, ncon);
else
error(_("invalid '%s' argument"), "text");
}
else
error(_("unsupported mode"));
/* already opened */
PROTECT(ans = ScalarInteger(ncon));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar("textConnection"));
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
con->ex_ptr = R_MakeExternalPtr(con->id, install("connection"), R_NilValue);
setAttrib(ans, R_ConnIdSymbol, con->ex_ptr);
R_RegisterCFinalizerEx(con->ex_ptr, conFinalizer, FALSE);
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_textconvalue(SEXP call, SEXP op, SEXP args, SEXP env)
{
Rconnection con=NULL;
Routtextconn this;
checkArity(op, args);
if(!inherits(CAR(args), "textConnection"))
error(_("'con' is not a textConnection"));
con = getConnection(asInteger(CAR(args)));
if(!con->canwrite)
error(_("'con' is not an output textConnection"));
this = con->private;
return this->data;
}
/* ------------------- socket connections --------------------- */
/* socketConnection(host, port, server, blocking, open, encoding) */
SEXP attribute_hidden do_sockconn(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP scmd, sopen, ans, class, enc;
const char *host, *open;
int ncon, port, server, blocking, timeout;
Rconnection con = NULL;
checkArity(op, args);
#ifdef HAVE_SOCKETS
scmd = CAR(args);
if(!isString(scmd) || length(scmd) != 1)
error(_("invalid '%s' argument"), "host");
host = translateChar(STRING_ELT(scmd, 0));
args = CDR(args);
port = asInteger(CAR(args));
if(port == NA_INTEGER || port < 0)
error(_("invalid '%s' argument"), "port");
args = CDR(args);
server = asLogical(CAR(args));
if(server == NA_LOGICAL)
error(_("invalid '%s' argument"), "server");
args = CDR(args);
blocking = asLogical(CAR(args));
if(blocking == NA_LOGICAL)
error(_("invalid '%s' argument"), "blocking");
args = CDR(args);
sopen = CAR(args);
if(!isString(sopen) || length(sopen) != 1)
error(_("invalid '%s' argument"), "open");
open = CHAR(STRING_ELT(sopen, 0)); /* ASCII */
args = CDR(args);
enc = CAR(args);
if(!isString(enc) || length(enc) != 1 ||
strlen(CHAR(STRING_ELT(enc, 0))) > 100) /* ASCII */
error(_("invalid '%s' argument"), "encoding");
args = CDR(args);
timeout = asInteger(CAR(args));
ncon = NextConnection();
con = R_newsock(host, port, server, open, timeout);
Connections[ncon] = con;
con->blocking = blocking;
strncpy(con->encname, CHAR(STRING_ELT(enc, 0)), 100); /* ASCII */
con->ex_ptr = PROTECT(R_MakeExternalPtr(con->id, install("connection"), R_NilValue));
/* open it if desired */
if(strlen(open)) {
Rboolean success = con->open(con);
if(!success) {
con_destroy(ncon);
error(_("cannot open the connection"));
}
}
PROTECT(ans = ScalarInteger(ncon));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar("sockconn"));
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
setAttrib(ans, R_ConnIdSymbol, con->ex_ptr);
R_RegisterCFinalizerEx(con->ex_ptr, conFinalizer, FALSE);
UNPROTECT(3);
#else
error(_("sockets are not available on this system"));
#endif
return ans;
}
/* ------------------- unz connections --------------------- */
/* see dounzip.c for the details */
SEXP attribute_hidden do_unz(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile, sopen, ans, class, enc;
const char *file, *open;
int ncon;
Rconnection con = NULL;
checkArity(op, args);
sfile = CAR(args);
if(!isString(sfile) || length(sfile) != 1)
error(_("invalid '%s' argument"), "description");
if(length(sfile) > 1)
warning(_("only first element of 'description' argument used"));
file = translateChar(STRING_ELT(sfile, 0));
sopen = CADR(args);
if(!isString(sopen) || length(sopen) != 1)
error(_("invalid '%s' argument"), "open");
enc = CADDR(args);
if(!isString(enc) || length(enc) != 1 ||
strlen(CHAR(STRING_ELT(enc, 0))) > 100) /* ASCII */
error(_("invalid '%s' argument"), "encoding");
open = CHAR(STRING_ELT(sopen, 0)); /* ASCII */
ncon = NextConnection();
con = Connections[ncon] = R_newunz(file, strlen(open) ? open : "r");
strncpy(con->encname, CHAR(STRING_ELT(enc, 0)), 100); /* ASCII */
con->ex_ptr = PROTECT(R_MakeExternalPtr(con->id, install("connection"), R_NilValue));
/* open it if desired */
if(strlen(open)) {
Rboolean success = con->open(con);
if(!success) {
con_destroy(ncon);
error(_("cannot open the connection"));
}
}
PROTECT(ans = ScalarInteger(ncon));
PROTECT(class = allocVector(STRSXP, 2));
SET_STRING_ELT(class, 0, mkChar("unz"));
SET_STRING_ELT(class, 1, mkChar("connection"));
classgets(ans, class);
setAttrib(ans, R_ConnIdSymbol, con->ex_ptr);
R_RegisterCFinalizerEx(con->ex_ptr, conFinalizer, FALSE);
UNPROTECT(3);
return ans;
}
/* -------------- open, close, seek, truncate, flush ------------------ */
SEXP attribute_hidden do_open(SEXP call, SEXP op, SEXP args, SEXP env)
{
int i, block;
Rconnection con=NULL;
SEXP sopen;
const char *open;
Rboolean success;
checkArity(op, args);
if(!inherits(CAR(args), "connection"))
error(_("'con' is not a connection"));
i = asInteger(CAR(args));
con = getConnection(i);
if(i < 3) error(_("cannot open standard connections"));
if(con->isopen) {
warning(_("connection is already open"));
return R_NilValue;
}
sopen = CADR(args);
if(!isString(sopen) || length(sopen) != 1)
error(_("invalid '%s' argument"), "open");
block = asLogical(CADDR(args));
if(block == NA_LOGICAL)
error(_("invalid '%s' argument"), "blocking");
open = CHAR(STRING_ELT(sopen, 0)); /* ASCII */
if(strlen(open) > 0) strcpy(con->mode, open);
con->blocking = block;
success = con->open(con);
if(!success) {
/* con_destroy(i); user might have a reference */
error(_("cannot open the connection"));
}
return R_NilValue;
}
SEXP attribute_hidden do_isopen(SEXP call, SEXP op, SEXP args, SEXP env)
{
Rconnection con;
int rw, res;
checkArity(op, args);
con = getConnection(asInteger(CAR(args)));
rw = asInteger(CADR(args));
res = con->isopen != FALSE;
switch(rw) {
case 0: break;
case 1: res = res & con->canread; break;
case 2: res = res & con->canwrite; break;
default: error(_("unknown 'rw' value"));
}
return ScalarLogical(res);
}
SEXP attribute_hidden do_isincomplete(SEXP call, SEXP op, SEXP args, SEXP env)
{
Rconnection con;
checkArity(op, args);
if(!inherits(CAR(args), "connection"))
error(_("'con' is not a connection"));
con = getConnection(asInteger(CAR(args)));
return ScalarLogical(con->incomplete != FALSE);
}
SEXP attribute_hidden do_isseekable(SEXP call, SEXP op, SEXP args, SEXP env)
{
Rconnection con;
checkArity(op, args);
if(!inherits(CAR(args), "connection"))
error(_("'con' is not a connection"));
con = getConnection(asInteger(CAR(args)));
return ScalarLogical(con->canseek != FALSE);
}
static void con_close1(Rconnection con)
{
if(con->isopen) con->close(con);
if(con->isGzcon) {
Rgzconn priv = con->private;
con_close1(priv->con);
R_ReleaseObject(priv->con->ex_ptr);
}
/* close inconv and outconv if open */
if(con->inconv) Riconv_close(con->inconv);
if(con->outconv) Riconv_close(con->outconv);
con->destroy(con);
free(con->class);
free(con->description);
/* clear the pushBack */
if(con->nPushBack > 0) {
int j;
for(j = 0; j < con->nPushBack; j++)
free(con->PushBack[j]);
free(con->PushBack);
}
}
static void con_destroy(int i)
{
Rconnection con=NULL;
con = getConnection(i);
con_close1(con);
free(Connections[i]);
Connections[i] = NULL;
}
SEXP attribute_hidden do_close(SEXP call, SEXP op, SEXP args, SEXP env)
{
int i, j;
checkArity(op, args);
if(!inherits(CAR(args), "connection"))
error(_("'con' is not a connection"));
i = asInteger(CAR(args));
if(i < 3) error(_("cannot close standard connections"));
for(j = 0; j < R_SinkNumber; j++)
if(i == SinkCons[j])
error(_("cannot close output sink connection"));
if(i == R_ErrorCon)
error(_("cannot close messages sink connection"));
con_destroy(i);
return R_NilValue;
}
/* seek(con, where = numeric(), origin = "start", rw = "") */
SEXP attribute_hidden do_seek(SEXP call, SEXP op, SEXP args, SEXP env)
{
int origin, rw;
Rconnection con = NULL;
double where;
checkArity(op, args);
if(!inherits(CAR(args), "connection"))
error(_("'con' is not a connection"));
con = getConnection(asInteger(CAR(args)));
if(!con->isopen) error(_("connection is not open"));
where = asReal(CADR(args));
origin = asInteger(CADDR(args));
rw = asInteger(CADDDR(args));
if(!ISNAN(where) && con->nPushBack > 0) {
/* clear pushback */
int j;
for(j = 0; j < con->nPushBack; j++) free(con->PushBack[j]);
free(con->PushBack);
con->nPushBack = 0;
}
return ScalarReal(con->seek(con, where, origin, rw));
}
/* truncate(con) */
SEXP attribute_hidden do_truncate(SEXP call, SEXP op, SEXP args, SEXP env)
{
Rconnection con = NULL;
checkArity(op, args);
if(!inherits(CAR(args), "connection"))
error(_("'con' is not a connection"));
con = getConnection(asInteger(CAR(args)));
con->truncate(con);
return R_NilValue;
}
SEXP attribute_hidden do_flush(SEXP call, SEXP op, SEXP args, SEXP env)
{
Rconnection con = NULL;
checkArity(op, args);
if(!inherits(CAR(args), "connection"))
error(_("'con' is not a connection"));
con = getConnection(asInteger(CAR(args)));
if(con->canwrite) con->fflush(con);
return R_NilValue;
}
/* ------------------- read, write text --------------------- */
int Rconn_fgetc(Rconnection con)
{
char *curLine;
int c;
if (con->save2 != -1000) {
c = con->save2;
con->save2 = -1000;
return c;
}
if(con->nPushBack <= 0) {
/* map CR or CRLF to LF */
if (con->save != -1000) {
c = con->save;
con->save = -1000;
return c;
}
c = con->fgetc(con);
if (c == '\r') {
c = con->fgetc(con);
if (c != '\n') {
con->save = (c != '\r') ? c : '\n';
return('\n');
}
}
return c;
}
curLine = con->PushBack[con->nPushBack-1];
c = (unsigned char) curLine[con->posPushBack++];
if(con->posPushBack >= strlen(curLine)) {
/* last character on a line, so pop the line */
free(curLine);
con->nPushBack--;
con->posPushBack = 0;
if(con->nPushBack == 0) free(con->PushBack);
}
return c;
}
int Rconn_ungetc(int c, Rconnection con)
{
con->save2 = c;
return c;
}
/* read one line (without trailing newline) from con and store it in buf */
/* return number of characters read, -1 on EOF */
int Rconn_getline(Rconnection con, char *buf, int bufsize)
{
int c, nbuf = -1;
while((c = Rconn_fgetc(con)) != R_EOF) {
if(nbuf+1 >= bufsize) error(_("line longer than buffer size"));
if(c != '\n'){
buf[++nbuf] = (char) c;
} else {
buf[++nbuf] = '\0';
break;
}
}
/* Make sure it is null-terminated and count is correct, even if
* file did not end with newline.
*/
if(nbuf >= 0 && buf[nbuf]) {
if(nbuf+1 >= bufsize) error(_("line longer than buffer size"));
buf[++nbuf] = '\0';
}
return(nbuf);
}
int Rconn_printf(Rconnection con, const char *format, ...)
{
int res;
va_list(ap);
va_start(ap, format);
/* Parentheses added for FC4 with gcc4 and -D_FORTIFY_SOURCE=2 */
res = (con->vfprintf)(con, format, ap);
va_end(ap);
return res;
}
static void con_cleanup(void *data)
{
Rconnection con = data;
if(con->isopen) con->close(con);
}
/* readLines(con = stdin(), n = 1, ok = TRUE, warn = TRUE) */
#define BUF_SIZE 1000
SEXP attribute_hidden do_readLines(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans = R_NilValue, ans2;
int ok, warn, c, nbuf, buf_size = BUF_SIZE;
int oenc = CE_NATIVE;
Rconnection con = NULL;
Rboolean wasopen;
char *buf;
const char *encoding;
RCNTXT cntxt;
R_xlen_t i, n, nn, nnn, nread;
checkArity(op, args);
if(!inherits(CAR(args), "connection"))
error(_("'con' is not a connection"));
con = getConnection(asInteger(CAR(args)));
n = asVecSize(CADR(args));
if(n == -999)
error(_("invalid '%s' argument"), "n");
ok = asLogical(CADDR(args));
if(ok == NA_LOGICAL)
error(_("invalid '%s' argument"), "ok");
warn = asLogical(CADDDR(args));
if(warn == NA_LOGICAL)
error(_("invalid '%s' argument"), "warn");
if(!isString(CAD4R(args)) || LENGTH(CAD4R(args)) != 1)
error(_("invalid '%s' value"), "encoding");
encoding = CHAR(STRING_ELT(CAD4R(args), 0)); /* ASCII */
wasopen = con->isopen;
if(!wasopen) {
char mode[5];
con->UTF8out = TRUE; /* a request */
strcpy(mode, con->mode);
strcpy(con->mode, "rt");
if(!con->open(con)) error(_("cannot open the connection"));
strcpy(con->mode, mode);
/* Set up a context which will close the connection on error */
begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &con_cleanup;
cntxt.cenddata = con;
if(!con->canread) error(_("cannot read from this connection"));
} else {
if(!con->canread) error(_("cannot read from this connection"));
/* for a non-blocking connection, more input may
have become available, so re-position */
if(con->canseek && !con->blocking)
con->seek(con, con->seek(con, -1, 1, 1), 1, 1);
}
con->incomplete = FALSE;
if(con->UTF8out || streql(encoding, "UTF-8")) oenc = CE_UTF8;
else if(streql(encoding, "latin1")) oenc = CE_LATIN1;
buf = (char *) malloc(buf_size);
if(!buf)
error(_("cannot allocate buffer in readLines"));
nn = (n < 0) ? 1000 : n; /* initially allocate space for 1000 lines */
nnn = (n < 0) ? R_XLEN_T_MAX : n;
PROTECT(ans = allocVector(STRSXP, nn));
for(nread = 0; nread < nnn; nread++) {
if(nread >= nn) {
double dnn = 2.* nn;
if (dnn > R_XLEN_T_MAX) error("too many items");
ans2 = allocVector(STRSXP, 2*nn);
for(i = 0; i < nn; i++)
SET_STRING_ELT(ans2, i, STRING_ELT(ans, i));
nn *= 2;
UNPROTECT(1); /* old ans */
PROTECT(ans = ans2);
}
nbuf = 0;
while((c = Rconn_fgetc(con)) != R_EOF) {
if(nbuf == buf_size-1) { /* need space for the null */
buf_size *= 2;
char *tmp = (char *) realloc(buf, buf_size);
if(!buf) {
free(buf);
error(_("cannot allocate buffer in readLines"));
} else buf = tmp;
}
if(c != '\n') buf[nbuf++] = (char) c; else break;
}
buf[nbuf] = '\0';
SET_STRING_ELT(ans, nread, mkCharCE(buf, oenc));
if(c == R_EOF) goto no_more_lines;
}
if(!wasopen) {endcontext(&cntxt); con->close(con);}
UNPROTECT(1);
free(buf);
return ans;
no_more_lines:
if(!wasopen) {endcontext(&cntxt); con->close(con);}
if(nbuf > 0) { /* incomplete last line */
if(con->text && !con->blocking) {
/* push back the rest */
con_pushback(con, 0, buf);
con->incomplete = TRUE;
} else {
nread++;
if(warn)
warning(_("incomplete final line found on '%s'"),
con->description);
}
}
free(buf);
if(nread < nnn && !ok)
error(_("too few lines read in readLines"));
PROTECT(ans2 = allocVector(STRSXP, nread));
for(i = 0; i < nread; i++)
SET_STRING_ELT(ans2, i, STRING_ELT(ans, i));
UNPROTECT(2);
return ans2;
}
/* writeLines(text, con = stdout(), sep = "\n", useBytes) */
SEXP attribute_hidden do_writelines(SEXP call, SEXP op, SEXP args, SEXP env)
{
int con_num, useBytes;
Rboolean wasopen;
Rconnection con=NULL;
const char *ssep;
SEXP text, sep;
RCNTXT cntxt;
checkArity(op, args);
text = CAR(args);
if(!isString(text)) error(_("invalid '%s' argument"), "text");
if(!inherits(CADR(args), "connection"))
error(_("'con' is not a connection"));
con_num = asInteger(CADR(args));
con = getConnection(con_num);
sep = CADDR(args);
if(!isString(sep)) error(_("invalid '%s' argument"), "sep");
useBytes = asLogical(CADDDR(args));
if(useBytes == NA_LOGICAL)
error(_("invalid '%s' argument"), "useBytes");
wasopen = con->isopen;
if(!wasopen) {
char mode[5];
/* Documented behaviour */
strcpy(mode, con->mode);
strcpy(con->mode, "wt");
if(!con->open(con)) error(_("cannot open the connection"));
strcpy(con->mode, mode);
/* Set up a context which will close the connection on error */
begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &con_cleanup;
cntxt.cenddata = con;
}
if(!con->canwrite) error(_("cannot write to this connection"));
/* NB: translateChar0() is the same as CHAR() for IS_BYTES strings */
if(useBytes)
ssep = CHAR(STRING_ELT(sep, 0));
else
ssep = translateChar0(STRING_ELT(sep, 0));
/* New for 2.7.0: split the output if sink was split.
It would be slightly simpler just to call Rvprintf if the
connection was stdout(), but this way is more efficent */
if(con_num == R_OutputCon) {
int j = 0;
Rconnection con0;
do {
con0 = getConnection(con_num);
for(R_xlen_t i = 0; i < xlength(text); i++)
Rconn_printf(con0, "%s%s",
useBytes ? CHAR(STRING_ELT(text, i)) :
translateChar0(STRING_ELT(text, i)), ssep);
con0->fflush(con0);
con_num = getActiveSink(j++);
} while (con_num > 0);
} else {
for(R_xlen_t i = 0; i < xlength(text); i++)
Rconn_printf(con, "%s%s",
useBytes ? CHAR(STRING_ELT(text, i)) :
translateChar0(STRING_ELT(text, i)), ssep);
}
if(!wasopen) {endcontext(&cntxt); con->close(con);}
return R_NilValue;
}
/* ------------------- read, write binary --------------------- */
static void swapb(void *result, int size)
{
int i;
char *p = result, tmp;
if (size == 1) return;
for (i = 0; i < size/2; i++) {
tmp = p[i];
p[i] = p[size - i - 1];
p[size - i - 1] = tmp;
}
}
static SEXP readOneString(Rconnection con)
{
char buf[10001], *p;
int pos, m;
for(pos = 0; pos < 10000; pos++) {
p = buf + pos;
m = (int) con->read(p, sizeof(char), 1, con);
if(!m) {
if(pos > 0)
warning(_("incomplete strin