Allow ~~ overloading on the left side, when the right side is a plain scalar

diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod
index 4302cf4..20ec68e 100644 (file)
--- a/pod/perlsyn.pod
+++ b/pod/perlsyn.pod
@@ -717,6 +717,7 @@ and "Array" entries apply in those cases. (For blessed references, the
     Array   Regex     array grep               grep /$b/, @$a
     Any     Regex     pattern match            $a =~ /$b/
 
     Array   Regex     array grep               grep /$b/, @$a
     Any     Regex     pattern match            $a =~ /$b/
 

+    Object  Any       invokes ~~ overloading on $object, or falls back:

     Any     Num       numeric equality         $a == $b
     Num     numish[4] numeric equality         $a == $b
     Any     Any       string equality          $a eq $b
     Any     Num       numeric equality         $a == $b
     Num     numish[4] numeric equality         $a == $b
     Any     Any       string equality          $a eq $b

diff --git a/pp_ctl.c b/pp_ctl.c
index e12b671..5adfc68 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4001,6 +4001,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     SV *e = TOPs;      /* e is for 'expression' */
     SV *d = TOPm1s;    /* d is for 'default', as in PL_defgv */
 
     SV *e = TOPs;      /* e is for 'expression' */
     SV *d = TOPm1s;    /* d is for 'default', as in PL_defgv */
 

+    /* First of all, handle overload magic of the rightmost argument */

     if (SvAMAGIC(e)) {
        SV * const tmpsv = amagic_call(d, e, smart_amg, 0);
        if (tmpsv) {
     if (SvAMAGIC(e)) {
        SV * const tmpsv = amagic_call(d, e, smart_amg, 0);
        if (tmpsv) {


@@ -4371,9 +4372,25 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            RETURN;
        }
     }
            RETURN;
        }
     }

-    /* ~~ X..Y TODO */

     /* ~~ scalar */
     /* ~~ scalar */

-    else if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
+    /* See if there is overload magic on left */
+    else if (object_on_left && SvAMAGIC(d)) {
+       SV *tmpsv;
+       PUSHs(d); PUSHs(e);
+       PUTBACK;
+       tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
+       if (tmpsv) {
+           SPAGAIN;
+           (void)POPs;
+           SETs(tmpsv);
+           RETURN;
+       }
+       SP -= 2;
+       goto sm_any_scalar;
+    }
+    else
+  sm_any_scalar:
+    if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {

        /* numeric comparison */
        PUSHs(d); PUSHs(e);
        PUTBACK;
        /* numeric comparison */
        PUSHs(d); PUSHs(e);
        PUTBACK;

diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t
index 5dfebbd..8c48768 100644 (file)
--- a/t/op/smartmatch.t
+++ b/t/op/smartmatch.t
@@ -37,7 +37,15 @@ tie my %tied_hash, 'Tie::StdHash';
 {
     package Test::Object::WithOverload;
     sub new { bless { key => 'magic' } }
 {
     package Test::Object::WithOverload;
     sub new { bless { key => 'magic' } }

-    use overload '~~' => sub { my %hash = %{ $_[0] }; $_[1] eq $hash{key} };
+    use overload '~~' => sub {
+       my %hash = %{ $_[0] };
+       if ($_[2]) { # arguments reversed ?
+           return $_[1] eq reverse $hash{key};
+       }
+       else {
+           return $_[1] eq $hash{key};
+       }
+    };

     use overload '""' => sub { "stringified" };
     use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
 }
     use overload '""' => sub { "stringified" };
     use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
 }


@@ -158,15 +166,15 @@ __DATA__
 
 # Any ~~ object overloaded
 !      \&fatal         $ov_obj
 
 # Any ~~ object overloaded
 !      \&fatal         $ov_obj

-       'magic'         $ov_obj
-!      'not magic'     $ov_obj
+       'cigam'         $ov_obj
+!      'cigam on'      $ov_obj

 !      $obj            $ov_obj
 !      undef           $ov_obj
 
 # regular object
 @      $obj            $obj
 @      $ov_obj         $obj
 !      $obj            $ov_obj
 !      undef           $ov_obj
 
 # regular object
 @      $obj            $obj
 @      $ov_obj         $obj

-@      \&fatal         $obj
+=@     \&fatal         $obj

 @      \&FALSE         $obj
 @      \&foo           $obj
 @      sub { 1 }       $obj
 @      \&FALSE         $obj
 @      \&foo           $obj
 @      sub { 1 }       $obj


@@ -183,7 +191,9 @@ __DATA__
 # object (overloaded or not) ~~ Any
        $obj            qr/NoOverload/
        $ov_obj         qr/^stringified$/
 # object (overloaded or not) ~~ Any
        $obj            qr/NoOverload/
        $ov_obj         qr/^stringified$/

-       $ov_obj         "stringified"
+       "$ov_obj"       "stringified"
+       $ov_obj         'magic'
+!      $ov_obj         'not magic'

 
 # ~~ Coderef
        sub{0}          sub { ref $_[0] eq "CODE" }
 
 # ~~ Coderef
        sub{0}          sub { ref $_[0] eq "CODE" }