path: root/stolen_chunk_of_pp_ctl.c

#define NEED_sv_2pv_flags
#include "ppport.h"

/* embed.h */

#define destroy_matcher(a)	S_destroy_matcher(aTHX_ a)
#define do_smartmatch(a,b)	S_do_smartmatch(aTHX_ a,b)
#define make_matcher(a)		S_make_matcher(aTHX_ a)
#define matcher_matches_sv(a,b)	S_matcher_matches_sv(aTHX_ a,b)

/* proto.h */

STATIC void	S_destroy_matcher(pTHX_ PMOP* matcher)
			__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_DESTROY_MATCHER	\
	assert(matcher)

STATIC OP*	S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other);

STATIC PMOP*	S_make_matcher(pTHX_ REGEXP* re)
			__attribute__warn_unused_result__
			__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_MAKE_MATCHER	\
	assert(re)

STATIC bool	S_matcher_matches_sv(pTHX_ PMOP* matcher, SV* sv)
			__attribute__warn_unused_result__
			__attribute__nonnull__(pTHX_1)
			__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_MATCHER_MATCHES_SV	\
	assert(matcher); assert(sv)

/* pp_ctl.c */

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_with_name("matcher"); 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) Perl_pp_match(aTHX);
    SPAGAIN;
    return (SvTRUEx(POPs));
}

STATIC void
S_destroy_matcher(pTHX_ PMOP *matcher)
{
    dVAR;

    PERL_ARGS_ASSERT_DESTROY_MATCHER;
    PERL_UNUSED_ARG(matcher);

    FREETMPS;
    LEAVE_with_name("matcher");
}

PP(pp_old_smartmatch)
{
    DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
    return do_smartmatch(NULL, NULL);
}

STATIC OP *
S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
{
    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 */

    /* 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);

    /* 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"));
    }

    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)) {
	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 (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;
	}
	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;
	}
    }
    /* ~~ %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(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((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 = hv;
		hv = temp;
		tied = TRUE;
	    }
	    if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
		other_tied = TRUE;
	    
	    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(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_ent(other_hv, key, 0)) {
	    	    (void) hv_iterinit(hv);	/* 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 (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);
		DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
		if (svp) {	/* ??? When can this not happen? */
		    if (hv_exists_ent(hv, *svp, 0))
		        RETPUSHYES;
		}
	    }
	    RETPUSHNO;
	}
	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;
	    }
	}
	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
		RETPUSHNO;
	}
    }
    /* ~~ @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;
	    	const I32 other_len = av_len(other_av);

		if (NULL == seen_this) {
		    seen_this = newHV();
		    (void) sv_2mortal(MUTABLE_SV(seen_this));
		}
		if (NULL == seen_other) {
		    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(SvRV(e)), i, FALSE);
		    SV * const * const other_elem = av_fetch(other_av, i, FALSE);

		    if (!this_elem || !other_elem) {
			if ((this_elem && SvOK(*this_elem))
				|| (other_elem && SvOK(*other_elem)))
			    RETPUSHNO;
		    }
		    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;
		    }
		    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(*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 (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;
	    }
	}
	else if (!SvOK(d)) {
	    /* undef ~~ array */
	    const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
	    I32 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);
		DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
		if (!svp || !SvOK(*svp))
		    RETPUSHYES;
	    }
	    RETPUSHNO;
	}
	else {
	  sm_any_array:
	    {
		I32 i;
		const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));

		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;
	    }
	}
    }
    /* ~~ 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));

	    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;
	}
    }
    /* ~~ 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;
	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;
	if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
	    (void) Perl_pp_i_eq(aTHX);
	else
	    (void) Perl_pp_eq(aTHX);
	SPAGAIN;
	if (SvTRUEx(POPs))
	    RETPUSHYES;
	else
	    RETPUSHNO;
    }
    
    /* As a last resort, use string comparison */
    DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
    PUSHs(d); PUSHs(e);
    PUTBACK;
    return Perl_pp_seq(aTHX);
}