#include "XSUB.h"
+/* Call the callback or PerlIOBase, and return failure. */
+#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
+ if (PerlIOValid(f)) { \
+ PerlIO_funcs *tab = PerlIOBase(f)->tab; \
+ if (tab && tab->callback) \
+ return (*tab->callback) args; \
+ else \
+ return PerlIOBase_ ## base args; \
+ } \
+ else \
+ SETERRNO(EBADF, SS_IVCHAN); \
+ return failure
+
+/* Call the callback or fail, and return failure. */
+#define Perl_PerlIO_or_fail(f, callback, failure, args) \
+ if (PerlIOValid(f)) { \
+ PerlIO_funcs *tab = PerlIOBase(f)->tab; \
+ if (tab && tab->callback) \
+ return (*tab->callback) args; \
+ SETERRNO(EINVAL, LIB_INVARG); \
+ } \
+ else \
+ SETERRNO(EBADF, SS_IVCHAN); \
+ return failure
+
+/* Call the callback or PerlIOBase, and be void. */
+#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
+ if (PerlIOValid(f)) { \
+ PerlIO_funcs *tab = PerlIOBase(f)->tab; \
+ if (tab && tab->callback) \
+ (*tab->callback) args; \
+ else \
+ PerlIOBase_ ## base args; \
+ SETERRNO(EINVAL, LIB_INVARG); \
+ } \
+ else \
+ SETERRNO(EBADF, SS_IVCHAN)
+
+/* Call the callback or fail, and be void. */
+#define Perl_PerlIO_or_fail_void(f, callback, args) \
+ if (PerlIOValid(f)) { \
+ PerlIO_funcs *tab = PerlIOBase(f)->tab; \
+ if (tab && tab->callback) \
+ (*tab->callback) args; \
+ SETERRNO(EINVAL, LIB_INVARG); \
+ } \
+ else \
+ SETERRNO(EBADF, SS_IVCHAN)
+
int
perlsio_binmode(FILE *fp, int iotype, int mode)
{
{
if (PerlIOValid(f)) {
PerlIO_funcs *tab = PerlIOBase(f)->tab;
- PerlIO *new;
PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
- new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
- return new;
- }
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return NULL;
+ if (tab && tab->Dup)
+ return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
+ SETERRNO(EINVAL, LIB_INVARG);
}
+ else
+ SETERRNO(EBADF, SS_IVCHAN);
+
+ return NULL;
}
void
}
}
+/* Return as an array the stack of layers on a filehandle. Note that
+ * the stack is returned top-first in the array, and there are three
+ * times as many array elements as there are layers in the stack: the
+ * first element of a layer triplet is the name, the second one is the
+ * arguments, and the third one is the flags. */
+
+AV *
+PerlIO_get_layers(pTHX_ PerlIO *f)
+{
+ AV *av = newAV();
+
+ if (PerlIOValid(f)) {
+ PerlIOl *l = PerlIOBase(f);
+
+ while (l) {
+ SV *name = l->tab && l->tab->name ?
+ newSVpv(l->tab->name, 0) : &PL_sv_undef;
+ SV *arg = l->tab && l->tab->Getarg ?
+ (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
+ av_push(av, name);
+ av_push(av, arg);
+ av_push(av, newSViv((IV)l->flags));
+ l = l->next;
+ }
+ }
+
+ return av;
+}
+
/*--------------------------------------------------------------------------------------*/
/*
* XS Interface for perl code
*f = l;
PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
(mode) ? mode : "(Null)", (void*)arg);
- if ((*l->tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
+ if (*l->tab->Pushed &&
+ (*l->tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
PerlIO_pop(aTHX_ f);
return NULL;
}
/* Pseudo-layer where push does its own stack adjust */
PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
(mode) ? mode : "(Null)", (void*)arg);
- if ((*tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
- return NULL;
+ if (tab->Pushed &&
+ (*tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
+ return NULL;
}
}
return f;
Perl_PerlIO_close(pTHX_ PerlIO *f)
{
int code = -1;
+
if (PerlIOValid(f)) {
- code = (*PerlIOBase(f)->tab->Close) (aTHX_ f);
- while (*f) {
- PerlIO_pop(aTHX_ f);
- }
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+
+ if (tab && tab->Close) {
+ code = (*tab->Close)(aTHX_ f);
+ while (*f) {
+ PerlIO_pop(aTHX_ f);
+ }
+ }
+ else
+ PerlIOBase_close(aTHX_ f);
}
+
return code;
}
int
Perl_PerlIO_fileno(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Fileno) (aTHX_ f);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
}
static const char *
PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
tab->name, layers, mode, fd, imode, perm,
(void*)f, narg, (void*)args);
- f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
- f, narg, args);
+ if (tab->Open)
+ f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
+ f, narg, args);
+ else {
+ SETERRNO(EINVAL, LIB_INVARG);
+ f = NULL;
+ }
if (f) {
if (n + 1 < layera->cur) {
/*
SSize_t
Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Read) (aTHX_ f, vbuf, count);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
}
SSize_t
Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Unread) (aTHX_ f, vbuf, count);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
}
SSize_t
Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Write) (aTHX_ f, vbuf, count);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
}
int
Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Seek) (aTHX_ f, offset, whence);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
}
Off_t
Perl_PerlIO_tell(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Tell) (aTHX_ f);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
}
int
if (f) {
if (*f) {
PerlIO_funcs *tab = PerlIOBase(f)->tab;
- if (tab && tab->Flush) {
+
+ if (tab && tab->Flush)
return (*tab->Flush) (aTHX_ f);
- }
- else {
- PerlIO_debug("Cannot flush f=%p :%s\n", (void*)f, tab->name);
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ else
+ return 0; /* If no Flush defined, silently succeed. */
}
else {
PerlIO_debug("Cannot flush f=%p\n", (void*)f);
int
Perl_PerlIO_fill(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Fill) (aTHX_ f);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
}
int
PerlIO_isutf8(PerlIO *f)
{
- if (PerlIOValid(f))
- return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ if (PerlIOValid(f))
+ return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
+ else
+ SETERRNO(EBADF, SS_IVCHAN);
+
+ return -1;
}
int
Perl_PerlIO_eof(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Eof) (aTHX_ f);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
}
int
Perl_PerlIO_error(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Error) (aTHX_ f);
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return -1;
- }
+ Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
}
void
Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- (*PerlIOBase(f)->tab->Clearerr) (aTHX_ f);
- else
- SETERRNO(EBADF, SS_IVCHAN);
+ Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
}
void
Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- (*PerlIOBase(f)->tab->Setlinebuf) (aTHX_ f);
- else
- SETERRNO(EBADF, SS_IVCHAN);
+ Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
}
int
PerlIO_has_base(PerlIO *f)
{
- if (PerlIOValid(f)) {
- return (PerlIOBase(f)->tab->Get_base != NULL);
- }
- return 0;
+ if (PerlIOValid(f)) {
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+
+ if (tab)
+ return (tab->Get_base != NULL);
+ SETERRNO(EINVAL, LIB_INVARG);
+ }
+ else
+ SETERRNO(EBADF, SS_IVCHAN);
+
+ return 0;
}
int
PerlIO_fast_gets(PerlIO *f)
{
if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
- PerlIO_funcs *tab = PerlIOBase(f)->tab;
- return (tab->Set_ptrcnt != NULL);
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+
+ if (tab)
+ return (tab->Set_ptrcnt != NULL);
+ SETERRNO(EINVAL, LIB_INVARG);
}
+ else
+ SETERRNO(EBADF, SS_IVCHAN);
+
return 0;
}
{
if (PerlIOValid(f)) {
PerlIO_funcs *tab = PerlIOBase(f)->tab;
- return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
+
+ if (tab)
+ return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
+ SETERRNO(EINVAL, LIB_INVARG);
}
+ else
+ SETERRNO(EBADF, SS_IVCHAN);
+
return 0;
}
PerlIO_canset_cnt(PerlIO *f)
{
if (PerlIOValid(f)) {
- PerlIOl *l = PerlIOBase(f);
- return (l->tab->Set_ptrcnt != NULL);
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+
+ if (tab)
+ return (tab->Set_ptrcnt != NULL);
+ SETERRNO(EINVAL, LIB_INVARG);
}
+ else
+ SETERRNO(EBADF, SS_IVCHAN);
+
return 0;
}
STDCHAR *
Perl_PerlIO_get_base(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Get_base) (aTHX_ f);
- return NULL;
+ Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
}
int
Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f))
- return (*PerlIOBase(f)->tab->Get_bufsiz) (aTHX_ f);
- return 0;
+ Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
}
STDCHAR *
Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f)) {
- PerlIO_funcs *tab = PerlIOBase(f)->tab;
- if (tab->Get_ptr == NULL)
- return NULL;
- return (*tab->Get_ptr) (aTHX_ f);
- }
- return NULL;
+ Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
}
int
Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
{
- if (PerlIOValid(f)) {
- PerlIO_funcs *tab = PerlIOBase(f)->tab;
- if (tab->Get_cnt == NULL)
- return 0;
- return (*tab->Get_cnt) (aTHX_ f);
- }
- return 0;
+ Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
}
void
Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
{
- if (PerlIOValid(f)) {
- (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, NULL, cnt);
- }
+ Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
}
void
Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
{
- if (PerlIOValid(f)) {
- PerlIO_funcs *tab = PerlIOBase(f)->tab;
- if (tab->Set_ptrcnt == NULL) {
- Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
- }
- (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, ptr, cnt);
- }
+ Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
}
PerlIO *old, int narg, SV **args)
{
PerlIO_funcs *tab = PerlIO_default_btm();
- return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
- old, narg, args);
+ if (tab && tab->Open)
+ return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
+ old, narg, args);
+ SETERRNO(EINVAL, LIB_INVARG);
+ return NULL;
}
PerlIO_funcs PerlIO_raw = {
}
if (f) {
PerlIO_funcs *self = PerlIOBase(o)->tab;
- SV *arg = Nullsv;
+ SV *arg;
char buf[8];
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
self->name, (void*)f, (void*)o, (void*)param);
- if (self->Getarg) {
- arg = (*self->Getarg)(aTHX_ o,param,flags);
+ if (self->Getarg)
+ arg = (*self->Getarg)(aTHX_ o, param, flags);
+ else {
+ arg = Nullsv;
+ SETERRNO(EINVAL, LIB_INVARG);
}
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
if (arg) {
# elif defined(WIN32)
# if defined(__BORLANDC__)
f->fd = PerlLIO_dup(fileno(f));
+# elif defined(UNDER_CE)
+ /* WIN_CE does not have access to FILE internals, it hardly has FILE
+ structure at all
+ */
# else
f->_file = -1;
# endif
{
FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
SSize_t got = 0;
- if (count == 1) {
- STDCHAR *buf = (STDCHAR *) vbuf;
- /*
- * Perl is expecting PerlIO_getc() to fill the buffer Linux's
- * stdio does not do that for fread()
- */
- int ch = PerlSIO_fgetc(s);
- if (ch != EOF) {
- *buf = ch;
- got = 1;
+ for (;;) {
+ if (count == 1) {
+ STDCHAR *buf = (STDCHAR *) vbuf;
+ /*
+ * Perl is expecting PerlIO_getc() to fill the buffer Linux's
+ * stdio does not do that for fread()
+ */
+ int ch = PerlSIO_fgetc(s);
+ if (ch != EOF) {
+ *buf = ch;
+ got = 1;
+ }
}
+ else
+ got = PerlSIO_fread(vbuf, 1, count, s);
+ if (got || errno != EINTR)
+ break;
+ PERL_ASYNC_CHECK();
+ errno = 0; /* just in case */
}
- else
- got = PerlSIO_fread(vbuf, 1, count, s);
return got;
}
SSize_t
PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
- return PerlSIO_fwrite(vbuf, 1, count,
- PerlIOSelf(f, PerlIOStdio)->stdio);
+ SSize_t got;
+ for (;;) {
+ got = PerlSIO_fwrite(vbuf, 1, count,
+ PerlIOSelf(f, PerlIOStdio)->stdio);
+ if (got || errno != EINTR)
+ break;
+ PERL_ASYNC_CHECK();
+ errno = 0; /* just in case */
+ }
+ return got;
}
IV
#ifdef USE_STDIO_PTR
PerlIOStdio_get_ptr,
PerlIOStdio_get_cnt,
-#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
- PerlIOStdio_set_ptrcnt
-#else /* STDIO_PTR_LVALUE */
- NULL
-#endif /* STDIO_PTR_LVALUE */
-#else /* USE_STDIO_PTR */
+# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
+ PerlIOStdio_set_ptrcnt,
+# else
+ NULL,
+# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
+#else
NULL,
NULL,
- NULL
-#endif /* USE_STDIO_PTR */
+ NULL,
+#endif /* USE_STDIO_PTR */
};
/* Note that calls to PerlIO_exportFILE() are reversed using
#ifdef PERLIO_USING_CRLF
# ifdef PERLIO_IS_BINMODE_FD
if (PERLIO_IS_BINMODE_FD(fd))
- PerlIO_binmode(f, '<'/*not used*/, O_BINARY, Nullch);
+ PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, Nullch);
else
# endif
/*
PerlIO *
PerlIO_tmpfile(void)
{
- /*
- * I have no idea how portable mkstemp() is ...
- */
-#if defined(WIN32) || !defined(HAVE_MKSTEMP)
- dTHX;
- PerlIO *f = NULL;
- FILE *stdio = PerlSIO_tmpfile();
- if (stdio) {
- if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), &PerlIO_stdio, "w+", Nullsv))) {
- PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
- s->stdio = stdio;
- }
- }
- return f;
-#else
- dTHX;
- SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
- int fd = mkstemp(SvPVX(sv));
- PerlIO *f = NULL;
- if (fd >= 0) {
- f = PerlIO_fdopen(fd, "w+");
- if (f) {
- PerlIOBase(f)->flags |= PERLIO_F_TEMP;
- }
- PerlLIO_unlink(SvPVX(sv));
- SvREFCNT_dec(sv);
- }
- return f;
-#endif
+ dTHX;
+ PerlIO *f = NULL;
+ int fd = -1;
+ SV *sv = Nullsv;
+ GV *gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
+
+ if (!gv) {
+ ENTER;
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvn("File::Temp", 10), Nullsv, Nullsv, Nullsv);
+ gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
+ GvIMPORTED_CV_on(gv);
+ LEAVE;
+ }
+
+ if (gv && GvCV(gv)) {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ PUTBACK;
+ if (call_sv((SV*)GvCV(gv), G_SCALAR)) {
+ GV *gv = (GV*)SvRV(newSVsv(*PL_stack_sp--));
+ IO *io = gv ? GvIO(gv) : 0;
+ fd = io ? PerlIO_fileno(IoIFP(io)) : -1;
+ }
+ SPAGAIN;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ }
+
+ if (fd >= 0) {
+ f = PerlIO_fdopen(fd, "w+");
+ if (sv) {
+ if (f)
+ PerlIOBase(f)->flags |= PERLIO_F_TEMP;
+ PerlLIO_unlink(SvPVX(sv));
+ SvREFCNT_dec(sv);
+ }
+ }
+
+ return f;
}
#undef HAS_FSETPOS