add ~~x and x~~ overloads, deprecating ~~ overloads tonyc/smartmatch
authorTony Cook <tony@develop-help.com>
Tue, 24 Nov 2015 00:29:34 +0000 (11:29 +1100)
committerTony Cook <tony@develop-help.com>
Tue, 24 Nov 2015 00:29:57 +0000 (11:29 +1100)
gv.c
lib/overload.pm
lib/overload.t
lib/overload/numbers.pm
overload.h
overload.inc
pod/perldiag.pod
pp_ctl.c
regen/overload.pl
t/op/smartmatch.t

diff --git a/gv.c b/gv.c
index 0283b2d..e6b7c0a 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -3001,7 +3001,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
   dVAR;
   MAGIC *mg;
   CV *cv=NULL;
-  CV **cvp=NULL, **ocvp=NULL;
+  CV **cvp=NULL; /* right (and at least initially) left side over loading table */
+  CV **ocvp=NULL; /* left side overloading table */
   AMT *amtp=NULL, *oamtp=NULL;
   int off = 0, off1, lr = 0, notfound = 0;
   int postpr = 0, force_cpy = 0;
@@ -3152,6 +3153,15 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
               && (cv = cvp[off=method])) { /* Method for right
                                             * argument found */
       lr=1;
+    } else if ((method == smartleft_amg
+                && ocvp
+                && (cv = ocvp[smart_amg]))
+               ||
+               (method == smartright_amg
+                && cvp
+                && (cv = cvp[smart_amg]))) {
+        lr = method == smartleft_amg ? -1 : 1;
+        off = smart_amg;
     } else if (((cvp && amtp->fallback > AMGfallNEVER)
                 || (ocvp && oamtp->fallback > AMGfallNEVER))
               && !(flags & AMGf_unary)) {
index 4a1912c..b5d2ccf 100644 (file)
@@ -1,6 +1,6 @@
 package overload;
 
-our $VERSION = '1.26';
+our $VERSION = '1.28';
 
 %ops = (
     with_assign         => "+ - * / % ** << >> x .",
@@ -16,7 +16,7 @@ our $VERSION = '1.26';
     iterators           => '<>',
     filetest            => "-X",
     dereferencing       => '${} @{} %{} &{} *{}',
-    matching            => '~~',
+    matching            => '~~ x~~ ~~x',
     special             => 'nomethod fallback =',
 );
 
@@ -41,6 +41,8 @@ sub OVERLOAD {
     } else {
       warnings::warnif("overload arg '$_' is invalid")
         unless $ops_seen{$_};
+      warnings::warnif("deprecated", "Overloading ~~ is deprecated, use ~~x or x~~ overloading")
+        if $_ eq "~~";
       $sub = $arg{$_};
       if (not ref $sub) {
        $ {$package . "::(" . $_} = $sub;
index 6f49e5e..2e7504c 100644 (file)
@@ -1835,7 +1835,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
        $e = '"abc" ~~ (%s)';
        $subs{'~~'} = $e;
-       push @tests, [ qr/abc/, $e, '(~~)', '(NM:~~)', [ 1, 1, 0 ], 0 ];
+       push @tests, [ qr/abc/, $e, '(~~)', '(NM:~~x)', [ 1, 1, 0 ], 0 ];
 
        $subs{'-X'} = 'do { my $f = (%s);'
                    . '$_[1] eq "r" ? (-r ($f)) :'
@@ -1916,17 +1916,21 @@ foreach my $op (qw(<=> == != < <= > >=)) {
        '""'  => sub { $funcs .= '("")'; "$_[0][0]"   },
        "nomethod" => sub {
                        $funcs .= "(NM:$_[3])";
+                        my $op = $_[3];
+                        $op =~ s/^(?:~~x|x~~)$/~~/;
                        my $e = defined($_[1])
                                ? $_[3] eq 'atan2'
                                    ? $_[2]
                                       ? "atan2(\$_[1],\$_[0][0])"
                                       : "atan2(\$_[0][0],\$_[1])"
                                    : $_[2]
-                                       ? "\$_[1] $_[3] \$_[0][0]"
-                                       : "\$_[0][0] $_[3] \$_[1]"
+                                       ? "\$_[1] $op \$_[0][0]"
+                                       : "\$_[0][0] $op \$_[1]"
                                : $_[3] eq 'neg'
                                    ? "-\$_[0][0]"
-                                   : "$_[3](\$_[0][0])";
+                                   : $_[3] eq "~~x" || $_[3] eq "x~~"
+                                      ? "\$_[1] ~~ \$_[0][0]"
+                                      : "$_[3](\$_[0][0])";
                        my $r;
                        no warnings 'experimental::smartmatch';
                        if ($use_int) {
index ccea9e1..b5dc8f3 100644 (file)
@@ -89,6 +89,8 @@ our @names = qw#
     (~~
     (-X
     (qr
+    (x~~
+    (~~x
 #;
 
 our @enums = qw#
@@ -167,6 +169,8 @@ our @enums = qw#
     smart
     ftest
     regexp
+    smartleft
+    smartright
 #;
 
 { my $i = 0; our %names = map { $_ => $i++ } @names }
index 50e7660..308a7d6 100644 (file)
@@ -89,6 +89,8 @@ enum {
     smart_amg,         /* 0x48 ~~       */
     ftest_amg,         /* 0x49 -X       */
     regexp_amg,                /* 0x4a qr       */
+    smartleft_amg,     /* 0x4b x~~      */
+    smartright_amg,    /* 0x4c ~~x      */
     max_amg_code
     /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
 };
index 2383ef2..a337bf8 100644 (file)
@@ -91,7 +91,9 @@ static const U8 PL_AMG_namelens[NofAMmeth] = {
     3,
     3,
     3,
-    3
+    3,
+    4,
+    4
 };
 
 static const char * const PL_AMG_names[NofAMmeth] = {
@@ -174,7 +176,9 @@ static const char * const PL_AMG_names[NofAMmeth] = {
     "(.=",             /* concat_ass */
     "(~~",             /* smart      */
     "(-X",             /* ftest      */
-    "(qr"
+    "(qr",             /* regexp     */
+    "(x~~",            /* smartleft  */
+    "(~~x"
 };
 
 /* ex: set ro: */
index 0c58c79..2fd5f3b 100644 (file)
@@ -4252,6 +4252,12 @@ L<overload>.
 (F) An object with a C<qr> overload was used as part of a match, but the
 overloaded operation didn't return a compiled regexp.  See L<overload>.
 
+=item Overloading ~~ is deprecated, use ~~x or x~~ overloading
+
+(W deprecated) The C<~~> overload has been split into separate
+overloadings for the overloaded value on the left, C<x~~>), or on the
+right, C<~~x>.  The older C<~~> overload is now deprecated.
+
 =item %s package attribute may clash with future reserved word: %s
 
 (W reserved) A lowercase attribute name was used that had a
index b603529..19374b7 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4461,9 +4461,9 @@ PP(pp_smartmatch)
     if (SvAMAGIC(e)) {
        SV * tmpsv;
        DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
-       DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
+       DEBUG_M(Perl_deb(aTHX_ "        attempting ~~x overload\n"));
 
-       tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
+        tmpsv = amagic_call(d, e, smartright_amg, AMGf_noleft);
        if (tmpsv) {
            SPAGAIN;
            (void)POPs;
@@ -4528,9 +4528,9 @@ PP(pp_smartmatch)
     if (SvAMAGIC(d)) {
        SV * tmpsv;
        DEBUG_M(Perl_deb(aTHX_ "    applying rule over-Any\n"));
-       DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
+       DEBUG_M(Perl_deb(aTHX_ "        attempting x~~ overload\n"));
 
-       tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
+       tmpsv = amagic_call(d, e, smartleft_amg, AMGf_noright);
        if (tmpsv) {
            SPAGAIN;
            PUSHs(boolSV(SvTRUE(tmpsv)));
index c95ab2d..4269473 100644 (file)
@@ -205,3 +205,5 @@ concat_ass  (.=
 smart          (~~
 ftest           (-X
 regexp          (qr
+smartleft      (x~~
+smartright     (~~x
index de2a0d5..d48dad7 100644 (file)
@@ -9,6 +9,7 @@ use strict;
 use warnings;
 no warnings 'uninitialized';
 no warnings 'experimental::smartmatch';
+no warnings 'syntax';
 
 ++$|;
 
@@ -58,8 +59,24 @@ tie my %tied_hash, 'Tie::StdHash';
     use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
 }
 
+{
+    package Test::Object::WithNewOverload;
+    sub new { bless { key => ($_[1] // 'magic') } }
+    use overload '~~x' => sub {
+       my %hash = %{ $_[0] };
+        return $hash{key} eq $_[1];
+    };
+    use overload 'x~~' => sub {
+       my %hash = %{ $_[0] };
+        return $hash{key} ne $_[1];
+    };
+    use overload '""' => sub { "stringified" };
+    use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
+}
+
 our $ov_obj = Test::Object::WithOverload->new;
 our $ov_obj_2 = Test::Object::WithOverload->new("object");
+our $ov_obj_3 = Test::Object::WithNewOverload->new;
 our $obj = Test::Object::NoOverload->new;
 our $str_obj = Test::Object::StringOverload->new;
 
@@ -187,11 +204,22 @@ sub NOT_DEF() { undef }
         use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
         sub new { bless +{} };
     };
+    package Test::Object::StrangeOverload2 {
+        use overload '~~x' => sub { $_[1] };
+        use overload 'x~~' => sub { $_[1] };
+        use overload '""' => sub { "stringified" };
+        use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
+        sub new { bless +{} };
+    };
     my $ov_strange = Test::Object::StrangeOverload->new;
-    is(42 ~~ $ov_strange, "1", "overload true return is a yes");
-    is("0" ~~ $ov_strange, "", "overload false return is a no");
-    is($ov_strange ~~ 44, "1", "reversed overload true return is a yes");
-    is($ov_strange ~~ "0", "", "reversed overload false return is a no");
+    my $ov_strange2 = Test::Object::StrangeOverload2->new;
+    {
+        no warnings 'deprecated';
+        is(42 ~~ $ov_strange, "1", "overload true return is a yes");
+        is("0" ~~ $ov_strange, "", "overload false return is a no");
+        is($ov_strange ~~ 44, "1", "reversed overload true return is a yes");
+        is($ov_strange ~~ "0", "", "reversed overload false return is a no");
+    }
 }
 
 done_testing();
@@ -589,3 +617,8 @@ __DATA__
 !      !1              undef
 !      \&foo           undef
 !      sub { }         undef
+
+       "magic"         $ov_obj_3
+!      $ov_obj_3       "magic"
+
+