-
- /* ~~ undef */
- if (!SvOK(e)) {
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
- if (SvOK(d))
- RETPUSHNO;
- else
- RETPUSHYES;
- }
-
- if (SvROK(e) && SvOBJECT(SvRV(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 (SvROK(d) && SvOBJECT(SvRV(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 */
- SSize_t i;
- bool andedresults = TRUE;
- AV *av = (AV*) SvRV(d);
- const I32 len = av_tindex(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;
- bool other_tied;
- 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. */
- tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
- other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
- if (!tied ) {
- if(other_tied) {
- /* swap HV sides */
- HV * const temp = other_hv;
- other_hv = hv;
- hv = temp;
- tied = TRUE;
- other_tied = FALSE;
- }
- else if(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 SSize_t other_len = av_tindex(other_av) + 1;
- SSize_t 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"));
- PUTBACK;
- if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
- SPAGAIN;
- (void) hv_iterinit(hv);
- destroy_matcher(matcher);
- RETPUSHYES;
- }
- SPAGAIN;
- }
- 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 SSize_t other_len = av_tindex(other_av) + 1;
- SSize_t 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_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
- RETPUSHNO;
- else {
- SSize_t i;
- const SSize_t other_len = av_tindex(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, 0);
- 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 SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
- SSize_t 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"));
- PUTBACK;
- if (svp && matcher_matches_sv(matcher, *svp)) {
- SPAGAIN;
- destroy_matcher(matcher);
- RETPUSHYES;
- }
- SPAGAIN;
- }
- destroy_matcher(matcher);
- RETPUSHNO;
- }
- }
- else if (!SvOK(d)) {
- /* undef ~~ array */
- const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
- SSize_t 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:
- {
- SSize_t i;
- const SSize_t this_len = av_tindex(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, 1);
- 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));
- bool result;
-
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
- PUTBACK;
- result = matcher_matches_sv(matcher, d);
- SPAGAIN;
- PUSHs(result ? &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);
https://perl5.git.perl.org / perl5.git / blobdiff