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);
SV * const layer = newSVpvn(name, len);
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 = 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);
}
arg = newSVpvn(as, alen);
PerlIO_list_push(aTHX_ av, layer,
(arg) ? arg : &PL_sv_undef);
- if (arg)
- SvREFCNT_dec(arg);
+ SvREFCNT_dec(arg);
}
else {
Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
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) {
/*
* 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 */
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);
}
}
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);
if (!b->buf) {
if (!b->bufsiz)
b->bufsiz = 4096;
- b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
+ Newxz(b->buf,b->bufsiz, STDCHAR);
if (!b->buf) {
b->buf = (STDCHAR *) & b->oneword;
b->bufsiz = sizeof(b->oneword);
int fd = -1;
char tempname[] = "/tmp/PerlIO_XXXXXX";
const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
- SV * const sv = tmpdir && *tmpdir ? newSVpv(tmpdir, 0) : NULL;
+ SV * sv = NULL;
/*
* I have no idea how portable mkstemp() is ... NI-S
*/
- if (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);
}
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
}
- if (sv)
- SvREFCNT_dec(sv);
+ SvREFCNT_dec(sv);
# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
FILE * const stdio = PerlSIO_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;