else {
exsv = newSVpvs_flags("Died", SVs_TEMP);
}
- die_sv(exsv);
- RETURN;
+ return die_sv(exsv);
}
/* I/O. */
RETURN;
}
+/* These are private to this function, which is private to this file.
+ Use 0x04 rather than the next available bit, to help the compiler if the
+ architecture can generate more efficient instructions. */
+#define MORTALIZE_NOT_NEEDED 0x04
+#define TIED_HANDLE_ARGC_SHIFT 3
+
static OP *
S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
- IO *const io, MAGIC *const mg, const U32 gimme,
- unsigned int argc, ...)
+ IO *const io, MAGIC *const mg, const U32 flags, ...)
{
+ U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT;
+
PERL_ARGS_ASSERT_TIED_HANDLE_METHOD;
+ /* Ensure that our flag bits do not overlap. */
+ assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0);
+ assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0);
+
PUSHMARK(sp);
PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
if (argc) {
+ const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED;
va_list args;
- va_start(args, argc);
+ va_start(args, flags);
do {
SV *const arg = va_arg(args, SV *);
- PUSHs(arg);
+ if(mortalize_not_needed)
+ PUSHs(arg);
+ else
+ mPUSHs(arg);
} while (--argc);
va_end(args);
}
PUTBACK;
ENTER_with_name("call_tied_handle_method");
- call_method(methname, gimme);
+ call_method(methname, flags & G_WANT);
LEAVE_with_name("call_tied_handle_method");
return NORMAL;
}
#define tied_handle_method(a,b,c,d) \
- S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,0)
+ S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR)
#define tied_handle_method1(a,b,c,d,e) \
- S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
+ S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e)
#define tied_handle_method2(a,b,c,d,e,f) \
- S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
+ S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f)
PP(pp_close)
{
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_func, "pipe");
- return NORMAL;
#endif
}
function, which I don't think that the optimiser will be able to
figure out. Although, as it's a static function, in theory it
could. */
- return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg, G_SCALAR,
- discp ? 1 : 0, discp);
+ return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg,
+ G_SCALAR|MORTALIZE_NOT_NEEDED
+ | (discp
+ ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0),
+ discp);
}
}
call_method(methname, G_SCALAR);
}
else {
- /* Not clear why we don't call call_method here too.
- * perhaps to get different error message ?
+ /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
+ * will attempt to invoke IO::File::TIEARRAY, with (best case) the
+ * wrong error message, and worse case, supreme action at a distance.
+ * (Sorry obfuscation writers. You're not going to be given this one.)
*/
STRLEN len;
const char *name = SvPV_nomg_const(*MARK, len);
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
- DIE(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
if (!SvPOK(sv)) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
RETURN;
#else
DIE(aTHX_ "select not implemented");
- return NORMAL;
#endif
}
MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
const U32 gimme = GIMME_V;
- S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme, 0);
+ S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
if (gimme == G_SCALAR) {
SPAGAIN;
SvSetMagicSV_nosteal(TARG, TOPs);
RETPUSHNO;
if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
- return tied_handle_method1("EOF", SP, io, mg,
- sv_2mortal(newSVuv(which)));
+ return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
}
if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
#if LSEEKSIZE > IVSIZE
- SV *const offset_sv = sv_2mortal(newSVnv((NV) offset));
+ SV *const offset_sv = newSVnv((NV) offset);
#else
- SV *const offset_sv = sv_2mortal(newSViv(offset));
+ SV *const offset_sv = newSViv(offset);
#endif
return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
- sv_2mortal(newSViv(whence)));
+ newSViv(whence));
}
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "flock()");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "socket");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "socketpair");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "bind");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "connect");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "listen");
- return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, "accept");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "shutdown");
- return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
#endif
}
#endif
}
- result = my_stat();
+ result = my_stat_flags(0);
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
STACKED_FTEST_CHECK;
- result = my_stat();
+ result = my_stat_flags(0);
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
STACKED_FTEST_CHECK;
- result = my_stat();
+ result = my_stat_flags(0);
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
I32 result;
tryAMAGICftest_MG('l');
- result = my_lstat();
+ result = my_lstat_flags(0);
SPAGAIN;
if (result < 0)
int fd;
GV *gv;
SV *tmpsv = NULL;
+ char *name = NULL;
+ STRLEN namelen;
tryAMAGICftest_MG('t');
gv = MUTABLE_GV(POPs);
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
gv = MUTABLE_GV(SvRV(POPs));
- else
- gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
+ else {
+ tmpsv = POPs;
+ name = SvPV_nomg(tmpsv, namelen);
+ gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
+ }
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
else if (tmpsv && SvOK(tmpsv)) {
- const char *tmps = SvPV_nolen_const(tmpsv);
- if (isDIGIT(*tmps))
- fd = atoi(tmps);
+ if (isDIGIT(*name))
+ fd = atoi(name);
else
RETPUSHUNDEF;
}
really_filename:
PL_statgv = NULL;
PL_laststype = OP_STAT;
- sv_setpv(PL_statname, SvPV_nolen_const(sv));
+ sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
'\n'))
RETURN;
#else
DIE(aTHX_ PL_no_func, "chroot");
- return NORMAL;
#endif
}
{
/* Have neither. */
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
}
#endif
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "opendir");
- return NORMAL;
#endif
}
{
#if !defined(Direntry_t) || !defined(HAS_READDIR)
DIE(aTHX_ PL_no_dir_func, "readdir");
- return NORMAL;
#else
#if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "telldir");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "seekdir");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "rewinddir");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "closedir");
- return NORMAL;
#endif
}
RETURN;
# else
DIE(aTHX_ PL_no_func, "fork");
- return NORMAL;
# endif
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "wait");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "waitpid");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getppid");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getpgrp()");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpgrp()");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getpriority()");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpriority()");
- return NORMAL;
#endif
}
RETURN;
# else
DIE(aTHX_ "times not implemented");
- return NORMAL;
# endif
#endif /* HAS_TIMES */
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "alarm");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ "System V IPC is not implemented on this machine");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "gethostent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getnetent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getprotoent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getservent");
- return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "sethostent");
- return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setnetent");
- return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setprotoent");
- return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setservent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endhostent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endnetent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endprotoent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endservent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "setpwent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "endpwent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "setgrent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "endgrent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getlogin");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "syscall");
- return NORMAL;
#endif
}