/*
* Hour after hour for nearly three weary days he had jogged up and down,
* over passes, and through long dales, and across many streams.
+ *
+ * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
*/
/* This file contains the functions needed to implement PerlIO, which
* This used to be contents of do_binmode in doio.c
*/
#ifdef DOSISH
-# if defined(atarist) || defined(__MINT__)
+# if defined(atarist)
PERL_UNUSED_ARG(iotype);
if (!fflush(fp)) {
if (mode & O_BINARY)
if (--list->refcnt == 0) {
if (list->array) {
IV i;
- for (i = 0; i < list->cur; i++) {
- if (list->array[i].arg)
- SvREFCNT_dec(list->array[i].arg);
- }
+ for (i = 0; i < list->cur; i++)
+ SvREFCNT_dec(list->array[i].arg);
Safefree(list->array);
}
Safefree(list);
} else {
SV * const pkgsv = newSVpvs("PerlIO");
SV * const layer = newSVpvn(name, len);
- CV * const cv = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
+ CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
ENTER;
- SAVEINT(PL_in_load_module);
+ SAVEBOOL(PL_in_load_module);
if (cv) {
SAVEGENERICSV(PL_warnhook);
- PL_warnhook = (SV *) (SvREFCNT_inc_simple_NN(cv));
+ PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
}
- PL_in_load_module++;
+ PL_in_load_module = TRUE;
/*
* The two SVs are magically freed by load_module
*/
Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
- PL_in_load_module--;
LEAVE;
return PerlIO_find_layer(aTHX_ name, len, 0);
}
perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
{
if (SvROK(sv)) {
- IO * const io = GvIOn((GV *) SvRV(sv));
+ IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
PerlIO * const ifp = IoIFP(io);
PerlIO * const ofp = IoOFP(io);
Perl_warn(aTHX_ "set %" SVf " %p %p %p",
perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
{
if (SvROK(sv)) {
- IO * const io = GvIOn((GV *) SvRV(sv));
+ IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
PerlIO * const ifp = IoIFP(io);
PerlIO * const ofp = IoOFP(io);
Perl_warn(aTHX_ "get %" SVf " %p %p %p",
MAGIC *mg;
int count = 0;
int i;
- sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
+ sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
SvRMAGICAL_off(sv);
mg = mg_find(sv, PERL_MAGIC_ext);
mg->mg_virtual = &perlio_vtab;
* seen as an invalid separator character.
*/
const char q = ((*s == '\'') ? '"' : '\'');
- if (ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER),
- "Invalid separator character %c%c%c in PerlIO layer specification %s",
- q, *s, q, s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
+ "Invalid separator character %c%c%c in PerlIO layer specification %s",
+ q, *s, q, s);
SETERRNO(EINVAL, LIB_INVARG);
return -1;
}
*/
case '\0':
e--;
- if (ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER),
- "Argument list not closed for PerlIO layer \"%.*s\"",
- (int) (e - s), s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
+ "Argument list not closed for PerlIO layer \"%.*s\"",
+ (int) (e - s), s);
return -1;
default:
/*
arg = newSVpvn(as, alen);
PerlIO_list_push(aTHX_ av, layer,
(arg) ? arg : &PL_sv_undef);
- if (arg)
- SvREFCNT_dec(arg);
+ SvREFCNT_dec(arg);
}
else {
- if (ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
- (int) llen, s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
+ (int) llen, s);
return -1;
}
}
PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
{
if (tab->fsize != sizeof(PerlIO_funcs)) {
- mismatch:
- Perl_croak(aTHX_ "Layer does not match this perl");
+ Perl_croak( aTHX_
+ "%s (%d) does not match %s (%d)",
+ "PerlIO layer function table size", tab->fsize,
+ "size expected by this perl", sizeof(PerlIO_funcs) );
}
if (tab->size) {
PerlIOl *l;
if (tab->size < sizeof(PerlIOl)) {
- goto mismatch;
+ Perl_croak( aTHX_
+ "%s (%d) smaller than %s (%d)",
+ "PerlIO layer instance size", tab->size,
+ "size expected by this perl", sizeof(PerlIOl) );
}
/* Real layer with a data area */
if (f) {
PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
{
int code = 0;
+ ENTER;
+ save_scalar(PL_errgv);
if (f && names) {
PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
code = PerlIO_parse_layers(aTHX_ layers, names);
}
PerlIO_list_free(aTHX_ layers);
}
+ LEAVE;
return code;
}
/*
* For any scalar type load the handler which is bundled with perl
*/
- if (SvTYPE(sv) < SVt_PVAV) {
+ if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
/* This isn't supposed to happen, since PerlIO::scalar is core,
* but could happen anyway in smaller installs or with PAR */
- if (!f && ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
+ if (!f)
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
return f;
}
arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
PerlIO_list_push(aTHX_ layera, l->tab,
(arg) ? arg : &PL_sv_undef);
- if (arg)
- SvREFCNT_dec(arg);
+ SvREFCNT_dec(arg);
l = *PerlIONext(&l);
}
}
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)) {
- const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
+ if (PerlIOValid(f)) {
+ if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
+ const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
- if (tab)
- return (tab->Set_ptrcnt != NULL);
- SETERRNO(EINVAL, LIB_INVARG);
+ if (tab)
+ return (tab->Set_ptrcnt != NULL);
+ }
}
- else
- SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
if (tab)
return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
- SETERRNO(EINVAL, LIB_INVARG);
}
- else
- SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
if (tab)
return (tab->Set_ptrcnt != NULL);
- SETERRNO(EINVAL, LIB_INVARG);
}
- else
- SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
- if (arg)
- SvREFCNT_dec(arg);
+ SvREFCNT_dec(arg);
}
return f;
}
mode++;
else {
imode = PerlIOUnix_oflags(mode);
+#ifdef VMS
+ perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
+#else
perm = 0666;
+#endif
}
if (imode != -1) {
const char *path = SvPV_nolen_const(*args);
stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
set_this:
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(stdio));
+ if(stdio) {
+ PerlIOUnix_refcnt_inc(fileno(stdio));
+ }
}
return f;
}
const int fd = fileno(stdio);
int invalidate = 0;
IV result = 0;
- int saveerr = 0;
int dupfd = -1;
+ dSAVEDERRNO;
#ifdef USE_ITHREADS
dVAR;
#endif
fileno slot of the FILE *
*/
result = PerlIO_flush(f);
- saveerr = errno;
+ SAVE_ERRNO;
invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
if (!invalidate) {
#ifdef USE_ITHREADS
}
#endif
}
+ } else {
+ SAVE_ERRNO; /* This is here only to silence compiler warnings */
}
result = PerlSIO_fclose(stdio);
/* We treat error from stdio as success if we invalidated
errno may NOT be expected EBADF
*/
if (invalidate && result != 0) {
- errno = saveerr;
+ RESTORE_ERRNO;
result = 0;
}
#ifdef SOCKS5_VERSION_NAME
/*
* Not writeable - sync by attempting a seek
*/
- const int err = errno;
+ dSAVE_ERRNO;
if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
- errno = err;
+ RESTORE_ERRNO;
#endif
}
return 0;
*/
PerlLIO_setmode(fd, O_BINARY);
#endif
+#ifdef VMS
+#include <rms.h>
+ /* Enable line buffering with record-oriented regular files
+ * so we don't introduce an extraneous record boundary when
+ * the buffer fills up.
+ */
+ if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
+ Stat_t st;
+ if (PerlLIO_fstat(fd, &st) == 0
+ && S_ISREG(st.st_mode)
+ && (st.st_fab_rfm == FAB$C_VAR
+ || st.st_fab_rfm == FAB$C_VFC)) {
+ PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
+ }
+ }
+#endif
}
}
}
if (!b->buf) {
if (!b->bufsiz)
- b->bufsiz = 4096;
- b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
+ b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
+ Newxz(b->buf,b->bufsiz, STDCHAR);
if (!b->buf) {
b->buf = (STDCHAR *) & b->oneword;
b->bufsiz = sizeof(b->oneword);
PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
#ifndef PERLIO_USING_CRLF
/* CRLF is unusual case - if this is just the :crlf layer pop it */
- if (PerlIOBase(f)->tab == &PerlIO_crlf) {
- PerlIO_pop(aTHX_ f);
- }
+ PerlIO_pop(aTHX_ f);
#endif
}
return 0;
f = PerlIO_fdopen(fd, "w+b");
#else /* WIN32 */
# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
- SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
+ int fd = -1;
+ char tempname[] = "/tmp/PerlIO_XXXXXX";
+ const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
+ SV * sv = NULL;
/*
* I have no idea how portable mkstemp() is ... NI-S
*/
- const int fd = mkstemp(SvPVX(sv));
+ if (tmpdir && *tmpdir) {
+ /* if TMPDIR is set and not empty, we try that first */
+ sv = newSVpv(tmpdir, 0);
+ sv_catpv(sv, tempname + 4);
+ fd = mkstemp(SvPVX(sv));
+ }
+ if (fd < 0) {
+ sv = NULL;
+ /* else we try /tmp */
+ fd = mkstemp(tempname);
+ }
if (fd >= 0) {
f = PerlIO_fdopen(fd, "w+");
if (f)
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
- PerlLIO_unlink(SvPVX_const(sv));
+ PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
}
SvREFCNT_dec(sv);
# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
if (!direction)
return NULL;
- layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
- 0, direction, 5, 0, 0);
+ layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
assert(layers);
return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;