Bug #64542 for Perl6-Junction: Make Perl6::Junction work with smart match

Thu Jan 06 10:39:10 2011 CALDRIN [...] cpan.org - Ticket created

Subject:

Make Perl6::Junction work with smart match

Currently, Perl6::Junction does not work with the smart match operator ~~. Therefore the following dies: use 5.010; use Perl6::Junction qw/any/; if (any('a','A') ~~ 'b') {say 'broken'} else {say 'fixed'} This brings Operation "~~": no method found, left argument in overloaded package Perl6::Junction::Any, right argument has no overloaded magic at - line 3. Furthermore, given/when uses smart match and therefore the following doesn't work either: use Perl6::Junction qw/any/; use 5.010; my $x = 'a'; given ($x){ when(any('b','c')){say 'broken';} when(any('a','A')){say 'Fixed';} } This prints "broken". Since smart match and given/when is quite common, I think it's important to cover it in Perl6::Junction.

Thu Jan 06 10:52:07 2011 cpan [...] fireartist.com - Correspondence added

Hi, Any patch (contining test) to provide this will be applied and released to cpan. I won't be spending time further developing this myself. Cheers,

Thu Jan 06 10:52:08 2011 The RT System itself - Status changed from 'new' to 'open'

Thu Jan 06 10:52:08 2011 cpan [...] fireartist.com - Status changed from 'open' to 'stalled'

Wed Aug 29 09:20:41 2012 rjbs [...] cpan.org - Correspondence added

On 2011-01-06 10:52:07, CFRANKS wrote: Show quoted text

> Hi, > Any patch (contining test) to provide this will be applied and released > to cpan. > I won't be spending time further developing this myself. > Cheers,

I have written patches with tests. They are available at https://github.com/rjbs/Perl6-Junction I have also attached the results of git format-patch -- rjbs

Subject:

0003-rewrite-tests-to-use-sub-routine-smartmatchers.patch

