add -DM flag to track smartmatch resolution

diff --git a/perl.c b/perl.c
index 9ef9cd7..6c1b543 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2863,6 +2863,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       "  C  Copy On Write",
       "  A  Consistency checks on internal structures",
       "  q  quiet - currently only suppresses the 'EXECUTING' message",
+      "  M  trace smart match resolution",
       NULL
     };
     int i = 0;
@@ -2871,7 +2872,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
 
     if (isALPHA(**s)) {
        /* if adding extra options, remember to update DEBUG_MASK */
-       static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
+       static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqM";
 
        for (; isALNUM(**s); (*s)++) {
            const char * const d = strchr(debopts,**s);

diff --git a/perl.h b/perl.h
index 6fafe9a..75c52e7 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3619,7 +3619,8 @@ Gid_t getegid (void);
 #define DEBUG_C_FLAG           0x00200000 /*2097152 */
 #define DEBUG_A_FLAG           0x00400000 /*4194304 */
 #define DEBUG_q_FLAG           0x00800000 /*8388608 */
-#define DEBUG_MASK             0x00FEEFFF /* mask of all the standard flags */
+#define DEBUG_M_FLAG           0x01000000 /*8388608 */
+#define DEBUG_MASK             0x01FEEFFF /* mask of all the standard flags */
 
 #define DEBUG_DB_RECURSE_FLAG  0x40000000
 #define DEBUG_TOP_FLAG         0x80000000 /* XXX what's this for ??? Signal
@@ -3648,6 +3649,7 @@ Gid_t getegid (void);
 #  define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG)
 #  define DEBUG_A_TEST_ (PL_debug & DEBUG_A_FLAG)
 #  define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG)
+#  define DEBUG_M_TEST_ (PL_debug & DEBUG_M_FLAG)
 #  define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_)
 #  define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_)
 
@@ -3676,6 +3678,7 @@ Gid_t getegid (void);
 #  define DEBUG_C_TEST DEBUG_C_TEST_
 #  define DEBUG_A_TEST DEBUG_A_TEST_
 #  define DEBUG_q_TEST DEBUG_q_TEST_
+#  define DEBUG_M_TEST DEBUG_M_TEST_
 #  define DEBUG_Xv_TEST DEBUG_Xv_TEST_
 #  define DEBUG_Uv_TEST DEBUG_Uv_TEST_
 
@@ -3722,6 +3725,7 @@ Gid_t getegid (void);
 #  define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a)
 #  define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a)
 #  define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a)
+#  define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a)
 
 #else /* DEBUGGING */
 
@@ -3748,6 +3752,7 @@ Gid_t getegid (void);
 #  define DEBUG_C_TEST (0)
 #  define DEBUG_A_TEST (0)
 #  define DEBUG_q_TEST (0)
+#  define DEBUG_M_TEST (0)
 #  define DEBUG_Xv_TEST (0)
 #  define DEBUG_Uv_TEST (0)
 
@@ -3775,6 +3780,7 @@ Gid_t getegid (void);
 #  define DEBUG_C(a)
 #  define DEBUG_A(a)
 #  define DEBUG_q(a)
+#  define DEBUG_M(a)
 #  define DEBUG_Xv(a)
 #  define DEBUG_Uv(a)
 #endif /* DEBUGGING */

diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 994aecb..3d177eb 100644 (file)
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -417,6 +417,7 @@ B<-D14> is equivalent to B<-Dtls>):
   2097152  C  Copy On Write
   4194304  A  Consistency checks on internal structures
   8388608  q  quiet - currently only suppresses the "EXECUTING" message
+ 16777216  M  trace smart match resolution
 
 All these flags require B<-DDEBUGGING> when you compile the Perl
 executable (but see L<Devel::Peek>, L<re> which may change this).

diff --git a/pp_ctl.c b/pp_ctl.c
index 453d6d7..35e3436 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3990,6 +3990,7 @@ S_destroy_matcher(pTHX_ PMOP *matcher)
 /* Do a smart match */
 PP(pp_smartmatch)
 {
+    DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
     return do_smartmatch(NULL, NULL);
 }
 
@@ -4008,13 +4009,18 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 
     /* 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 */
@@ -4034,14 +4040,17 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 
     /* ~~ 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;
 
@@ -4057,9 +4066,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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;
                SAVETMPS;
                PUSHMARK(SP);
@@ -4085,10 +4096,12 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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;
                SAVETMPS;
                PUSHMARK(SP);
@@ -4111,6 +4124,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
        }
        else {
          sm_any_sub:
+           DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
            ENTER;
            SAVETMPS;
            PUSHMARK(SP);
@@ -4133,6 +4147,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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) {
@@ -4144,7 +4159,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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;
@@ -4166,7 +4182,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_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)) {
@@ -4194,8 +4211,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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;
@@ -4204,6 +4223,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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));
@@ -4212,6 +4232,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 
                (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);
@@ -4224,6 +4245,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
        }
        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
@@ -4240,8 +4262,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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;
@@ -4251,6 +4276,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
        }
        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 {
@@ -4292,8 +4318,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                        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;
@@ -4303,6 +4331,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            }
        }
        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));
@@ -4311,6 +4340,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 
                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;
@@ -4325,8 +4355,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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;
            }
@@ -4338,6 +4370,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                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)
@@ -4347,8 +4380,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                    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;
                }
@@ -4360,15 +4395,18 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     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
@@ -4381,6 +4419,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     /* 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);
@@ -4391,15 +4431,22 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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;
@@ -4415,6 +4462,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     }
     
     /* 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();