*/
/*
- * Now far ahead the Road has gone,
- * And I must follow, if I can,
- * Pursuing it with eager feet,
- * Until it joins some larger way
- * Where many paths and errands meet.
- * And whither then? I cannot say.
+ * Now far ahead the Road has gone,
+ * And I must follow, if I can,
+ * Pursuing it with eager feet,
+ * Until it joins some larger way
+ * Where many paths and errands meet.
+ * And whither then? I cannot say.
+ *
+ * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
*/
/* This file contains control-oriented pp ("push/pop") functions that
RETURN;
}
#endif
+
+#define tryAMAGICregexp(rx) \
+ STMT_START { \
+ if (SvROK(rx) && SvAMAGIC(rx)) { \
+ SV *sv = AMG_CALLun(rx, regexp); \
+ if (sv) { \
+ if (SvROK(sv)) \
+ sv = SvRV(sv); \
+ if (SvTYPE(sv) != SVt_REGEXP) \
+ Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
+ rx = sv; \
+ } \
+ } \
+ } STMT_END
+
+
if (PL_op->op_flags & OPf_STACKED) {
/* multiple args; concatentate them */
dMARK; dORIGMARK;
tmpstr = PAD_SV(ARGTARG);
sv_setpvs(tmpstr, "");
while (++MARK <= SP) {
+ SV *msv = *MARK;
if (PL_amagic_generation) {
SV *sv;
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
- (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
+
+ tryAMAGICregexp(msv);
+
+ if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
+ (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
{
sv_setsv(tmpstr, sv);
continue;
}
}
- sv_catsv(tmpstr, *MARK);
+ sv_catsv(tmpstr, msv);
}
SvSETMAGIC(tmpstr);
SP = ORIGMARK;
}
- else
+ else {
tmpstr = POPs;
+ tryAMAGICregexp(tmpstr);
+ }
+
+#undef tryAMAGICregexp
if (SvROK(tmpstr)) {
SV * const sv = SvRV(tmpstr);
if (SvTYPE(sv) == SVt_REGEXP)
re = (REGEXP*) sv;
}
+ else if (SvTYPE(tmpstr) == SVt_REGEXP)
+ re = (REGEXP*) tmpstr;
+
if (re) {
- re = reg_temp_copy(re);
+ /* The match's LHS's get-magic might need to access this op's reg-
+ exp (as is sometimes the case with $'; see bug 70764). So we
+ must call get-magic now before we replace the regexp. Hopeful-
+ ly this hack can be replaced with the approach described at
+ http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
+ /msg122415.html some day. */
+ if(pm->op_type == OP_MATCH) {
+ SV *lhs;
+ const bool was_tainted = PL_tainted;
+ if (pm->op_flags & OPf_STACKED)
+ lhs = TOPs;
+ else if (pm->op_private & OPpTARGET_MY)
+ lhs = PAD_SV(pm->op_targ);
+ else lhs = DEFSV;
+ SvGETMAGIC(lhs);
+ /* Restore the previous value of PL_tainted (which may have been
+ modified by get-magic), to avoid incorrectly setting the
+ RXf_TAINTED flag further down. */
+ PL_tainted = was_tainted;
+ }
+
+ re = reg_temp_copy(NULL, re);
ReREFCNT_dec(PM_GETRE(pm));
PM_SETRE(pm, re);
}
register REGEXP * const rx = cx->sb_rx;
SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
+
+ PERL_ASYNC_CHECK();
+
if(old != rx) {
if(old)
ReREFCNT_dec(old);
if (cx->sb_iters > cx->sb_maxiters)
DIE(aTHX_ "Substitution loop");
+ SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
+
if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
cx->sb_rxtainted |= 2;
- sv_catsv(dstr, POPs);
+ sv_catsv_nomg(dstr, POPs);
+ /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
+ s -= RX_GOFS(rx);
/* Are we done */
- if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
- s == m, cx->sb_targ, NULL,
- ((cx->sb_rflags & REXEC_COPY_STR)
- ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
- : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+ if (CxONCE(cx) || s < orig ||
+ !CALLREGEXEC(rx, s, cx->sb_strend, orig,
+ (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
+ ((cx->sb_rflags & REXEC_COPY_STR)
+ ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
+ : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
{
SV * const targ = cx->sb_targ;
}
}
-void
-Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
+static void
+S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
{
UV *p = (UV*)*rsp;
U32 i;
}
}
-void
-Perl_rxres_free(pTHX_ void **rsp)
+static void
+S_rxres_free(pTHX_ void **rsp)
{
UV * const p = (UV*)*rsp;
if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
- sv_utf8_upgrade(PL_formtarget);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
t = SvEND(PL_formtarget);
targ_is_utf8 = TRUE;
}
sv = *++MARK;
else {
sv = &PL_sv_no;
- if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
}
break;
if (!targ_is_utf8) {
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
- sv_utf8_upgrade(PL_formtarget);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
+ fudge + 1);
t = SvEND(PL_formtarget);
targ_is_utf8 = TRUE;
}
t - SvPVX_const(PL_formtarget));
targ_is_utf8 = TRUE;
/* Don't need get magic. */
- sv_utf8_upgrade_flags(PL_formtarget, 0);
+ sv_utf8_upgrade_nomg(PL_formtarget);
} else {
SvCUR_set(PL_formtarget,
t - SvPVX_const(PL_formtarget));
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
lines += FmLINES(PL_formtarget);
- if (lines == 200) {
- arg = t - linemark;
- if (strnEQ(linemark, linemark - arg, arg))
- DIE(aTHX_ "Runaway format");
- }
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) = lines;
PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
pp_pushmark(); /* push dst */
pp_pushmark(); /* push src */
- ENTER; /* enter outer scope */
+ ENTER_with_name("grep"); /* enter outer scope */
SAVETMPS;
if (PL_op->op_private & OPpGREP_LEX)
SAVESPTR(PAD_SVl(PL_op->op_targ));
else
SAVE_DEFSV;
- ENTER; /* enter inner scope */
+ ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
else
- DEFSV = src;
+ DEFSV_set(src);
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
}
}
}
- LEAVE; /* exit inner scope */
+ LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
(void)POPMARK; /* pop top */
- LEAVE; /* exit outer scope */
+ LEAVE_with_name("grep"); /* exit outer scope */
(void)POPMARK; /* pop src */
items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
(void)POPMARK; /* pop dst */
else {
SV *src;
- ENTER; /* enter inner scope */
+ ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
/* set $_ to the new source item */
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
else
- DEFSV = src;
+ DEFSV_set(src);
RETURNOP(cLOGOP->op_other);
}
static const char * const context_name[] = {
"pseudo-block",
- "when",
+ NULL, /* CXt_WHEN never actually needs "block" */
NULL, /* CXt_BLOCK never actually needs "block" */
- "given",
+ NULL, /* CXt_GIVEN never actually needs "block" */
NULL, /* CXt_LOOP_FOR never actually needs "loop" */
NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
- case CXt_GIVEN:
- case CXt_WHEN:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
- context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
if (CxTYPE(cx) == CXt_NULL)
return -1;
break;
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
- if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
- DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
- (long)i, CxLABEL(cx)));
+ {
+ const char *cx_label = CxLABEL(cx);
+ if (!cx_label || strNE(label, cx_label) ) {
+ DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
+ (long)i, cx_label));
continue;
}
- DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
+ DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
return i;
+ }
}
}
return i;
case CXt_EVAL:
case CXt_SUB:
case CXt_FORMAT:
- DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_EVAL:
- DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
return i;
}
}
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
- context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
if ((CxTYPE(cx)) == CXt_NULL)
return -1;
break;
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
- DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_GIVEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
return i;
case CXt_LOOP_PLAIN:
assert(!CxFOREACHDEF(cx));
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
if (CxFOREACHDEF(cx)) {
- DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_WHEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
return i;
}
}
while (cxstack_ix > cxix) {
SV *sv;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
- (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
+ DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
case CXt_SUBST:
++PL_parser->error_count;
}
-OP *
-Perl_die_where(pTHX_ const char *message, STRLEN msglen)
+void
+Perl_die_where(pTHX_ SV *msv)
{
dVAR;
I32 cxix;
I32 gimme;
- if (message) {
+ if (msv) {
if (PL_in_eval & EVAL_KEEPERR) {
static const char prefix[] = "\t(in cleanup) ";
SV * const err = ERRSV;
const char *e = NULL;
if (!SvPOK(err))
sv_setpvs(err,"");
- else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
+ else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
STRLEN len;
+ STRLEN msglen;
+ const char* message = SvPV_const(msv, msglen);
e = SvPV_const(err, len);
e += len - msglen;
if (*e != *message || strNE(e,message))
e = NULL;
}
if (!e) {
- SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
+ STRLEN start;
+ SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catpvn(err, message, msglen);
- if (ckWARN(WARN_MISC)) {
- const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
- Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
- }
+ sv_catsv(err, msv);
+ start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
+ SvPVX_const(err)+start);
}
}
else {
+ STRLEN msglen;
+ const char* message = SvPV_const(msv, msglen);
sv_setpvn(ERRSV, message, msglen);
+ SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
}
}
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
- if (!message)
- message = SvPVx_const(ERRSV, msglen);
+ STRLEN msglen;
+ const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
+ /* note that unlike pp_entereval, pp_require isn't
+ * supposed to trap errors. So now that we've popped the
+ * EVAL that pp_require pushed, and processed the error
+ * message, rethrow the error */
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
assert(CxTYPE(cx) == CXt_EVAL);
- return cx->blk_eval.retop;
+ PL_restartop = cx->blk_eval.retop;
+ JMPENV_JUMP(3);
+ /* NOTREACHED */
}
}
- if (!message)
- message = SvPVx_const(ERRSV, msglen);
- write_to_stderr(message, msglen);
+ write_to_stderr( msv ? msv : ERRSV );
my_failure_exit();
/* NOTREACHED */
- return 0;
}
PP(pp_xor)
const int off = AvARRAY(ary) - AvALLOC(ary);
if (!PL_dbargs) {
- GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
- PL_dbargs = GvAV(gv_AVadd(tmpgv));
- GvMULTI_on(tmpgv);
+ PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
+ SVt_PVAV)));
AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
}
/* Get the bit mask for $warnings::Bits{all}, because
* it could have been extended by warnings::register */
SV **bits_all;
- HV * const bits = get_hv("warnings::Bits", FALSE);
+ HV * const bits = get_hv("warnings::Bits", 0);
if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
mask = newSVsv(*bits_all);
}
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
+ PERL_ASYNC_CHECK();
+
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
PAD *iterdata;
#endif
- ENTER;
+ ENTER_with_name("loop1");
SAVETMPS;
if (PL_op->op_targ) {
if (PL_op->op_private & OPpITER_DEF)
cxtype |= CXp_FOR_DEF;
- ENTER;
+ ENTER_with_name("loop2");
PUSHBLOCK(cx, cxtype, SP);
#ifdef USE_ITHREADS
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER;
+ ENTER_with_name("loop1");
SAVETMPS;
- ENTER;
+ ENTER_with_name("loop2");
PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
PUSHLOOP_PLAIN(cx, SP);
POPLOOP(cx); /* Stack values are safe: release loop vars ... */
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE;
- LEAVE;
+ LEAVE_with_name("loop2");
+ LEAVE_with_name("loop1");
return NORMAL;
}
PMOP *newpm;
I32 optype = 0;
SV *sv;
- OP *retop;
+ OP *retop = NULL;
const I32 cxix = dopoptosub(cxstack_ix);
I32 pop2 = 0;
I32 gimme;
I32 optype;
- OP *nextop;
+ OP *nextop = NULL;
SV **newsp;
PMOP *newpm;
SV **mark;
OP *kid;
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
- CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
- return kid;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
+ const char *kid_label = CopLABEL(kCOP);
+ if (kid_label && strEQ(kid_label, label))
+ return kid;
+ }
}
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid == PL_lastgotoprobe)
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
Perl_get_db_sub(aTHX_ NULL, cv);
if (PERLDB_GOTO) {
- CV * const gotocv = get_cv("DB::goto", FALSE);
+ CV * const gotocv = get_cvs("DB::goto", 0);
if (gotocv) {
PUSHMARK( PL_stack_sp );
call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
else
label = cPVOP->op_pv;
+ PERL_ASYNC_CHECK();
+
if (label && *label) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
+ case CXt_GIVEN:
+ case CXt_WHEN:
gotoprobe = cx->blk_oldcop->op_sibling;
break;
case CXt_SUBST:
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
}
+ if (*enterops && enterops[1]) {
+ I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ if (enterops[i])
+ deprecate("\"goto\" to jump into a construct");
+ }
+
/* pop unwanted frames */
if (ix < cxstack_ix) {
const char *t;
SV * const tmpstr = newSV_type(SVt_PVMG);
- t = strchr(s, '\n');
+ t = (const char *)memchr(s, '\n', send - s);
if (t)
t++;
else
}
}
+/*
+=for apidoc docatch
+
+Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
+
+0 is used as continue inside eval,
+
+3 is used for a die caught by an inner eval - continue inner loop
+
+See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+establish a local jmpenv to handle exception traps.
+
+=cut
+*/
STATIC OP *
S_docatch(pTHX_ OP *o)
{
return NULL;
}
+/* James Bond: Do you expect me to talk?
+ Auric Goldfinger: No, Mr. Bond. I expect you to die.
+
+ This code is an ugly hack, doesn't work with lexicals in subroutines that are
+ called more than once, and is only used by regcomp.c, for (?{}) blocks.
+
+ Currently it is not used outside the core code. Best if it stays that way.
+*/
OP *
Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
/* sv Text to convert to OP tree. */
/* startop op_free() this to undo. */
/* code Short string id of the caller. */
{
- /* FIXME - how much of this code is common with pp_entereval? */
dVAR; dSP; /* Make POPBLOCK work. */
PERL_CONTEXT *cx;
SV **newsp;
PERL_ARGS_ASSERT_SV_COMPILE_2OP;
- ENTER;
+ ENTER_with_name("eval");
lex_start(sv, NULL, FALSE);
SAVETMPS;
/* switch to eval mode */
lex_end();
/* XXX DAPM do this properly one year */
*padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
- LEAVE;
+ LEAVE_with_name("eval");
if (IN_PERL_COMPILETIME)
CopHINTS_set(&PL_compiling, PL_hints);
#ifdef OP_IN_REGISTER
}
+/* Run yyparse() in a setjmp wrapper. Returns:
+ * 0: yyparse() successful
+ * 1: yyparse() failed
+ * 3: yyparse() died
+ */
+STATIC int
+S_try_yyparse(pTHX)
+{
+ int ret;
+ dJMPENV;
+
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ ret = yyparse() ? 1 : 0;
+ break;
+ case 3:
+ break;
+ default:
+ JMPENV_POP;
+ JMPENV_JUMP(ret);
+ /* NOTREACHED */
+ }
+ JMPENV_POP;
+ return ret;
+}
+
+
/* Compile a require/do, an eval '', or a /(?{...})/.
* In the last case, startop is non-null, and contains the address of
* a pointer that should be set to the just-compiled code.
{
dVAR; dSP;
OP * const saveop = PL_op;
+ bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
+ int yystatus;
- PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
+ PL_in_eval = (in_require
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
: EVAL_INEVAL);
PL_in_eval |= EVAL_KEEPERR;
else
CLEAR_ERRSV();
- if (yyparse() || PL_parser->error_count || !PL_eval_root) {
+
+ /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
+ * so honour CATCH_GET and trap it here if necessary */
+
+ yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
+
+ if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- I32 optype = 0; /* Might be reset by POPEVAL. */
+ I32 optype; /* Used by POPEVAL. */
const char *msg;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(optype);
+
PL_op = saveop;
if (PL_eval_root) {
op_free(PL_eval_root);
PL_eval_root = NULL;
}
- SP = PL_stack_base + POPMARK; /* pop original mark */
- if (!startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
+ if (yystatus != 3) {
+ SP = PL_stack_base + POPMARK; /* pop original mark */
+ if (!startop) {
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ }
}
lex_end();
- LEAVE;
+ if (yystatus != 3)
+ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
msg = SvPVx_nolen_const(ERRSV);
- if (optype == OP_REQUIRE) {
+ if (in_require) {
const SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
*msg ? msg : "Unknown error\n");
}
else if (startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
+ if (yystatus != 3) {
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ }
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
sv_setpvs(ERRSV, "Compilation error");
}
}
- PERL_UNUSED_VAR(newsp);
PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
SAVEFREEOP(PL_eval_root);
/* Set the context for this new optree.
- * If the last op is an OP_REQUIRE, force scalar context.
- * Otherwise, propagate the context from the eval(). */
- if (PL_eval_root->op_type == OP_LEAVEEVAL
- && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
- && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
- == OP_REQUIRE)
- scalar(PL_eval_root);
- else if ((gimme & G_WANT) == G_VOID)
+ * Propagate the context from the eval(). */
+ if ((gimme & G_WANT) == G_VOID)
scalarvoid(PL_eval_root);
else if ((gimme & G_WANT) == G_ARRAY)
list(PL_eval_root);
/* Register with debugger: */
if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
- CV * const cv = get_cv("DB::postponed", FALSE);
+ CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
PUSHMARK(SP);
SVfARG(vnormal(PL_patchlevel)));
}
else { /* probably 'use 5.10' or 'use 5.8' */
- SV * hintsv = newSV(0);
+ SV *hintsv;
I32 second = 0;
if (av_len(lav)>=1)
second = SvIV(*av_fetch(lav,1,0));
second /= second >= 600 ? 100 : 10;
- hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
- (int)first, (int)second,0);
+ hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
+ (int)first, (int)second);
upg_version(hintsv, TRUE);
DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
"--this is only %"SVf", stopped",
SVfARG(vnormal(req)),
- SVfARG(vnormal(hintsv)),
+ SVfARG(vnormal(sv_2mortal(hintsv))),
SVfARG(vnormal(PL_patchlevel)));
}
}
vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
SV *const importsv = vnormal(sv);
*SvPVX_mutable(importsv) = ':';
- ENTER;
+ ENTER_with_name("load_feature");
Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE;
+ LEAVE_with_name("load_feature");
+ }
+ /* If a version >= 5.11.0 is requested, strictures are on by default! */
+ if (PL_compcv &&
+ vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
+ PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
}
RETPUSHYES;
tryname = name;
tryrsfp = doopen_pm(name, len);
}
-#ifdef MACOS_TRADITIONAL
- if (!tryrsfp) {
- char newname[256];
-
- MacPerl_CanonDir(name, newname, 1);
- if (path_is_absolute(newname)) {
- tryname = newname;
- tryrsfp = doopen_pm(newname, strlen(newname));
- }
- }
-#endif
if (!tryrsfp) {
AV * const ar = GvAVn(PL_incgv);
I32 i;
tryname = SvPVX_const(namesv);
tryrsfp = NULL;
- ENTER;
+ ENTER_with_name("call_INC");
SAVETMPS;
EXTEND(SP, 2);
/* Adjust file name if the hook has set an %INC entry */
svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
if (svp)
- tryname = SvPVX_const(*svp);
+ tryname = SvPV_nolen_const(*svp);
if (count > 0) {
int i = 0;
PUTBACK;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("call_INC");
if (tryrsfp) {
hook_sv = dirsv;
}
else {
if (!path_is_absolute(name)
-#ifdef MACOS_TRADITIONAL
- /* We consider paths of the form :a:b ambiguous and interpret them first
- as global then as local
- */
- || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
-#endif
) {
const char *dir;
STRLEN dirlen;
dirlen = 0;
}
-#ifdef MACOS_TRADITIONAL
- char buf1[256];
- char buf2[256];
-
- MacPerl_CanonDir(name, buf2, 1);
- Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
-#else
-# ifdef VMS
+#ifdef VMS
char *unixdir;
if ((unixdir = tounixpath(dir, NULL)) == NULL)
continue;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
-# else
-# ifdef __SYMBIAN32__
+#else
+# ifdef __SYMBIAN32__
if (PL_origfilename[0] &&
PL_origfilename[1] == ':' &&
!(dir[0] && dir[1] == ':'))
Perl_sv_setpvf(aTHX_ namesv,
"%s\\%s",
dir, name);
-# else
+# else
/* The equivalent of
Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
but without the need to parse the format string, or
/* Don't even actually have to turn SvPOK_on() as we
access it directly with SvPVX() below. */
}
-# endif
# endif
#endif
TAINT_PROPER("require");
tryname = SvPVX_const(namesv);
tryrsfp = doopen_pm(tryname, SvCUR(namesv));
if (tryrsfp) {
- if (tryname[0] == '.' && tryname[1] == '/')
- tryname += 2;
+ if (tryname[0] == '.' && tryname[1] == '/') {
+ ++tryname;
+ while (*++tryname == '/');
+ }
break;
}
else if (errno == EMFILE)
unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
}
- ENTER;
+ ENTER_with_name("eval");
SAVETMPS;
lex_start(NULL, tryrsfp, TRUE);
SAVEHINTS();
PL_hints = 0;
- if (PL_compiling.cop_hints_hash) {
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
- PL_compiling.cop_hints_hash = NULL;
- }
+ hv_clear(GvHV(PL_hintgv));
SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_STD ;
if (filter_sub || filter_cache) {
- SV * const datasv = filter_add(S_run_user_filter, NULL);
+ /* We can use the SvPV of the filter PVIO itself as our cache, rather
+ than hanging another SV from it. In turn, filter_add() optionally
+ takes the SV to use as the filter (or creates a new SV if passed
+ NULL), so simply pass in whatever value filter_cache has. */
+ SV * const datasv = filter_add(S_run_user_filter, filter_cache);
IoLINES(datasv) = filter_has_file;
IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
- IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
}
/* switch to eval mode */
register PERL_CONTEXT *cx;
SV *sv;
const I32 gimme = GIMME_V;
- const I32 was = PL_sub_generation;
+ const U32 was = PL_breakable_sub_gen;
char tbuf[TYPE_DIGITS(long) + 12];
char *tmpbuf = tbuf;
- char *safestr;
STRLEN len;
- bool ok;
CV* runcv;
U32 seq;
HV *saved_hh = NULL;
- const char * const fakestr = "_<(eval )";
- const int fakelen = 9 + 1;
-
+
if (PL_op->op_private & OPpEVAL_HAS_HH) {
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
}
TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
- ENTER;
+ ENTER_with_name("eval");
lex_start(sv, NULL, FALSE);
SAVETMPS;
(i.e. before run-time proper). To work around the coredump that
ensues, we always turn GvMULTI_on for any globals that were
introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepvn(tmpbuf, len);
- SAVEDELETE(PL_defstash, safestr, len);
SAVEHINTS();
PL_hints = PL_op->op_targ;
- if (saved_hh)
+ if (saved_hh) {
+ /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
+ SvREFCNT_dec(GvHV(PL_hintgv));
GvHV(PL_hintgv) = saved_hh;
+ }
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
if (PL_compiling.cop_hints_hash) {
/* prepare to compile string */
- if (PERLDB_LINE && PL_curstash != PL_debstash)
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
PUTBACK;
- ok = doeval(gimme, NULL, runcv, seq);
- if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
- && ok) {
- /* Copy in anything fake and short. */
- my_strlcpy(safestr, fakestr, fakelen);
+
+ if (doeval(gimme, NULL, runcv, seq)) {
+ if (was != PL_breakable_sub_gen /* Some subs defined here. */
+ ? (PERLDB_LINE || PERLDB_SAVESRC)
+ : PERLDB_SAVESRC_NOSUBS) {
+ /* Retain the filegv we created. */
+ } else {
+ char *const safestr = savepvn(tmpbuf, len);
+ SAVEDELETE(PL_defstash, safestr, len);
+ }
+ return DOCATCH(PL_eval_start);
+ } else {
+ /* We have already left the scope set up earler thanks to the LEAVE
+ in doeval(). */
+ if (was != PL_breakable_sub_gen /* Some subs defined here. */
+ ? (PERLDB_LINE || PERLDB_SAVESRC)
+ : PERLDB_SAVESRC_INVALID) {
+ /* Retain the filegv we created. */
+ } else {
+ (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
+ }
+ return PL_op->op_next;
}
- return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
}
PP(pp_leaveeval)
/* die_where() did LEAVE, or we won't be here */
}
else {
- LEAVE;
+ LEAVE_with_name("eval");
if (!(save_flags & OPf_SPECIAL)) {
CLEAR_ERRSV();
}
POPBLOCK(cx,newpm);
POPEVAL(cx);
PL_curpm = newpm;
- LEAVE;
+ LEAVE_with_name("eval_scope");
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
PERL_UNUSED_VAR(optype);
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER;
+ ENTER_with_name("eval_scope");
SAVETMPS;
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
}
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE;
+ LEAVE_with_name("eval_scope");
CLEAR_ERRSV();
RETURN;
}
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER;
+ ENTER_with_name("given");
SAVETMPS;
- if (PL_op->op_targ == 0) {
- SV ** const defsv_p = &GvSV(PL_defgv);
- *defsv_p = newSVsv(POPs);
- SAVECLEARSV(*defsv_p);
- }
- else
- sv_setsv(PAD_SV(PL_op->op_targ), POPs);
+ sv_setsv(PAD_SV(PL_op->op_targ), POPs);
PUSHBLOCK(cx, CXt_GIVEN, SP);
PUSHGIVEN(cx);
PL_curpm = newpm; /* pop $1 et al */
- LEAVE;
+ LEAVE_with_name("given");
return NORMAL;
}
PM_SETRE(matcher, ReREFCNT_inc(re));
SAVEFREEOP((OP *) matcher);
- ENTER; SAVETMPS;
+ ENTER_with_name("matcher"); SAVETMPS;
SAVEOP();
return matcher;
}
PERL_UNUSED_ARG(matcher);
FREETMPS;
- LEAVE;
+ LEAVE_with_name("matcher");
}
/* Do a smart match */
PP(pp_smartmatch)
{
+ DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
return do_smartmatch(NULL, NULL);
}
dVAR;
dSP;
+ bool object_on_left = FALSE;
SV *e = TOPs; /* e is for 'expression' */
SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
- SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
- REGEXP *this_regex, *other_regex;
-
-# define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
-
-# define SM_REF(type) ( \
- (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
- || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
-
-# define SM_CV_NEP /* Find a code ref without an empty prototype */ \
- ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
- && NOT_EMPTY_PROTO(This) && (Other = e)) \
- || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
- && NOT_EMPTY_PROTO(This) && (Other = d)))
-
-# define SM_REGEX ( \
- (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
- && (this_regex = (REGEXP*) This) \
- && (Other = e)) \
- || \
- (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
- && (this_regex = (REGEXP*) This) \
- && (Other = d)) )
-
-
-# define SM_OBJECT ( \
- (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \
- || \
- (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \
-
-# define SM_OTHER_REF(type) \
- (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
-# define SM_OTHER_REGEX (SvROK(Other) \
- && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
- && (other_regex = (REGEXP*) SvRV(Other)))
+ /* First of all, handle overload magic of the rightmost argument */
+ if (SvAMAGIC(e)) {
+ SV * tmpsv;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
+ DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
+ tmpsv = amagic_call(d, e, smart_amg, 0);
+ if (tmpsv) {
+ SPAGAIN;
+ (void)POPs;
+ SETs(tmpsv);
+ RETURN;
+ }
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
+ }
-# define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
- sv_2mortal(newSViv(PTR2IV(sv))), 0)
-
-# define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
- sv_2mortal(newSViv(PTR2IV(sv))), 0)
-
- tryAMAGICbinSET(smart, 0);
-
SP -= 2; /* Pop the values */
/* Take care only to invoke mg_get() once for each argument.
if (SvGMAGICAL(e))
e = sv_mortalcopy(e);
- if (SM_OBJECT)
+ /* ~~ undef */
+ if (!SvOK(e)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
+ if (SvOK(d))
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+ }
+
+ if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+ }
+ if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
+ object_on_left = TRUE;
- if (SM_CV_NEP) {
+ /* ~~ sub */
+ if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
I32 c;
-
- if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
- {
- if (This == SvRV(Other))
+ if (object_on_left) {
+ goto sm_any_sub; /* Treat objects like scalars */
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ /* Test sub truth for each key */
+ HE *he;
+ bool andedresults = TRUE;
+ HV *hv = (HV*) SvRV(d);
+ I32 numkeys = hv_iterinit(hv);
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
+ if (numkeys == 0)
+ RETPUSHYES;
+ while ( (he = hv_iternext(hv)) ) {
+ DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
+ ENTER_with_name("smartmatch_hash_key_test");
+ SAVETMPS;
+ PUSHMARK(SP);
+ PUSHs(hv_iterkeysv(he));
+ PUTBACK;
+ c = call_sv(e, G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ andedresults = FALSE;
+ else
+ andedresults = SvTRUEx(POPs) && andedresults;
+ FREETMPS;
+ LEAVE_with_name("smartmatch_hash_key_test");
+ }
+ if (andedresults)
RETPUSHYES;
else
RETPUSHNO;
}
-
- ENTER;
- SAVETMPS;
- PUSHMARK(SP);
- PUSHs(Other);
- PUTBACK;
- c = call_sv(This, G_SCALAR);
- SPAGAIN;
- if (c == 0)
- PUSHs(&PL_sv_no);
- else if (SvTEMP(TOPs))
- SvREFCNT_inc_void(TOPs);
- FREETMPS;
- LEAVE;
- RETURN;
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ /* Test sub truth for each element */
+ I32 i;
+ bool andedresults = TRUE;
+ AV *av = (AV*) SvRV(d);
+ const I32 len = av_len(av);
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
+ if (len == -1)
+ RETPUSHYES;
+ for (i = 0; i <= len; ++i) {
+ SV * const * const svp = av_fetch(av, i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
+ ENTER_with_name("smartmatch_array_elem_test");
+ SAVETMPS;
+ PUSHMARK(SP);
+ if (svp)
+ PUSHs(*svp);
+ PUTBACK;
+ c = call_sv(e, G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ andedresults = FALSE;
+ else
+ andedresults = SvTRUEx(POPs) && andedresults;
+ FREETMPS;
+ LEAVE_with_name("smartmatch_array_elem_test");
+ }
+ if (andedresults)
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+ else {
+ sm_any_sub:
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
+ ENTER_with_name("smartmatch_coderef");
+ SAVETMPS;
+ PUSHMARK(SP);
+ PUSHs(d);
+ PUTBACK;
+ c = call_sv(e, G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ PUSHs(&PL_sv_no);
+ else if (SvTEMP(TOPs))
+ SvREFCNT_inc_void(TOPs);
+ FREETMPS;
+ LEAVE_with_name("smartmatch_coderef");
+ RETURN;
+ }
}
- else if (SM_REF(PVHV)) {
- if (SM_OTHER_REF(PVHV)) {
+ /* ~~ %hash */
+ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
+ if (object_on_left) {
+ goto sm_any_hash; /* Treat objects like scalars */
+ }
+ else if (!SvOK(d)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
+ RETPUSHNO;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
/* Check that the key-sets are identical */
HE *he;
- HV *other_hv = MUTABLE_HV(SvRV(Other));
+ HV *other_hv = MUTABLE_HV(SvRV(d));
bool tied = FALSE;
bool other_tied = FALSE;
U32 this_key_count = 0,
other_key_count = 0;
-
+ HV *hv = MUTABLE_HV(SvRV(e));
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
/* Tied hashes don't know how many keys they have. */
- if (SvTIED_mg(This, PERL_MAGIC_tied)) {
+ if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
tied = TRUE;
}
else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
HV * const temp = other_hv;
- other_hv = MUTABLE_HV(This);
- This = MUTABLE_SV(temp);
+ other_hv = hv;
+ hv = temp;
tied = TRUE;
}
if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
other_tied = TRUE;
- if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv))
+ if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
RETPUSHNO;
/* The hashes have the same number of keys, so it suffices
to check that one is a subset of the other. */
- (void) hv_iterinit(MUTABLE_HV(This));
- while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
- I32 key_len;
- char * const key = hv_iterkey(he, &key_len);
-
+ (void) hv_iterinit(hv);
+ while ( (he = hv_iternext(hv)) ) {
+ SV *key = hv_iterkeysv(he);
+
+ DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
++ this_key_count;
- if(!hv_exists(other_hv, key, key_len)) {
- (void) hv_iterinit(MUTABLE_HV(This)); /* reset iterator */
+ if(!hv_exists_ent(other_hv, key, 0)) {
+ (void) hv_iterinit(hv); /* reset iterator */
RETPUSHNO;
}
}
else
RETPUSHYES;
}
- else if (SM_OTHER_REF(PVAV)) {
- AV * const other_av = MUTABLE_AV(SvRV(Other));
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ AV * const other_av = MUTABLE_AV(SvRV(d));
const I32 other_len = av_len(other_av) + 1;
I32 i;
+ HV *hv = MUTABLE_HV(SvRV(e));
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
for (i = 0; i < other_len; ++i) {
SV ** const svp = av_fetch(other_av, i, FALSE);
- char *key;
- STRLEN key_len;
-
+ DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
if (svp) { /* ??? When can this not happen? */
- key = SvPV(*svp, key_len);
- if (hv_exists(MUTABLE_HV(This), key, key_len))
+ if (hv_exists_ent(hv, *svp, 0))
RETPUSHYES;
}
}
RETPUSHNO;
}
- else if (SM_OTHER_REGEX) {
- PMOP * const matcher = make_matcher(other_regex);
- HE *he;
-
- (void) hv_iterinit(MUTABLE_HV(This));
- while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
- if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
- (void) hv_iterinit(MUTABLE_HV(This));
- destroy_matcher(matcher);
- RETPUSHYES;
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
+ sm_regex_hash:
+ {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
+ HE *he;
+ HV *hv = MUTABLE_HV(SvRV(e));
+
+ (void) hv_iterinit(hv);
+ while ( (he = hv_iternext(hv)) ) {
+ DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
+ if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
+ (void) hv_iterinit(hv);
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
}
+ destroy_matcher(matcher);
+ RETPUSHNO;
}
- destroy_matcher(matcher);
- RETPUSHNO;
}
else {
- if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
+ sm_any_hash:
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
+ if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
RETPUSHYES;
else
RETPUSHNO;
}
}
- else if (SM_REF(PVAV)) {
- if (SM_OTHER_REF(PVAV)) {
- AV *other_av = MUTABLE_AV(SvRV(Other));
- if (av_len(MUTABLE_AV(This)) != av_len(other_av))
+ /* ~~ @array */
+ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
+ if (object_on_left) {
+ goto sm_any_array; /* Treat objects like scalars */
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ AV * const other_av = MUTABLE_AV(SvRV(e));
+ const I32 other_len = av_len(other_av) + 1;
+ I32 i;
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
+ for (i = 0; i < other_len; ++i) {
+ SV ** const svp = av_fetch(other_av, i, FALSE);
+
+ DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
+ if (svp) { /* ??? When can this not happen? */
+ if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
+ RETPUSHYES;
+ }
+ }
+ RETPUSHNO;
+ }
+ if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ AV *other_av = MUTABLE_AV(SvRV(d));
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
+ if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
RETPUSHNO;
else {
I32 i;
(void) sv_2mortal(MUTABLE_SV(seen_this));
}
if (NULL == seen_other) {
- seen_this = newHV();
+ seen_other = newHV();
(void) sv_2mortal(MUTABLE_SV(seen_other));
}
for(i = 0; i <= other_len; ++i) {
- SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
+ SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
SV * const * const other_elem = av_fetch(other_av, i, FALSE);
if (!this_elem || !other_elem) {
- if (this_elem || other_elem)
+ if ((this_elem && SvOK(*this_elem))
+ || (other_elem && SvOK(*other_elem)))
RETPUSHNO;
}
- else if (SM_SEEN_THIS(*this_elem)
- || SM_SEEN_OTHER(*other_elem))
+ else if (hv_exists_ent(seen_this,
+ sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
+ hv_exists_ent(seen_other,
+ sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
{
if (*this_elem != *other_elem)
RETPUSHNO;
(void)hv_store_ent(seen_other,
sv_2mortal(newSViv(PTR2IV(*other_elem))),
&PL_sv_undef, 0);
- PUSHs(*this_elem);
PUSHs(*other_elem);
+ PUSHs(*this_elem);
PUTBACK;
+ DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
(void) do_smartmatch(seen_this, seen_other);
SPAGAIN;
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
if (!SvTRUEx(POPs))
RETPUSHNO;
RETPUSHYES;
}
}
- else if (SM_OTHER_REGEX) {
- PMOP * const matcher = make_matcher(other_regex);
- const I32 this_len = av_len(MUTABLE_AV(This));
- I32 i;
-
- for(i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
- if (svp && matcher_matches_sv(matcher, *svp)) {
- destroy_matcher(matcher);
- RETPUSHYES;
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
+ sm_regex_array:
+ {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
+ const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
+ I32 i;
+
+ for(i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
+ if (svp && matcher_matches_sv(matcher, *svp)) {
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
}
+ destroy_matcher(matcher);
+ RETPUSHNO;
}
- destroy_matcher(matcher);
- RETPUSHNO;
}
- else if (SvIOK(Other) || SvNOK(Other)) {
+ else if (!SvOK(d)) {
+ /* undef ~~ array */
+ const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
I32 i;
- for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
- SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
- if (!svp)
- continue;
-
- PUSHs(Other);
- PUSHs(*svp);
- PUTBACK;
- if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
- (void) pp_i_eq();
- else
- (void) pp_eq();
- SPAGAIN;
- if (SvTRUEx(POPs))
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
+ for (i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
+ if (!svp || !SvOK(*svp))
RETPUSHYES;
}
RETPUSHNO;
}
- else if (SvPOK(Other)) {
- const I32 this_len = av_len(MUTABLE_AV(This));
- I32 i;
+ else {
+ sm_any_array:
+ {
+ I32 i;
+ const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
- for(i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
- if (!svp)
- continue;
-
- PUSHs(Other);
- PUSHs(*svp);
- PUTBACK;
- (void) pp_seq();
- SPAGAIN;
- if (SvTRUEx(POPs))
- RETPUSHYES;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
+ for (i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ if (!svp)
+ continue;
+
+ PUSHs(d);
+ PUSHs(*svp);
+ PUTBACK;
+ /* infinite recursion isn't supposed to happen here */
+ DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
+ (void) do_smartmatch(NULL, NULL);
+ SPAGAIN;
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
}
- RETPUSHNO;
}
}
- else if (!SvOK(d) || !SvOK(e)) {
- if (!SvOK(d) && !SvOK(e))
- RETPUSHYES;
- else
- RETPUSHNO;
- }
- else if (SM_REGEX) {
- PMOP * const matcher = make_matcher(this_regex);
+ /* ~~ qr// */
+ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
+ if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ SV *t = d; d = e; e = t;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
+ goto sm_regex_hash;
+ }
+ else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ SV *t = d; d = e; e = t;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
+ goto sm_regex_array;
+ }
+ else {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
- PUTBACK;
- PUSHs(matcher_matches_sv(matcher, Other)
- ? &PL_sv_yes
- : &PL_sv_no);
- destroy_matcher(matcher);
- RETURN;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
+ PUTBACK;
+ PUSHs(matcher_matches_sv(matcher, d)
+ ? &PL_sv_yes
+ : &PL_sv_no);
+ destroy_matcher(matcher);
+ RETURN;
+ }
}
- else if (SM_REF(PVCV)) {
- I32 c;
- /* This must be a null-prototyped sub, because we
- already checked for the other kind. */
-
- ENTER;
- SAVETMPS;
- PUSHMARK(SP);
+ /* ~~ scalar */
+ /* See if there is overload magic on left */
+ else if (object_on_left && SvAMAGIC(d)) {
+ SV *tmpsv;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
+ DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
+ PUSHs(d); PUSHs(e);
PUTBACK;
- c = call_sv(This, G_SCALAR);
- SPAGAIN;
- if (c == 0)
- PUSHs(&PL_sv_undef);
- else if (SvTEMP(TOPs))
- SvREFCNT_inc_void(TOPs);
-
- if (SM_OTHER_REF(PVCV)) {
- /* This one has to be null-proto'd too.
- Call both of 'em, and compare the results */
- PUSHMARK(SP);
- c = call_sv(SvRV(Other), G_SCALAR);
+ tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
+ if (tmpsv) {
SPAGAIN;
- if (c == 0)
- PUSHs(&PL_sv_undef);
- else if (SvTEMP(TOPs))
- SvREFCNT_inc_void(TOPs);
- FREETMPS;
- LEAVE;
- PUTBACK;
- return pp_eq();
+ (void)POPs;
+ SETs(tmpsv);
+ RETURN;
}
-
- FREETMPS;
- LEAVE;
- RETURN;
+ SP -= 2;
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
+ goto sm_any_scalar;
}
- else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
- || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
- {
- if (SvPOK(Other) && !looks_like_number(Other)) {
- /* String comparison */
- PUSHs(d); PUSHs(e);
- PUTBACK;
- return pp_seq();
- }
- /* Otherwise, numeric comparison */
+ else if (!SvOK(d)) {
+ /* undef ~~ scalar ; we already know that the scalar is SvOK */
+ DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
+ RETPUSHNO;
+ }
+ else
+ sm_any_scalar:
+ if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
+ DEBUG_M(if (SvNIOK(e))
+ Perl_deb(aTHX_ " applying rule Any-Num\n");
+ else
+ Perl_deb(aTHX_ " applying rule Num-numish\n");
+ );
+ /* numeric comparison */
PUSHs(d); PUSHs(e);
PUTBACK;
if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
}
/* As a last resort, use string comparison */
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
PUSHs(d); PUSHs(e);
PUTBACK;
return pp_seq();
if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
return cLOGOP->op_other->op_next;
- ENTER;
+ ENTER_with_name("eval");
SAVETMPS;
PUSHBLOCK(cx, CXt_WHEN, SP);
PL_curpm = newpm; /* pop $1 et al */
- LEAVE;
+ LEAVE_with_name("eval");
return NORMAL;
}
int status = 0;
SV *upstream;
STRLEN got_len;
- const char *got_p = NULL;
- const char *prune_from = NULL;
+ char *got_p = NULL;
+ char *prune_from = NULL;
bool read_from_cache = FALSE;
STRLEN umaxlen;
for PL_parser->error_count == 0.) Solaris doesn't segfault --
not sure where the trouble is yet. XXX */
- if (IoFMT_GV(datasv)) {
- SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
+ {
+ SV *const cache = datasv;
if (SvOK(cache)) {
STRLEN cache_len;
const char *cache_p = SvPV(cache, cache_len);
dSP;
int count;
- ENTER;
+ ENTER_with_name("call_filter_sub");
SAVE_DEFSV;
SAVETMPS;
EXTEND(SP, 2);
- DEFSV = upstream;
+ DEFSV_set(upstream);
PUSHMARK(SP);
mPUSHi(0);
if (filter_state) {
PUTBACK;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("call_filter_sub");
}
if(SvOK(upstream)) {
prune_from = got_p + umaxlen;
}
} else {
- const char *const first_nl =
- (const char *)memchr(got_p, '\n', got_len);
+ char *const first_nl = (char *)memchr(got_p, '\n', got_len);
if (first_nl && first_nl + 1 < got_p + got_len) {
/* There's a second line here... */
prune_from = first_nl + 1;
if (prune_from) {
/* Oh. Too long. Stuff some in our cache. */
STRLEN cached_len = got_p + got_len - prune_from;
- SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
+ SV *const cache = datasv;
- if (!cache) {
- IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
- } else if (SvOK(cache)) {
+ if (SvOK(cache)) {
/* Cache should be empty. */
assert(!SvCUR(cache));
}
SvUTF8_on(cache);
}
SvCUR_set(upstream, got_len - cached_len);
+ *prune_from = 0;
/* Can't yet be EOF */
if (status == 0)
status = 1;
if (status <= 0) {
IoLINES(datasv) = 0;
- SvREFCNT_dec(IoFMT_GV(datasv));
if (filter_state) {
SvREFCNT_dec(filter_state);
IoTOP_GV(datasv) = NULL;
PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
if (PERL_FILE_IS_ABSOLUTE(name)
-#ifdef MACOS_TRADITIONAL
- || (*name == ':')
+#ifdef WIN32
+ || (*name == '.' && ((name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/'))
+ || (name[1] == '\\' ||
+ ( name[1] == '.' && name[2] == '\\')))
+ )
#else
|| (*name == '.' && (name[1] == '/' ||
(name[1] == '.' && name[2] == '/')))
https://perl5.git.perl.org / perl5.git / blobdiff