else {
exsv = newSVpvs_flags("Died", SVs_TEMP);
}
- die_sv(exsv);
- RETURN;
+ return die_sv(exsv);
}
/* I/O. */
GV * const gv = MUTABLE_GV(*++MARK);
- if (!isGV(gv))
+ if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
DIE(aTHX_ PL_no_usym, "filehandle");
if ((io = GvIOp(gv))) {
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_func, "pipe");
- return NORMAL;
#endif
}
methname = "TIEARRAY";
break;
case SVt_PVGV:
+ case SVt_PVLV:
if (isGV_with_GP(varsv)) {
+ if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
+ deprecate("tie on a handle without *");
+ GvFLAGS(varsv) |= GVf_TIEWARNED;
+ }
methname = "TIEHANDLE";
how = PERL_MAGIC_tiedscalar;
/* For tied filehandles, we apply tiedscalar magic to the IO
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);
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
+ if (isGV_with_GP(sv)) {
+ if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
+ deprecate("untie on a handle without *");
+ GvFLAGS(sv) |= GVf_TIEWARNED;
+ }
+ if (!(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
+ }
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
+ if (isGV_with_GP(sv)) {
+ if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
+ deprecate("tied on a handle without *");
+ GvFLAGS(sv) |= GVf_TIEWARNED;
+ }
+ if (!(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHUNDEF;
+ }
if ((mg = SvTIED_mg(sv, how))) {
SV *osv = SvTIED_obj(sv, mg);
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
}
PERL_ARGS_ASSERT_DOFORM;
+ if (cv && CvCLONE(cv))
+ cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
+
ENTER;
SAVETMPS;
not_a_format_reference:
DIE(aTHX_ "Not a format reference");
}
- if (CvCLONE(cv))
- cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
-
IoFLAGS(io) &= ~IOf_DIDTOP;
return doform(cv,gv,PL_op->op_next);
}
SV **newsp;
I32 gimme;
register PERL_CONTEXT *cx;
+ OP *retop;
if (!io || !(ofp = IoOFP(io)))
goto forget_top;
else
DIE(aTHX_ "Undefined top format called");
}
- if (cv && CvCLONE(cv))
- cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
return doform(cv, gv, PL_op);
}
forget_top:
POPBLOCK(cx,PL_curpm);
POPFORMAT(cx);
+ retop = cx->blk_sub.retop;
LEAVE;
fp = IoOFP(io);
PUTBACK;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
- return cx->blk_sub.retop;
+ return retop;
}
PP(pp_prtf)
(struct sockaddr *)namebuf, &bufsize);
if (count < 0)
RETPUSHUNDEF;
+ /* MSG_TRUNC can give oversized count; quietly lose it */
+ if (count > length)
+ count = length;
#ifdef EPOC
/* Bogus return without padding */
bufsize = sizeof (struct sockaddr_in);
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;
}
tryAMAGICftest_MG(opchar);
+ STACKED_FTEST_CHECK;
+
/* I believe that all these three are likely to be defined on most every
system these days. */
#ifndef S_ISUID
- if(PL_op->op_type == OP_FTSUID)
+ if(PL_op->op_type == OP_FTSUID) {
+ if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+ (void) POPs;
RETPUSHNO;
+ }
#endif
#ifndef S_ISGID
- if(PL_op->op_type == OP_FTSGID)
+ if(PL_op->op_type == OP_FTSGID) {
+ if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+ (void) POPs;
RETPUSHNO;
+ }
#endif
#ifndef S_ISVTX
- if(PL_op->op_type == OP_FTSVTX)
+ if(PL_op->op_type == OP_FTSVTX) {
+ if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+ (void) POPs;
RETPUSHNO;
+ }
#endif
- 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');
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
- else if (isGV(TOPs))
+ else if (isGV_with_GP(TOPs))
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;
}
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
- else if (isGV(TOPs))
+ else if (isGV_with_GP(TOPs))
gv = MUTABLE_GV(POPs);
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
gv = MUTABLE_GV(SvRV(POPs));
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
}
+#ifdef __GLIBC__
+# define PRIORITY_WHICH_T(which) (__priority_which_t)which
+#else
+# define PRIORITY_WHICH_T(which) which
+#endif
+
PP(pp_getpriority)
{
#ifdef HAS_GETPRIORITY
dVAR; dSP; dTARGET;
const int who = POPi;
const int which = TOPi;
- SETi( getpriority(which, who) );
+ SETi( getpriority(PRIORITY_WHICH_T(which), who) );
RETURN;
#else
DIE(aTHX_ PL_no_func, "getpriority()");
- return NORMAL;
#endif
}
const int who = POPi;
const int which = TOPi;
TAINT_PROPER("setpriority");
- SETi( setpriority(which, who, niceval) >= 0 );
+ SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpriority()");
- return NORMAL;
#endif
}
+#undef PRIORITY_WHICH_T
+
/* Time calls. */
PP(pp_time)
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
}
EXTEND(SP, 1);
if (!(tmps = PerlProc_getlogin()))
RETPUSHUNDEF;
- PUSHp(tmps, strlen(tmps));
+ sv_setpv_mg(TARG, tmps);
+ PUSHs(TARG);
RETURN;
#else
DIE(aTHX_ PL_no_func, "getlogin");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "syscall");
- return NORMAL;
#endif
}