* is called once and only once */
if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s));
- tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
+ tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
if (PL_op->op_flags & OPf_SPECIAL) {
/* call Perl-level glob function instead. Stack args are:
}
else {
exsv = TOPs;
+ if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
}
if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
/* well-formed exception supplied */
}
- else if (SvROK(ERRSV)) {
- exsv = ERRSV;
- }
- else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
- exsv = sv_mortalcopy(ERRSV);
- sv_catpvs(exsv, "\t...caught");
- }
else {
+ SvGETMAGIC(ERRSV);
+ if (SvROK(ERRSV)) {
+ if (SvGMAGICAL(ERRSV)) {
+ exsv = sv_newmortal();
+ sv_setsv_nomg(exsv, ERRSV);
+ }
+ else exsv = ERRSV;
+ }
+ else if (SvPOKp(ERRSV) ? SvCUR(ERRSV) : SvNIOKp(ERRSV)) {
+ exsv = sv_newmortal();
+ sv_setsv_nomg(exsv, ERRSV);
+ sv_catpvs(exsv, "\t...caught");
+ }
+ else {
exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
+ }
}
if (SvROK(exsv) && !PL_warnhook)
Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx, retop);
+ if (CvDEPTH(cv) >= 2) {
+ PERL_STACK_OVERFLOW_CHECK();
+ pad_push(CvPADLIST(cv), CvDEPTH(cv));
+ }
SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
}
IoFLAGS(io) &= ~IOf_DIDTOP;
- return doform(cv,gv,PL_op->op_next);
+ RETURNOP(doform(cv,gv,PL_op->op_next));
}
PP(pp_leavewrite)
if (!cv) {
SV * const sv = sv_newmortal();
gv_efullname4(sv, fgv, NULL, FALSE);
- if (SvPOK(sv) && *SvPV_nolen_const(sv))
- DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
- else
- DIE(aTHX_ "Undefined top format called");
+ DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
}
return doform(cv, gv, PL_op);
}
POPBLOCK(cx,PL_curpm);
POPFORMAT(cx);
retop = cx->blk_sub.retop;
+ SP = newsp; /* ignore retval of formline */
LEAVE;
- fp = IoOFP(io);
- if (!fp) {
- if (IoIFP(io))
+ if (!io || !(fp = IoOFP(io))) {
+ if (io && IoIFP(io))
report_wrongway_fh(gv, '<');
else
report_evil_fh(gv);
PUSHs(&PL_sv_yes);
}
}
- /* bad_ofp: */
PL_formtarget = PL_bodytarget;
- PUTBACK;
- PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
- return retop;
+ RETURNOP(retop);
}
PP(pp_prtf)
if (! SvOK(bufsv))
sv_setpvs(bufsv, "");
length = SvIVx(*++MARK);
+ if (length < 0)
+ DIE(aTHX_ "Negative length");
SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
buffer = SvPV_force(bufsv, blen);
buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
}
- if (length < 0)
- DIE(aTHX_ "Negative length");
- wanted = length;
+ if (DO_UTF8(bufsv)) {
+ /* offset adjust in characters not bytes */
+ /* SV's length cache is only safe for non-magical values */
+ if (SvGMAGICAL(bufsv))
+ blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen);
+ else
+ blen = sv_len_utf8(bufsv);
+ }
charstart = TRUE;
charskip = 0;
skip = 0;
+ wanted = length;
#ifdef HAS_SOCKET
if (PL_op->op_type == OP_RECV) {
RETURN;
}
#endif
- if (DO_UTF8(bufsv)) {
- /* offset adjust in characters not bytes */
- blen = sv_len_utf8(bufsv);
- }
if (offset < 0) {
if (-offset > (SSize_t)blen)
DIE(aTHX_ "Offset outside string");
}
if (DO_UTF8(bufsv)) {
/* convert offset-as-chars to offset-as-bytes */
- if (offset >= (int)blen)
+ if (offset >= (SSize_t)blen)
offset += SvCUR(bufsv) - blen;
else
offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
GV *tmpgv;
IO *io;
- if ((tmpgv = PL_op->op_flags & OPf_SPECIAL
- ? gv_fetchsv(sv, 0, SVt_PVIO)
- : MAYBE_DEREF_GV(sv) )) {
+ if (PL_op->op_flags & OPf_SPECIAL
+ ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
+ : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
io = GvIO(tmpgv);
if (!io)
result = 0;
goto do_fstat_have_io;
}
+ SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
PL_statgv = NULL;
PL_laststype = PL_op->op_type;
RETURN;
}
+/* All filetest ops avoid manipulating the perl stack pointer in their main
+ bodies (since commit d2c4d2d1e22d3125), and return using either
+ S_ft_return_false() or S_ft_return_true(). These two helper functions are
+ the only two which manipulate the perl stack. To ensure that no stack
+ manipulation macros are used, the filetest ops avoid defining a local copy
+ of the stack pointer with dSP. */
+
/* If the next filetest is stacked up with this one
(PL_op->op_private & OPpFT_STACKING), we leave
the original argument on the stack for success,
*/
static OP *
-S_ft_stacking_return_false(pTHX_ SV *ret) {
- dSP;
+S_ft_return_false(pTHX_ SV *ret) {
OP *next = NORMAL;
- while (OP_IS_FILETEST(next->op_type)
- && next->op_private & OPpFT_STACKED)
- next = next->op_next;
+ dSP;
+
if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
else SETs(ret);
PUTBACK;
+
+ if (PL_op->op_private & OPpFT_STACKING) {
+ while (OP_IS_FILETEST(next->op_type)
+ && next->op_private & OPpFT_STACKED)
+ next = next->op_next;
+ }
return next;
}
-#define FT_RETURN_FALSE(X) \
- STMT_START { \
- if (PL_op->op_private & OPpFT_STACKING) \
- return S_ft_stacking_return_false(aTHX_ X); \
- RETURNX(PL_op->op_flags & OPf_REF ? XPUSHs(X) : SETs(X)); \
- } STMT_END
-#define FT_RETURN_TRUE(X) \
- RETURNX((void)( \
- PL_op->op_flags & OPf_REF \
- ? (bool)XPUSHs( \
- PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (X) \
- ) \
- : (PL_op->op_private & OPpFT_STACKING || SETs(X)) \
- ))
-
-#define FT_RETURNNO FT_RETURN_FALSE(&PL_sv_no)
-#define FT_RETURNUNDEF FT_RETURN_FALSE(&PL_sv_undef)
-#define FT_RETURNYES FT_RETURN_TRUE(&PL_sv_yes)
+PERL_STATIC_INLINE OP *
+S_ft_return_true(pTHX_ SV *ret) {
+ dSP;
+ if (PL_op->op_flags & OPf_REF)
+ XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
+ else if (!(PL_op->op_private & OPpFT_STACKING))
+ SETs(ret);
+ PUTBACK;
+ return NORMAL;
+}
+
+#define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
+#define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
+#define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
#define tryAMAGICftest_MG(chr) STMT_START { \
- if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
+ if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
&& PL_op->op_flags & OPf_KIDS) { \
OP *next = S_try_amagic_ftest(aTHX_ chr); \
if (next) return next; \
STATIC OP *
S_try_amagic_ftest(pTHX_ char chr) {
dVAR;
- dSP;
- SV* const arg = TOPs;
+ SV *const arg = *PL_stack_sp;
assert(chr != '?');
if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
- if (SvAMAGIC(TOPs))
+ if (SvAMAGIC(arg))
{
const char tmpchr = chr;
SV * const tmpsv = amagic_call(arg,
if (!tmpsv)
return NULL;
- if (SvTRUE(tmpsv)) FT_RETURN_TRUE(tmpsv);
- FT_RETURN_FALSE(tmpsv);
+ return SvTRUE(tmpsv)
+ ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
}
return NULL;
}
bool effective = FALSE;
char opchar = '?';
- dSP;
switch (PL_op->op_type) {
case OP_FTRREAD: opchar = 'R'; break;
if (use_access) {
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
- const char *name = TOPpx;
+ const char *name = SvPV_nolen(*PL_stack_sp);
if (effective) {
# ifdef PERL_EFF_ACCESS
result = PERL_EFF_ACCESS(name, access_mode);
I32 result;
const int op_type = PL_op->op_type;
char opchar = '?';
- dSP;
switch (op_type) {
case OP_FTIS: opchar = 'e'; break;
break;
}
SvSETMAGIC(TARG);
- if (SvTRUE_nomg(TARG)) FT_RETURN_TRUE(TARG);
- else FT_RETURN_FALSE(TARG);
+ return SvTRUE_nomg(TARG)
+ ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
}
}
dVAR;
I32 result;
char opchar = '?';
- dSP;
switch (PL_op->op_type) {
case OP_FTROWNED: opchar = 'O'; break;
PP(pp_ftlink)
{
dVAR;
- dSP;
I32 result;
tryAMAGICftest_MG('l');
PP(pp_fttty)
{
dVAR;
- dSP;
int fd;
GV *gv;
char *name = NULL;
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
else {
- SV *tmpsv = TOPs;
+ SV *tmpsv = *PL_stack_sp;
if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
name = SvPV_nomg(tmpsv, namelen);
gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
FT_RETURNNO;
}
-#if defined(atarist) /* this will work with atariST. Configure will
- make guesses for other systems. */
-# define FILE_base(f) ((f)->_base)
-# define FILE_ptr(f) ((f)->_ptr)
-# define FILE_cnt(f) ((f)->_cnt)
-# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
-#endif
-
PP(pp_fttext)
{
dVAR;
- dSP;
I32 i;
I32 len;
I32 odd = 0;
== OPpFT_STACKED)
gv = PL_defgv;
else {
- sv = TOPs;
+ sv = *PL_stack_sp;
gv = MAYBE_DEREF_GV_nomg(sv);
}
register I32 items = SP - MARK;
unsigned long a[20];
register I32 i = 0;
- I32 retval = -1;
+ IV retval = -1;
if (PL_tainting) {
while (++MARK <= SP) {
case 8:
retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
break;
-#ifdef atarist
- case 9:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
- break;
- case 10:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
- break;
- case 11:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10]);
- break;
- case 12:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11]);
- break;
- case 13:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12]);
- break;
- case 14:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12],a[13]);
- break;
-#endif /* atarist */
}
SP = ORIGMARK;
PUSHi(retval);
https://perl5.git.perl.org / perl5.git / blobdiff