Make smart matching ~~ undef dispatch only on the RHS

diff --git a/pp_ctl.c b/pp_ctl.c
index 33ac1ee..db4ba16 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4042,12 +4042,6 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
        && (this_regex = (REGEXP*) This)                                \
        && (Other = d)) )
        
-
-#   define SM_OBJECT ( \
-          (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))          \
-    ||                                                                 \
-          (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) )        \
-
 #   define SM_OTHER_REF(type) \
        (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
 
@@ -4063,7 +4057,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *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. 
@@ -4079,13 +4073,17 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     if (SvGMAGICAL(e))
        e = sv_mortalcopy(e);
 
-    if (SM_OBJECT) {
-       if (!SvOK(d) || !SvOK(e))
+    if (!SvOK(e)) {
+       if (SvOK(d))
            RETPUSHNO;
        else
-           Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+           RETPUSHYES;
     }
 
+    if ((sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
+           || (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)))
+       Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+
     if (SM_REF(PVCV)) {
        I32 c;
        ENTER;
@@ -4305,12 +4303,6 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            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);
 

diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t
index 52e7f91..0097bff 100644 (file)
--- a/t/op/smartmatch.t
+++ b/t/op/smartmatch.t
@@ -135,6 +135,7 @@ __DATA__
 !      ""              undef
 !      !1              undef
        undef           undef
+       (my $u)         undef
 
 # Any ~~ object overloaded
 # object overloaded ~~ Any

diff --git a/t/op/switch.t b/t/op/switch.t
index b00ade8..de44082 100644 (file)
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -133,14 +133,16 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
     is($ok, 1, "Given(0) when($undef++)");
 }
 {
-    my $ok = 1;
-    given (undef) { when(0) {$ok = 0} }
+    no warnings "uninitialized";
+    my $ok = 0;
+    given (undef) { when(0) {$ok = 1} }
     is($ok, 1, "Given(undef) when(0)");
 }
 {
+    no warnings "uninitialized";
     my $undef;
-    my $ok = 1;
-    given ($undef) { when(0) {$ok = 0} }
+    my $ok = 0;
+    given ($undef) { when(0) {$ok = 1} }
     is($ok, 1, 'Given($undef) when(0)');
 }
 ########
@@ -156,14 +158,16 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
     is($ok, 1, 'Given("") when($undef)');
 }
 {
-    my $ok = 1;
-    given (undef) { when("") {$ok = 0} }
+    no warnings "uninitialized";
+    my $ok = 0;
+    given (undef) { when("") {$ok = 1} }
     is($ok, 1, 'Given(undef) when("")');
 }
 {
+    no warnings "uninitialized";
     my $undef;
-    my $ok = 1;
-    given ($undef) { when("") {$ok = 0} }
+    my $ok = 0;
+    given ($undef) { when("") {$ok = 1} }
     is($ok, 1, 'Given($undef) when("")');
 }
 ########
@@ -617,6 +621,7 @@ my $f = tie my $v, "FetchCounter";
     my $ok;
     $v = undef;
     is($f->count(), 0, "Sanity check: $test_name");
+    no warnings "uninitialized";
     given(my $undef) {
        when(sub{0}->()) {}
        when("21")  {}