From: Dave Rolsky <autarch@urth.org>
Date: Mon, 27 Sep 2010 00:09:21 +0000 (-0500)
Subject: Allow overloading on arguments to native trait methods
X-Git-Tag: 1.15~62
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=88e88a7b2cfdf5d777f502a34cfbf5ba69809c58;p=gitmo%2FMoose.git

Allow overloading on arguments to native trait methods
---

diff --git a/Makefile.PL b/Makefile.PL
index 228f9fe..06d21e5 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -18,6 +18,7 @@ requires 'Class::MOP'                  => '1.05';
 requires 'Data::OptList'               => '0';
 requires 'List::MoreUtils'             => '0.12';
 requires 'Package::DeprecationManager' => '0.04';
+requires 'Params::Util'                => '0';
 requires 'Scalar::Util'                => '1.19';
 requires 'Sub::Exporter'               => '0.980';
 requires 'Sub::Name'                   => '0';
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm
index 7323bb7..88c1f44 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use List::Util ();
+use Params::Util ();
 
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
@@ -30,7 +31,7 @@ sub _inline_check_arguments {
 
     return $self->_inline_throw_error(
         q{'The argument passed to first must be a code reference'})
-        . q{if $_[0] && ( ref $_[0] || q{} ) ne 'CODE';};
+        . q{ unless Params::Util::_CODELIKE( $_[0] );};
 }
 
 sub _return_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm
index e6ac60d..dd7c7db 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm
@@ -3,6 +3,8 @@ package Moose::Meta::Method::Accessor::Native::Array::grep;
 use strict;
 use warnings;
 
+use Params::Util ();
+
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -28,7 +30,7 @@ sub _inline_check_arguments {
 
     return $self->_inline_throw_error(
         q{'The argument passed to grep must be a code reference'})
-        . q{if $_[0] && ( ref $_[0] || q{} ) ne 'CODE';};
+        . q{ unless Params::Util::_CODELIKE( $_[0] );};
 }
 
 sub _return_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm
index bbaad84..26d488f 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm
@@ -3,6 +3,8 @@ package Moose::Meta::Method::Accessor::Native::Array::join;
 use strict;
 use warnings;
 
+use Moose::Util ();
+
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -28,7 +30,7 @@ sub _inline_check_arguments {
 
     return $self->_inline_throw_error(
         q{'The argument passed to join must be a string'})
-        . ' unless defined $_[0] && ! ref $_[0];';
+        . ' unless Moose::Util::_STRINGLIKE( $_[0] );';
 }
 
 sub _return_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm
index 3013fe0..ad25551 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm
@@ -3,6 +3,8 @@ package Moose::Meta::Method::Accessor::Native::Array::map;
 use strict;
 use warnings;
 
+use Params::Util ();
+
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -28,7 +30,7 @@ sub _inline_check_arguments {
 
     return $self->_inline_throw_error(
         q{'The argument passed to map must be a code reference'})
-        . q{if $_[0] && ( ref $_[0] || q{} ) ne 'CODE';};
+        . q{ unless Params::Util::_CODELIKE( $_[0] );};
 }
 
 sub _return_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm
index b905564..f5cea6d 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm
@@ -3,7 +3,8 @@ package Moose::Meta::Method::Accessor::Native::Array::natatime;
 use strict;
 use warnings;
 
-use List::MoreUtils;
+use List::MoreUtils ();
+use Params::Util ();
 
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
@@ -34,7 +35,7 @@ sub _inline_check_arguments {
         . ' unless defined $_[0] && $_[0] =~ /^\\d+$/;' . "\n"
         . $self->_inline_throw_error(
         q{'The second argument passed to natatime must be a code reference'})
-        . q{ if defined $_[1] && ( ref $_[1] || q{} ) ne 'CODE';};
+        . q{ if @_ == 2 && ! Params::Util::_CODELIKE( $_[1] );};
 }
 
 sub _inline_return_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm
index 8b5e72a..797b6b6 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use List::Util ();
+use Params::Util ();
 
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
@@ -30,7 +31,7 @@ sub _inline_check_arguments {
 
     return $self->_inline_throw_error(
         q{'The argument passed to reduce must be a code reference'})
-        . q{if $_[0] && ( ref $_[0] || q{} ) ne 'CODE';};
+        . q{ unless Params::Util::_CODELIKE( $_[0] );};
 }
 
 sub _return_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm
index 57da995..9f18cb7 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm
@@ -3,6 +3,8 @@ package Moose::Meta::Method::Accessor::Native::Array::sort;
 use strict;
 use warnings;
 
+use Params::Util ();
+
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -25,7 +27,7 @@ sub _inline_check_arguments {
 
     return $self->_inline_throw_error(
         q{'The argument passed to sort must be a code reference'})
-        . q{if $_[0] && ( ref $_[0] || q{} ) ne 'CODE';};
+        . q{ if @_ && ! Params::Util::_CODELIKE( $_[0] );};
 }
 
 sub _return_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm
index 41a895f..7c8c40e 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm
@@ -3,6 +3,8 @@ package Moose::Meta::Method::Accessor::Native::Array::sort_in_place;
 use strict;
 use warnings;
 
+use Params::Util ();
+
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -25,7 +27,7 @@ sub _inline_check_arguments {
 
     return $self->_inline_throw_error(
         q{'The argument passed to sort_in_place must be a code reference'})
-        . q{if $_[0] && ( ref $_[0] || q{} ) ne 'CODE';};
+        . q{ if @_ && ! Params::Util::_CODELIKE( $_[0] );};
 }
 
 sub _adds_members { 0 }
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/match.pm b/lib/Moose/Meta/Method/Accessor/Native/String/match.pm
index 23492e7..4dc64bb 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/match.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/match.pm
@@ -3,6 +3,9 @@ package Moose::Meta::Method::Accessor::Native::String::match;
 use strict;
 use warnings;
 
