+PP(pp_entergiven)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
+ ENTER;
+ 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);
+
+ PUSHBLOCK(cx, CXt_GIVEN, SP);
+ PUSHGIVEN(cx);
+
+ RETURN;
+}
+
+PP(pp_leavegiven)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+ PERL_UNUSED_CONTEXT;
+
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_GIVEN);
+
+ SP = newsp;
+ PUTBACK;
+
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE;
+
+ return NORMAL;
+}
+
+/* Helper routines used by pp_smartmatch */
+STATIC PMOP *
+S_make_matcher(pTHX_ REGEXP *re)
+{
+ dVAR;
+ PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
+
+ PERL_ARGS_ASSERT_MAKE_MATCHER;
+
+ PM_SETRE(matcher, ReREFCNT_inc(re));
+
+ SAVEFREEOP((OP *) matcher);
+ ENTER; SAVETMPS;
+ SAVEOP();
+ return matcher;
+}
+
+STATIC bool
+S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
+{
+ dVAR;
+ dSP;
+
+ PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
+
+ PL_op = (OP *) matcher;
+ XPUSHs(sv);
+ PUTBACK;
+ (void) pp_match();
+ SPAGAIN;
+ return (SvTRUEx(POPs));
+}
+
+STATIC void
+S_destroy_matcher(pTHX_ PMOP *matcher)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_DESTROY_MATCHER;
+ PERL_UNUSED_ARG(matcher);
+
+ FREETMPS;
+ LEAVE;
+}
+
+/* Do a smart match */
+PP(pp_smartmatch)
+{
+ return do_smartmatch(NULL, NULL);
+}
+
+/* This version of do_smartmatch() implements the
+ * table of smart matches that is found in perlsyn.
+ */
+STATIC OP *
+S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
+{
+ dVAR;
+ dSP;
+
+ 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_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)))
+
+
+# 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.
+ * Currently we do this by copying the SV if it's magical. */
+ if (d) {
+ if (SvGMAGICAL(d))
+ d = sv_mortalcopy(d);
+ }
+ else
+ d = &PL_sv_undef;
+
+ assert(e);
+ if (SvGMAGICAL(e))
+ e = sv_mortalcopy(e);
+
+ if (SM_CV_NEP) {
+ I32 c;
+
+ if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
+ {
+ if (This == SvRV(Other))
+ 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 (SM_REF(PVHV)) {
+ if (SM_OTHER_REF(PVHV)) {
+ /* Check that the key-sets are identical */
+ HE *he;
+ HV *other_hv = (HV *) SvRV(Other);
+ bool tied = FALSE;
+ bool other_tied = FALSE;
+ U32 this_key_count = 0,
+ other_key_count = 0;
+
+ /* Tied hashes don't know how many keys they have. */
+ if (SvTIED_mg(This, PERL_MAGIC_tied)) {
+ tied = TRUE;
+ }
+ else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
+ HV * const temp = other_hv;
+ other_hv = (HV *) This;
+ This = (SV *) temp;
+ tied = TRUE;
+ }
+ if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
+ other_tied = TRUE;
+
+ if (!tied && HvUSEDKEYS((HV *) This) != 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((HV *) This);
+ while ( (he = hv_iternext((HV *) This)) ) {
+ I32 key_len;
+ char * const key = hv_iterkey(he, &key_len);
+
+ ++ this_key_count;
+
+ if(!hv_exists(other_hv, key, key_len)) {
+ (void) hv_iterinit((HV *) This); /* reset iterator */
+ RETPUSHNO;
+ }
+ }
+
+ if (other_tied) {
+ (void) hv_iterinit(other_hv);
+ while ( hv_iternext(other_hv) )
+ ++other_key_count;
+ }
+ else
+ other_key_count = HvUSEDKEYS(other_hv);
+
+ if (this_key_count != other_key_count)
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+ }
+ else if (SM_OTHER_REF(PVAV)) {
+ AV * const other_av = (AV *) SvRV(Other);
+ const I32 other_len = av_len(other_av) + 1;
+ I32 i;
+
+ for (i = 0; i < other_len; ++i) {
+ SV ** const svp = av_fetch(other_av, i, FALSE);
+ char *key;
+ STRLEN key_len;
+
+ if (svp) { /* ??? When can this not happen? */
+ key = SvPV(*svp, key_len);
+ if (hv_exists((HV *) This, key, key_len))
+ RETPUSHYES;
+ }
+ }
+ RETPUSHNO;
+ }
+ else if (SM_OTHER_REGEX) {
+ PMOP * const matcher = make_matcher(other_regex);
+ HE *he;
+
+ (void) hv_iterinit((HV *) This);
+ while ( (he = hv_iternext((HV *) This)) ) {
+ if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
+ (void) hv_iterinit((HV *) This);
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
+ }
+ destroy_matcher(matcher);
+ RETPUSHNO;
+ }
+ else {
+ if (hv_exists_ent((HV *) This, Other, 0))
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+ }
+ else if (SM_REF(PVAV)) {
+ if (SM_OTHER_REF(PVAV)) {
+ AV *other_av = (AV *) SvRV(Other);
+ if (av_len((AV *) This) != av_len(other_av))
+ RETPUSHNO;
+ else {
+ I32 i;
+ const I32 other_len = av_len(other_av);
+
+ if (NULL == seen_this) {
+ seen_this = newHV();
+ (void) sv_2mortal((SV *) seen_this);
+ }
+ if (NULL == seen_other) {
+ seen_this = newHV();
+ (void) sv_2mortal((SV *) seen_other);
+ }
+ for(i = 0; i <= other_len; ++i) {
+ SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
+ SV * const * const other_elem = av_fetch(other_av, i, FALSE);
+
+ if (!this_elem || !other_elem) {
+ if (this_elem || other_elem)
+ RETPUSHNO;
+ }
+ else if (SM_SEEN_THIS(*this_elem)
+ || SM_SEEN_OTHER(*other_elem))
+ {
+ if (*this_elem != *other_elem)
+ RETPUSHNO;
+ }
+ else {
+ (void)hv_store_ent(seen_this,
+ sv_2mortal(newSViv(PTR2IV(*this_elem))),
+ &PL_sv_undef, 0);
+ (void)hv_store_ent(seen_other,
+ sv_2mortal(newSViv(PTR2IV(*other_elem))),
+ &PL_sv_undef, 0);
+ PUSHs(*this_elem);
+ PUSHs(*other_elem);
+
+ PUTBACK;
+ (void) do_smartmatch(seen_this, seen_other);
+ SPAGAIN;
+
+ if (!SvTRUEx(POPs))
+ RETPUSHNO;
+ }
+ }
+ RETPUSHYES;
+ }
+ }
+ else if (SM_OTHER_REGEX) {
+ PMOP * const matcher = make_matcher(other_regex);
+ const I32 this_len = av_len((AV *) This);
+ I32 i;
+
+ for(i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch((AV *)This, i, FALSE);
+ if (svp && matcher_matches_sv(matcher, *svp)) {
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
+ }
+ destroy_matcher(matcher);
+ RETPUSHNO;
+ }
+ else if (SvIOK(Other) || SvNOK(Other)) {
+ I32 i;
+
+ for(i = 0; i <= AvFILL((AV *) This); ++i) {
+ SV * const * const svp = av_fetch((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))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+ }
+ else if (SvPOK(Other)) {
+ const I32 this_len = av_len((AV *) This);
+ I32 i;
+
+ for(i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch((AV *)This, i, FALSE);
+ if (!svp)
+ continue;
+
+ PUSHs(Other);
+ PUSHs(*svp);
+ PUTBACK;
+ (void) pp_seq();
+ SPAGAIN;
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ }
+ 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);
+
+ PUTBACK;
+ PUSHs(matcher_matches_sv(matcher, Other)
+ ? &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);
+ 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);
+ SPAGAIN;
+ if (c == 0)
+ PUSHs(&PL_sv_undef);
+ else if (SvTEMP(TOPs))
+ SvREFCNT_inc_void(TOPs);
+ FREETMPS;
+ LEAVE;
+ PUTBACK;
+ return pp_eq();
+ }
+
+ FREETMPS;
+ LEAVE;
+ RETURN;
+ }
+ 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 */
+ PUSHs(d); PUSHs(e);
+ PUTBACK;
+ if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
+ (void) pp_i_eq();
+ else
+ (void) pp_eq();
+ SPAGAIN;
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+
+ /* As a last resort, use string comparison */
+ PUSHs(d); PUSHs(e);
+ PUTBACK;
+ return pp_seq();
+}
+
+PP(pp_enterwhen)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
+ /* This is essentially an optimization: if the match
+ fails, we don't want to push a context and then
+ pop it again right away, so we skip straight
+ to the op that follows the leavewhen.
+ */
+ if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
+ return cLOGOP->op_other->op_next;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHBLOCK(cx, CXt_WHEN, SP);
+ PUSHWHEN(cx);
+
+ RETURN;
+}
+
+PP(pp_leavewhen)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_WHEN);
+
+ SP = newsp;
+ PUTBACK;
+
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE;
+ return NORMAL;
+}
+
+PP(pp_continue)
+{
+ dVAR;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 inner;
+
+ cxix = dopoptowhen(cxstack_ix);
+ if (cxix < 0)
+ DIE(aTHX_ "Can't \"continue\" outside a when block");
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* clear off anything above the scope we're re-entering */
+ inner = PL_scopestack_ix;
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+ return cx->blk_givwhen.leave_op;
+}
+
+PP(pp_break)
+{
+ dVAR;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 inner;
+
+ cxix = dopoptogiven(cxstack_ix);
+ if (cxix < 0) {
+ if (PL_op->op_flags & OPf_SPECIAL)
+ DIE(aTHX_ "Can't use when() outside a topicalizer");
+ else
+ DIE(aTHX_ "Can't \"break\" outside a given block");
+ }
+ if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
+ DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* clear off anything above the scope we're re-entering */
+ inner = PL_scopestack_ix;
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+
+ if (CxFOREACH(cx))
+ return CX_LOOP_NEXTOP_GET(cx);
+ else
+ return cx->blk_givwhen.leave_op;
+}
+