#define dSYS dNOOP
#endif
-#define VOIDUSED 1
-#ifdef PERL_MICRO
-# include "uconfig.h"
-#else
-# ifndef USE_CROSS_COMPILE
-# include "config.h"
-# else
-# include "xconfig.h"
-# endif
-#endif
-
#define PERLIO_NOT_STDIO 0
-#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
-/*
- * #define PerlIO FILE
- */
-#endif
/*
* This file provides those parts of PerlIO abstraction
* which are not #defined in perlio.h.
extern off_t ftello(FILE *);
#endif
-#ifndef USE_SFIO
+#define NATIVE_0xd CR_NATIVE
+#define NATIVE_0xa LF_NATIVE
EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
# endif
#endif
}
-#endif /* sfio */
#ifndef O_ACCMODE
#define O_ACCMODE 3 /* Assume traditional implementation */
mode[ix++] = '+';
}
}
+#ifdef PERLIO_BINARY_AND_TEXT_DIFFERENT_AND_EFFECTIVE
if (rawmode & O_BINARY)
mode[ix++] = 'b';
+#endif
mode[ix] = '\0';
return ptype;
}
int
PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
{
-#ifdef USE_SFIO
- PERL_UNUSED_ARG(iotype);
- PERL_UNUSED_ARG(mode);
- PERL_UNUSED_ARG(names);
- return 1;
-#else
return perlsio_binmode(fp, iotype, mode);
-#endif
}
PerlIO *
if (*args == &PL_sv_undef)
return PerlIO_tmpfile();
else {
- const char *name = SvPV_nolen_const(*args);
- if (!IS_SAFE_PATHNAME(*args, "open"))
+ STRLEN len;
+ const char *name = SvPV_const(*args, len);
+ if (!IS_SAFE_PATHNAME(name, len, "open"))
return NULL;
if (*mode == IoTYPE_NUMERIC) {
return NULL;
}
+XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO__Layer__find)
{
dXSARGS;
#else /* PERLIO_IS_STDIO */
-#ifdef USE_SFIO
-
-#undef HAS_FSETPOS
-#undef HAS_FGETPOS
-
-/*
- * This section is just to make sure these functions get pulled in from
- * libsfio.a
- */
-
-#undef PerlIO_tmpfile
-PerlIO *
-PerlIO_tmpfile(void)
-{
- return sftmp(0);
-}
-
-void
-PerlIO_init(pTHX)
-{
- PERL_UNUSED_CONTEXT;
- /*
- * Force this file to be included in perl binary. Which allows this
- * file to force inclusion of other functions that may be required by
- * loadable extensions e.g. for FileHandle::tmpfile
- */
-
- /*
- * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
- * results in a lot of lseek()s to regular files and lot of small
- * writes to pipes.
- */
- sfset(sfstdout, SF_SHARE, 0);
-}
-
-/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
-PerlIO *
-PerlIO_importFILE(FILE *stdio, const char *mode)
-{
- const int fd = fileno(stdio);
- if (!mode || !*mode) {
- mode = "r+";
- }
- return PerlIO_fdopen(fd, mode);
-}
-
-FILE *
-PerlIO_findFILE(PerlIO *pio)
-{
- const int fd = PerlIO_fileno(pio);
- FILE * const f = fdopen(fd, "r+");
- PerlIO_flush(pio);
- if (!f && errno == EINVAL)
- f = fdopen(fd, "w");
- if (!f && errno == EINVAL)
- f = fdopen(fd, "r");
- return f;
-}
-
-
-#else /* USE_SFIO */
/*======================================================================================*/
/*
* Implement all the PerlIO interface ourselves.
}
}
if (PL_perlio_debug_fd > 0) {
+ int rc = 0;
#ifdef USE_ITHREADS
const char * const s = CopFILE(PL_curcop);
/* Use fixed buffer as sv_catpvf etc. needs SVs */
char buffer[1024];
const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
- PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
+ rc = PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
#else
const char *s = CopFILE(PL_curcop);
STRLEN len;
Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
s = SvPV_const(sv, len);
- PerlLIO_write(PL_perlio_debug_fd, s, len);
+ rc = PerlLIO_write(PL_perlio_debug_fd, s, len);
SvREFCNT_dec(sv);
#endif
+ /* silently ignore failures */
+ PERL_UNUSED_VAR(rc);
}
va_end(ap);
}
list = PerlIO_list_alloc(aTHX);
for (i=0; i < proto->cur; i++) {
SV *arg = proto->array[i].arg;
-#ifdef sv_dup
+#ifdef USE_ITHREADS
if (arg && param)
arg = sv_dup(arg, param);
#else
perlio_mg_free
};
+XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
{
dXSARGS;
return sv;
}
+XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO__Layer__NoWarnings)
{
/* This is used as a %SIG{__WARN__} handler to suppress warnings
XSRETURN(0);
}
+XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO__Layer__find)
{
dVAR;
Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
}
-int
+SSize_t
Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
{
+ /* Note that Get_bufsiz returns a Size_t */
Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
}
Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
}
-int
+SSize_t
Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
}
void
-Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
+Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t 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)
+Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
{
Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
}
{
if (!arg)
return NULL;
-#ifdef sv_dup
+#ifdef USE_ITHREADS
if (param) {
arg = sv_dup(arg, param);
SvREFCNT_inc_simple_void_NN(arg);
PerlIO_funcs * const self = PerlIOBase(o)->tab;
SV *arg = NULL;
char buf[8];
+ assert(self);
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
self ? self->name : "(Null)",
(void*)f, (void*)o, (void*)param);
if (self && self->Getarg)
arg = (*self->Getarg)(aTHX_ o, param, flags);
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
- if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
+ if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
SvREFCNT_dec(arg);
}
oflags |= O_WRONLY;
break;
}
+#ifdef PERLIO_BINARY_AND_TEXT_DIFFERENT_AND_EFFECTIVE
if (*mode == 'b') {
oflags |= O_BINARY;
oflags &= ~O_TEXT;
mode++;
}
else {
-#ifdef PERLIO_USING_CRLF
/*
* If neither "t" nor "b" was specified, open the file
* in O_BINARY mode.
*/
oflags |= O_BINARY;
-#endif
}
+#endif
if (*mode || oflags == -1) {
SETERRNO(EINVAL, LIB_INVARG);
oflags = -1;
#endif
}
if (imode != -1) {
- const char *path = SvPV_nolen_const(*args);
- if (!IS_SAFE_PATHNAME(*args, "open"))
+ STRLEN len;
+ const char *path = SvPV_const(*args, len);
+ if (!IS_SAFE_PATHNAME(path, len, "open"))
return NULL;
fd = PerlLIO_open3(path, imode, perm);
}
}
if (!PerlIOValid(f)) {
if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
+ PerlLIO_close(fd);
return NULL;
}
}
PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
return f;
}
+ PerlLIO_close(fd);
}
return NULL;
}
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
/* We never call down so do any pending stuff now */
PerlIO_flush(PerlIONext(f));
+ return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
}
else {
return -1;
PerlIO *f = NULL;
if (stdio) {
PerlIOStdio *s;
+ int fd0 = fileno(stdio);
+ if (fd0 < 0) {
+ return NULL;
+ }
if (!mode || !*mode) {
/* We need to probe to see how we can open the stream
so start with read/write and then try write and read
Note that the errno value set by a failing fdopen
varies between stdio implementations.
*/
- const int fd = PerlLIO_dup(fileno(stdio));
- FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
+ const int fd = PerlLIO_dup(fd0);
+ FILE *f2;
+ if (fd < 0) {
+ return f;
+ }
+ f2 = PerlSIO_fdopen(fd, (mode = "r+"));
if (!f2) {
f2 = PerlSIO_fdopen(fd, (mode = "w"));
}
}
fclose(f2);
}
- if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
+ if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
s = PerlIOSelf(f, PerlIOStdio);
s->stdio = stdio;
PerlIOUnix_refcnt_inc(fileno(stdio));
{
char tmode[8];
if (PerlIOValid(f)) {
- const char * const path = SvPV_nolen_const(*args);
+ STRLEN len;
+ const char * const path = SvPV_const(*args, len);
PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
FILE *stdio;
- if (!IS_SAFE_PATHNAME(*args, "open"))
+ if (!IS_SAFE_PATHNAME(path, len, "open"))
return NULL;
PerlIOUnix_refcnt_dec(fileno(s->stdio));
- stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
- s->stdio);
+ stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
+ s->stdio);
if (!s->stdio)
return NULL;
s->stdio = stdio;
}
else {
if (narg > 0) {
- const char * const path = SvPV_nolen_const(*args);
- if (!IS_SAFE_PATHNAME(*args, "open"))
+ STRLEN len;
+ const char * const path = SvPV_const(*args, len);
+ if (!IS_SAFE_PATHNAME(path, len, "open"))
return NULL;
if (*mode == IoTYPE_NUMERIC) {
mode++;
}
return f;
}
+ PerlLIO_close(fd);
}
}
return NULL;
*/
f->_fileno = -1;
return 1;
-# elif defined(__sun__)
+# elif defined(__sun)
PERL_UNUSED_ARG(f);
return 0;
# elif defined(__hpux)
}
if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
/* Did not change pointer as expected */
- fgetc(s); /* get char back again */
- break;
+ if (fgetc(s) != EOF) /* get char back again */
+ break;
}
/* It worked ! */
count--;
FILE *stdio = NULL;
if (PerlIOValid(f)) {
char buf[8];
+ int fd = PerlIO_fileno(f);
+ if (fd < 0) {
+ return NULL;
+ }
PerlIO_flush(f);
if (!mode || !*mode) {
mode = PerlIO_modestr(f, buf);
{
PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
- *(c->nl) = 0xd;
+ *(c->nl) = NATIVE_0xd;
c->nl = NULL;
}
if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
const int ch = *--buf;
if (ch == '\n') {
if (b->ptr - 2 >= b->buf) {
- *--(b->ptr) = 0xa;
- *--(b->ptr) = 0xd;
+ *--(b->ptr) = NATIVE_0xa;
+ *--(b->ptr) = NATIVE_0xd;
unread++;
count--;
}
else {
/* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
- *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
+ *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
+ '\r' */
unread++;
count--;
}
PerlIO_get_base(f);
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
- if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
+ if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
scan:
- while (nl < b->end && *nl != 0xd)
+ while (nl < b->end && *nl != NATIVE_0xd)
nl++;
- if (nl < b->end && *nl == 0xd) {
+ if (nl < b->end && *nl == NATIVE_0xd) {
test:
if (nl + 1 < b->end) {
- if (nl[1] == 0xa) {
+ if (nl[1] == NATIVE_0xa) {
*nl = '\n';
c->nl = nl;
}
b->buf--; /* Point at space */
b->ptr = nl = b->buf; /* Which is what we hand
* off */
- *nl = 0xd; /* Fill in the CR */
+ *nl = NATIVE_0xd; /* Fill in the CR */
if (code == 0)
goto test; /* fill() call worked */
/*
if (!ptr) {
if (c->nl) {
ptr = c->nl + 1;
- if (ptr == b->end && *c->nl == 0xd) {
+ if (ptr == b->end && *c->nl == NATIVE_0xd) {
/* Deferred CR at end of buffer case - we lied about count */
ptr--;
}
*/
IV flags = PerlIOBase(f)->flags;
STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
- if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
+ if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
/* Deferred CR at end of buffer case - we lied about count */
chk--;
}
/*
* They have taken what we lied about
*/
- *(c->nl) = 0xd;
+ *(c->nl) = NATIVE_0xd;
c->nl = NULL;
ptr++;
}
break;
}
else {
- *(b->ptr)++ = 0xd; /* CR */
- *(b->ptr)++ = 0xa; /* LF */
+ *(b->ptr)++ = NATIVE_0xd; /* CR */
+ *(b->ptr)++ = NATIVE_0xa; /* LF */
buf++;
if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
PerlIO_flush(f);
{
PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
if (c->nl) {
- *(c->nl) = 0xd;
+ *(c->nl) = NATIVE_0xd;
c->nl = NULL;
}
return PerlIOBuf_flush(aTHX_ f);
va_list apc;
Perl_va_copy(ap, apc);
sv = vnewSVpvf(fmt, &apc);
+ va_end(apc);
#else
sv = vnewSVpvf(fmt, &ap);
#endif
char tempname[] = "/tmp/PerlIO_XXXXXX";
const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
SV * sv = NULL;
+ int old_umask = umask(0600);
/*
* I have no idea how portable mkstemp() is ... NI-S
*/
fd = mkstemp(SvPVX(sv));
}
if (fd < 0) {
+ SvREFCNT_dec(sv);
sv = NULL;
/* else we try /tmp */
fd = mkstemp(tempname);
}
+ if (fd < 0) {
+ /* Try cwd */
+ sv = newSVpvs(".");
+ sv_catpv(sv, tempname + 4);
+ fd = mkstemp(SvPVX(sv));
+ }
+ umask(old_umask);
if (fd >= 0) {
f = PerlIO_fdopen(fd, "w+");
if (f)
#undef HAS_FSETPOS
#undef HAS_FGETPOS
-#endif /* USE_SFIO */
#endif /* PERLIO_IS_STDIO */
/*======================================================================================*/
}
#endif
-#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
+#if !defined(HAS_VPRINTF)
int
vprintf(char *pat, char *args)
#endif
-#ifndef PerlIO_vsprintf
-int
-PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
-{
- dTHX;
- const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
- PERL_UNUSED_CONTEXT;
-
-#ifndef PERL_MY_VSNPRINTF_GUARDED
- if (val < 0 || (n > 0 ? val >= n : 0)) {
- Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
- }
-#endif
- return val;
-}
-#endif
-
-#ifndef PerlIO_sprintf
-int
-PerlIO_sprintf(char *s, int n, const char *fmt, ...)
-{
- va_list ap;
- int result;
- va_start(ap, fmt);
- result = PerlIO_vsprintf(s, n, fmt, ap);
- va_end(ap);
- return result;
-}
-#endif
-
/*
* Local variables:
* c-indentation-style: bsd