#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 */
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);
+ STRLEN len;
+ const char *name = SvPV_const(*args, len);
+ if (!IS_SAFE_PATHNAME(name, len, "open"))
+ return NULL;
+
if (*mode == IoTYPE_NUMERIC) {
fd = PerlLIO_open3(name, imode, perm);
if (fd >= 0)
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
len = strlen(name);
for (i = 0; i < PL_known_layers->cur; i++) {
PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
- if (memEQ(f->name, name, len) && f->name[len] == 0) {
+ const STRLEN this_len = strlen(f->name);
+ if (this_len == len && memEQ(f->name, name, len)) {
PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
return f;
}
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);
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_BINARY;
mode++;
}
- /*
- * Always open in binary mode
- */
- oflags |= O_BINARY;
+ else {
+#ifdef PERLIO_USING_CRLF
+ /*
+ * If neither "t" nor "b" was specified, open the file
+ * in O_BINARY mode.
+ */
+ oflags |= O_BINARY;
+#endif
+ }
if (*mode || oflags == -1) {
SETERRNO(EINVAL, LIB_INVARG);
oflags = -1;
#endif
}
if (imode != -1) {
- const char *path = SvPV_nolen_const(*args);
+ 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;
{
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(path, len, "open"))
+ return NULL;
PerlIOUnix_refcnt_dec(fileno(s->stdio));
stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
s->stdio);
}
else {
if (narg > 0) {
- const char * const path = SvPV_nolen_const(*args);
+ STRLEN len;
+ const char * const path = SvPV_const(*args, len);
+ if (!IS_SAFE_PATHNAME(path, len, "open"))
+ return NULL;
if (*mode == IoTYPE_NUMERIC) {
mode++;
fd = PerlLIO_open3(path, imode, perm);
}
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)
{
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);
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
https://perl5.git.perl.org / perl5.git / blobdiff