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);
+ re = reg_temp_copy(NULL, re);
ReREFCNT_dec(PM_GETRE(pm));
PM_SETRE(pm, re);
}
if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
cx->sb_rxtainted |= 2;
sv_catsv(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;
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;
*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];
}
}
}
- 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 */
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_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;
++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), "%s",
- 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);
*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) */
}
/* don't do recursive DB::DB call */
return NORMAL;
- ENTER;
+ ENTER_with_name("sub");
SAVETMPS;
SAVEI32(PL_debug);
(void)(*CvXSUB(cv))(aTHX_ cv);
CvDEPTH(cv)--;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("sub");
return NORMAL;
}
else {
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;
}
PUSHMARK(mark);
PUTBACK;
(void)(*CvXSUB(cv))(aTHX_ cv);
- LEAVE;
+ LEAVE_with_name("sub");
return retop;
}
else {
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:
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
POPEVAL(cx);
}
lex_end();
- LEAVE; /* pp_entereval knows about this LEAVE. */
+ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
msg = SvPVx_nolen_const(ERRSV);
if (optype == OP_REQUIRE) {
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 = 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;
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 */
TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
- ENTER;
+ ENTER_with_name("eval");
lex_start(sv, NULL, FALSE);
SAVETMPS;
introduced within evals. See force_ident(). GSAR 96-10-12 */
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) {
/* 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 */
+ /* First of all, handle overload magic of the rightmost argument */
if (SvAMAGIC(e)) {
- SV * const tmpsv = amagic_call(d, e, smart_amg, 0);
+ 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"));
}
SP -= 2; /* Pop the values */
/* ~~ 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))
+ 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;
/* ~~ sub */
if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
I32 c;
- if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ 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)) ) {
- ENTER;
+ DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
+ ENTER_with_name("smartmatch_hash_key_test");
SAVETMPS;
PUSHMARK(SP);
PUSHs(hv_iterkeysv(he));
else
andedresults = SvTRUEx(POPs) && andedresults;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("smartmatch_hash_key_test");
}
if (andedresults)
RETPUSHYES;
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);
- ENTER;
+ DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
+ ENTER_with_name("smartmatch_array_elem_test");
SAVETMPS;
PUSHMARK(SP);
if (svp)
else
andedresults = SvTRUEx(POPs) && andedresults;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("smartmatch_array_elem_test");
}
if (andedresults)
RETPUSHYES;
RETPUSHNO;
}
else {
- ENTER;
+ sm_any_sub:
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
+ ENTER_with_name("smartmatch_coderef");
SAVETMPS;
PUSHMARK(SP);
PUSHs(d);
else if (SvTEMP(TOPs))
SvREFCNT_inc_void(TOPs);
FREETMPS;
- LEAVE;
+ LEAVE_with_name("smartmatch_coderef");
RETURN;
}
}
/* ~~ %hash */
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
- if (!SvOK(d)) {
+ 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) {
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((SV*)hv, PERL_MAGIC_tied)) {
tied = TRUE;
to check that one is a subset of the other. */
(void) hv_iterinit(hv);
while ( (he = hv_iternext(hv)) ) {
- I32 key_len;
- char * const key = hv_iterkey(he, &key_len);
-
+ 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)) {
+ if(!hv_exists_ent(other_hv, key, 0)) {
(void) hv_iterinit(hv); /* reset iterator */
RETPUSHNO;
}
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(hv, key, key_len))
+ if (hv_exists_ent(hv, *svp, 0))
RETPUSHYES;
}
}
RETPUSHNO;
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
- 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)) ) {
- if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
- (void) hv_iterinit(hv);
- destroy_matcher(matcher);
- RETPUSHYES;
+ 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 {
+ 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
}
/* ~~ @array */
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
- if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ 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);
- char *key;
- STRLEN key_len;
+ DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
if (svp) { /* ??? When can this not happen? */
- key = SvPV(*svp, key_len);
- if (hv_exists(MUTABLE_HV(SvRV(d)), key, key_len))
+ if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
RETPUSHYES;
}
}
}
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 {
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;
}
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
- 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);
- if (svp && matcher_matches_sv(matcher, *svp)) {
- destroy_matcher(matcher);
- RETPUSHYES;
+ 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 (SvNIOK(d)) {
+ 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(SvRV(e))); ++i) {
+ 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);
- if (!svp)
- continue;
-
- PUSHs(d);
- 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_ " testing for undef element...\n"));
+ if (!svp || !SvOK(*svp))
RETPUSHYES;
}
RETPUSHNO;
}
- else if (SvPOK(d)) {
- const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
- 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(SvRV(e)), i, FALSE);
- if (!svp)
- continue;
-
- PUSHs(d);
- 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;
}
}
/* ~~ qr// */
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
- PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
+ 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, d)
- ? &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;
+ }
}
- /* ~~ X..Y TODO */
/* ~~ scalar */
- else if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
+ /* 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;
+ tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
+ if (tmpsv) {
+ SPAGAIN;
+ (void)POPs;
+ SETs(tmpsv);
+ RETURN;
+ }
+ SP -= 2;
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
+ goto sm_any_scalar;
+ }
+ 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;
}
/* 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;
}
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);
PUTBACK;
FREETMPS;
- LEAVE;
+ LEAVE_with_name("call_filter_sub");
}
if(SvOK(upstream)) {
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));
}
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 WIN32
+ || (*name == '.' && ((name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/'))
+ || (name[1] == '\\' ||
+ ( name[1] == '.' && name[2] == '\\')))
+ )
+#else
|| (*name == '.' && (name[1] == '/' ||
(name[1] == '.' && name[2] == '/')))
+#endif
)
{
return TRUE;
https://perl5.git.perl.org / perl5.git / blobdiff