From 7b193db9c6d2467e9251ed729097cf73c30153e1 Mon Sep 17 00:00:00 2001 From: Ricardo Signes <rjbs@cpan.org> Date: Wed, 29 Aug 2012 09:04:39 -0400 Subject: [PATCH 3/3] rewrite ~~ tests to use sub routine smartmatchers There's currently discussion on p5p about disallowing simple scalars on the right hand side of a smart match, so better to avoid testing for it now. --- t/smartmatch.t | 44 ++++++++++++++++++++++++-------------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/t/smartmatch.t b/t/smartmatch.t index 204b642..0778774 100644 --- a/t/smartmatch.t +++ b/t/smartmatch.t @@ -6,23 +6,27 @@ plan tests => 16; use Perl6::Junction qw(all any none one); -ok(! (5 ~~ all(1,2,5)), "5 !~~ all(1,2,5)" ); -ok( (5 ~~ any(1,2,5)), "5 ~~ any(1,2,5)" ); -ok(! (5 ~~ none(1,2,5)), "5 !~~ none(1,2,5)" ); -ok( (5 ~~ one(1,2,5)), "5 ~~ one(1,2,5)" ); - -ok( (5 ~~ all(5,5,5)), "5 ~~ all(5,5,5)" ); -ok( (5 ~~ any(5,5,5)), "5 ~~ any(5,5,5)" ); -ok(! (5 ~~ none(5,5,5)), "5 !~~ none(5,5,5)" ); -ok(! (5 ~~ one(5,5,5)), "5 !~~ one(5,5,5)" ); - -ok(! (3 ~~ all(1,2,5)), "3 !~~ all(1,2,5)" ); -ok(! (3 ~~ any(1,2,5)), "3 !~~ any(1,2,5)" ); -ok( (3 ~~ none(1,2,5)), "3 ~~ none(1,2,5)" ); -ok(! (3 ~~ one(1,2,5)), "3 !~~ one(1,2,5)" ); - - -ok(! ( all(1,2,5) ~~ 5), " all(1,2,5) !~~ 5" ); -ok( ( any(1,2,5) ~~ 5), " any(1,2,5) ~~ 5" ); -ok(! ( none(1,2,5) ~~ 5), "none(1,2,5) !~~ 5" ); -ok( ( one(1,2,5) ~~ 5), " one(1,2,5) ~~ 5" ); +my $is_1 = sub { $_[0] == 1 }; +my $is_2 = sub { $_[0] == 2 }; +my $is_5 = sub { $_[0] == 5 }; + +ok(! (5 ~~ all($is_1,$is_2,$is_5)), '5 !~~ all($is_1,$is_2,$is_5)' ); +ok( (5 ~~ any($is_1,$is_2,$is_5)), '5 ~~ any($is_1,$is_2,$is_5)' ); +ok(! (5 ~~ none($is_1,$is_2,$is_5)), '5 !~~ none($is_1,$is_2,$is_5)' ); +ok( (5 ~~ one($is_1,$is_2,$is_5)), '5 ~~ one($is_1,$is_2,$is_5)' ); + +ok( (5 ~~ all($is_5,$is_5,$is_5)), '5 ~~ all($is_5,$is_5,$is_5)' ); +ok( (5 ~~ any($is_5,$is_5,$is_5)), '5 ~~ any($is_5,$is_5,$is_5)' ); +ok(! (5 ~~ none($is_5,$is_5,$is_5)), '5 !~~ none($is_5,$is_5,$is_5)' ); +ok(! (5 ~~ one($is_5,$is_5,$is_5)), '5 !~~ one($is_5,$is_5,$is_5)' ); + +ok(! (3 ~~ all($is_1,$is_2,$is_5)), '3 !~~ all($is_1,$is_2,$is_5)' ); +ok(! (3 ~~ any($is_1,$is_2,$is_5)), '3 !~~ any($is_1,$is_2,$is_5)' ); +ok( (3 ~~ none($is_1,$is_2,$is_5)), '3 ~~ none($is_1,$is_2,$is_5)' ); +ok(! (3 ~~ one($is_1,$is_2,$is_5)), '3 !~~ one($is_1,$is_2,$is_5)' ); + + +ok(! ( all(1,2,5) ~~ $is_5), ' all(1,2,5) !~~ $is_5' ); +ok( ( any(1,2,5) ~~ $is_5), ' any(1,2,5) ~~ $is_5' ); +ok(! ( none(1,2,5) ~~ $is_5), 'none(1,2,5) !~~ $is_5' ); +ok( ( one(1,2,5) ~~ $is_5), ' one(1,2,5) ~~ $is_5' ); -- 1.7.9.6 (Apple Git-31.1)

Subject:

0001-add-untested-code-for-support.patch