+use Moose::Util ();
+use Params::Util ();
+
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -28,7 +31,7 @@ sub _inline_check_arguments {
 
     return $self->_inline_throw_error(
         q{'The argument passed to match must be a string or regexp reference'}
-    ) . q{ unless ! ref $_[0] || ref $_[0] eq 'Regexp';};
+    ) . q{ unless Moose::Util::_STRINGLIKE( $_[0] ) || Params::Util::_REGEX( $_[0] );};
 }
 
 sub _return_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm
index 5650fc0..f360080 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm
@@ -3,6 +3,9 @@ package Moose::Meta::Method::Accessor::Native::String::replace;
 use strict;
 use warnings;
 
+use Moose::Util ();
+use Params::Util ();
+
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -30,10 +33,10 @@ sub _inline_check_arguments {
     return $self->_inline_throw_error(
         q{'The first argument passed to replace must be a string or regexp reference'}
         )
-        . q{ unless ! ref $_[0] || ref $_[0] eq 'Regexp';} . "\n"
+        . q{ unless Moose::Util::_STRINGLIKE( $_[0] ) || Params::Util::_REGEX( $_[0] );}
         . $self->_inline_throw_error(
         q{'The second argument passed to replace must be a string or code reference'}
-        ) . q{ unless ! ref $_[1] || ref $_[1] eq 'CODE';};
+        ) . q{ unless Moose::Util::_STRINGLIKE( $_[1] ) || Params::Util::_CODELIKE( $_[1] );};
 }
 
 sub _potential_value {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm
index 9f5d8c8..4a48f1f 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm
@@ -3,6 +3,8 @@ package Moose::Meta::Method::Accessor::Native::String::substr;
 use strict;
 use warnings;
 
+use Moose::Util ();
+
 our $VERSION = '1.14';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -86,17 +88,17 @@ sub _inline_check_arguments {
     my $code
         = $self->_inline_throw_error(
         q{'The first argument passed to substr must be an integer'})
-        . q{ if ref $offset || $offset !~ /^-?\\d+$/;} . "\n"
+        . q{ unless $offset =~ /^-?\\d+$/;} . "\n"
         . $self->_inline_throw_error(
-        q{'The second argument passed to substr must be a positive integer'})
-        . q{ if ref $length || $offset !~ /^-?\\d+$/;};
+        q{'The second argument passed to substr must be an integer'})
+        . q{ unless $length =~ /^-?\\d+$/;};
 
     if ($for_writer) {
         $code
             .= "\n"
             . $self->_inline_throw_error(
             q{'The third argument passed to substr must be a string'})
-            . q{ unless defined $replacement && ! ref $replacement;};
+            . q{ unless Moose::Util::_STRINGLIKE($replacement);};
     }
 
     return $code;
diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm
index 638e40e..5896f41 100644
--- a/lib/Moose/Util.pm
+++ b/lib/Moose/Util.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use Data::OptList;
+use Params::Util qw( _STRING );
 use Sub::Exporter;
 use Scalar::Util 'blessed';
 use Class::MOP   0.60;
@@ -285,6 +286,14 @@ sub meta_class_alias {
     _create_alias('Class', $to, $trait, $from);
 }
 
+# XXX - this should be added to Params::Util
+sub _STRINGLIKE ($) {
+    return _STRING( $_[0] )
+        || ( blessed $_[0]
+        && overload::Method( $_[0], q{""} )
+        && length "$_[0]" );
+}
+
 1;
 
 __END__
diff --git a/t/070_native_traits/010_trait_array.t b/t/070_native_traits/010_trait_array.t
index 58df448..33cd4e5 100644
--- a/t/070_native_traits/010_trait_array.t
+++ b/t/070_native_traits/010_trait_array.t
@@ -95,6 +95,18 @@ use Test::Moose;
 }
 
 {
+    package Overloader;
+
+    use overload
+        '&{}' => sub { ${ $_[0] } },
+        bool  => sub {1};
+
+    sub new {
+        bless \$_[1], $_[0];
+    }
+}
+
+{
     run_tests(build_class);
     run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) );
     run_tests( build_class( trigger => sub { } ) );
@@ -493,6 +505,13 @@ sub run_tests {
         qr/The argument passed to grep must be a code reference/,
             'throws an error when passing a non coderef to grep';
 
+        my $overloader = Overloader->new( sub { $_ < 5 } );
+        is_deeply(
+            [ $obj->grep($overloader) ],
+            [ 2 .. 4 ],
+            'grep works with obj that overload code dereferencing'
+        );
+
         is_deeply(
             [ $obj->grep_curried ],
             [ 2 .. 4 ],
diff --git a/t/070_native_traits/070_trait_string.t b/t/070_native_traits/070_trait_string.t
index f5d4ab7..d3029b7 100644
--- a/t/070_native_traits/070_trait_string.t
+++ b/t/070_native_traits/070_trait_string.t
@@ -234,8 +234,8 @@ sub run_tests {
             'substr throws an error when first argument is not an integer';
 
         throws_ok { $obj->substr( 1, {} ) }
-        qr/The second argument passed to substr must be a positive integer/,
-            'substr throws an error when second argument is not a positive integer';
+        qr/The second argument passed to substr must be an integer/,
+            'substr throws an error when second argument is not an integer';
 
         throws_ok { $obj->substr( 1, 2, {} ) }
         qr/The third argument passed to substr must be a string/,