From 92ac9118379106d28d16ddc86d11ae252ee34a86 Mon Sep 17 00:00:00 2001 From: Ricardo Signes <rjbs@cpan.org> Date: Tue, 26 Jun 2012 11:06:40 -0400 Subject: [PATCH 1/3] add untested code for ~~ support --- lib/Perl6/Junction.pm | 4 ++++ lib/Perl6/Junction/All.pm | 24 ++++++++++++++++++++++++ lib/Perl6/Junction/Any.pm | 24 ++++++++++++++++++++++++ lib/Perl6/Junction/Base.pm | 2 ++ lib/Perl6/Junction/None.pm | 24 ++++++++++++++++++++++++ lib/Perl6/Junction/One.pm | 33 +++++++++++++++++++++++++++++++++ 6 files changed, 111 insertions(+) diff --git a/lib/Perl6/Junction.pm b/lib/Perl6/Junction.pm index c306d71..9eebfa4 100644 --- a/lib/Perl6/Junction.pm +++ b/lib/Perl6/Junction.pm @@ -91,6 +91,7 @@ Returns an object which overloads the following operators: '<', '<=', '>', '>=', '==', '!=', 'lt', 'le', 'gt', 'ge', 'eq', 'ne', + '~~' Returns true only if B<all> arguments test true according to the operator used. @@ -101,6 +102,7 @@ Returns an object which overloads the following operators: '<', '<=', '>', '>=', '==', '!=', 'lt', 'le', 'gt', 'ge', 'eq', 'ne', + '~~' Returns true if B<any> argument tests true according to the operator used. @@ -110,6 +112,7 @@ Returns an object which overloads the following operators: '<', '<=', '>', '>=', '==', '!=', 'lt', 'le', 'gt', 'ge', 'eq', 'ne', + '~~' Returns true only if B<no> argument tests true according to the operator used. @@ -120,6 +123,7 @@ Returns an object which overloads the following operators: '<', '<=', '>', '>=', '==', '!=', 'lt', 'le', 'gt', 'ge', 'eq', 'ne', + '~~' Returns true only if B<one and only one> argument tests true according to the operator used. diff --git a/lib/Perl6/Junction/All.pm b/lib/Perl6/Junction/All.pm index 966ad4b..e7e70fe 100644 --- a/lib/Perl6/Junction/All.pm +++ b/lib/Perl6/Junction/All.pm @@ -4,6 +4,30 @@ our $VERSION = '1.40000'; use base 'Perl6::Junction::Base'; +BEGIN { + if ($] >= 5.010001) { + eval q< +sub match { + my ( $self, $other, $is_rhs ) = @_; + + if ($is_rhs) { + for (@$self) { + return unless $other ~~ $_; + } + + return 1; + } + + for (@$self) { + return unless $_ ~~ $other; + } + + return 1; +} +> + } +} + sub num_eq { return regex_eq(@_) if ref( $_[1] ) eq 'Regexp'; diff --git a/lib/Perl6/Junction/Any.pm b/lib/Perl6/Junction/Any.pm index 909f9ac..8a7044b 100644 --- a/lib/Perl6/Junction/Any.pm +++ b/lib/Perl6/Junction/Any.pm @@ -4,6 +4,30 @@ our $VERSION = '1.40000'; use base 'Perl6::Junction::Base'; +BEGIN { + if ($] >= 5.010001) { + eval q< +sub match { + my ( $self, $other, $is_rhs ) = @_; + + if ($is_rhs) { + for (@$self) { + return 1 if $other ~~ $_; + } + + return; + } + + for (@$self) { + return 1 if $_ ~~ $other; + } + + return; +} +> + } +} + sub num_eq { return regex_eq(@_) if ref( $_[1] ) eq 'Regexp'; diff --git a/lib/Perl6/Junction/Base.pm b/lib/Perl6/Junction/Base.pm index 9b7eb99..5a679de 100644 --- a/lib/Perl6/Junction/Base.pm +++ b/lib/Perl6/Junction/Base.pm @@ -19,6 +19,8 @@ use overload( '""' => sub {shift}, ); +use if ($] >= 5.010001), overload => '~~' => 'match'; + sub new { my ( $class, @param ) = @_; return bless \@param, $class; diff --git a/lib/Perl6/Junction/None.pm b/lib/Perl6/Junction/None.pm index 526dd9b..7018d55 100644 --- a/lib/Perl6/Junction/None.pm +++ b/lib/Perl6/Junction/None.pm @@ -4,6 +4,30 @@ our $VERSION = '1.40000'; use base 'Perl6::Junction::Base'; +BEGIN { + if ($] >= 5.010001) { + eval q< +sub match { + my ( $self, $other, $is_rhs ) = @_; + + if ($is_rhs) { + for (@$self) { + return if $other ~~ $_; + } + + return 1; + } + + for (@$self) { + return if $_ ~~ $other; + } + + return 1; +} +> + } +} + sub num_eq { return regex_eq(@_) if ref( $_[1] ) eq 'Regexp'; diff --git a/lib/Perl6/Junction/One.pm b/lib/Perl6/Junction/One.pm index d83d4d7..a90f3b8 100644 --- a/lib/Perl6/Junction/One.pm +++ b/lib/Perl6/Junction/One.pm @@ -4,6 +4,39 @@ our $VERSION = '1.40000'; use base 'Perl6::Junction::Base'; +BEGIN { + if ($] >= 5.010001) { + eval q< +sub match { + my ( $self, $other, $is_rhs ) = @_; + + my $count = 0; + + if ($is_rhs) { + + for (@$self) { + if ($other ~~ $_) { + return if $count; + $count = 1; + } + } + + return($count == 1); + } + + for (@$self) { + if ($_ ~~ $other) { + return if $count; + $count = 1; + } + } + + return($count == 1); +} +> + } +} + sub num_eq { return regex_eq(@_) if ref( $_[1] ) eq 'Regexp'; -- 1.7.9.6 (Apple Git-31.1)

Subject:

0002-some-tests-not-enough-for-support.patch

From 670731828730d47fc132d41667f88c3a7fe7f3ef Mon Sep 17 00:00:00 2001 From: Ricardo Signes <rjbs@cpan.org> Date: Tue, 26 Jun 2012 11:19:11 -0400 Subject: [PATCH 2/3] some tests (not enough) for ~~ support --- t/smartmatch.t | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 t/smartmatch.t diff --git a/t/smartmatch.t b/t/smartmatch.t new file mode 100644 index 0000000..204b642 --- /dev/null +++ b/t/smartmatch.t @@ -0,0 +1,28 @@ +use strict; +use Test::More; +plan skip_all => "~~ support requires v5.10.1" unless $] >= 5.010001; + +plan tests => 16; + +use Perl6::Junction qw(all any none one); + +ok(! (5 ~~ all(1,2,5)), "5 !~~ all(1,2,5)" ); +ok( (5 ~~ any(1,2,5)), "5 ~~ any(1,2,5)" ); +ok(! (5 ~~ none(1,2,5)), "5 !~~ none(1,2,5)" ); +ok( (5 ~~ one(1,2,5)), "5 ~~ one(1,2,5)" ); + +ok( (5 ~~ all(5,5,5)), "5 ~~ all(5,5,5)" ); +ok( (5 ~~ any(5,5,5)), "5 ~~ any(5,5,5)" ); +ok(! (5 ~~ none(5,5,5)), "5 !~~ none(5,5,5)" ); +ok(! (5 ~~ one(5,5,5)), "5 !~~ one(5,5,5)" ); + +ok(! (3 ~~ all(1,2,5)), "3 !~~ all(1,2,5)" ); +ok(! (3 ~~ any(1,2,5)), "3 !~~ any(1,2,5)" ); +ok( (3 ~~ none(1,2,5)), "3 ~~ none(1,2,5)" ); +ok(! (3 ~~ one(1,2,5)), "3 !~~ one(1,2,5)" ); + + +ok(! ( all(1,2,5) ~~ 5), " all(1,2,5) !~~ 5" ); +ok( ( any(1,2,5) ~~ 5), " any(1,2,5) ~~ 5" ); +ok(! ( none(1,2,5) ~~ 5), "none(1,2,5) !~~ 5" ); +ok( ( one(1,2,5) ~~ 5), " one(1,2,5) ~~ 5" ); -- 1.7.9.6 (Apple Git-31.1)

Wed Aug 29 09:20:42 2012 The RT System itself - Status changed from 'stalled' to 'open'

Tue Sep 11 15:57:42 2012 cpan [...] fireartist.com - Correspondence added

Thanks! - your patch has been pulled in, and uploaded to pause.

Tue Sep 11 15:57:43 2012 cpan [...] fireartist.com - Status changed from 'open' to 'resolved'