Commits

Toby Inkster  committed 4189476

more test stuff

  • Participants
  • Parent commits 7701f96

Comments (0)

Files changed (5)

File lib/Scalar/Does.pm

 	$Scalar::Does::VERSION   = '0.001';
 }
 
-use IO::Detect qw( is_filehandle );
-use overload qw();
-use Scalar::Util qw( blessed reftype );
+use Carp             0     qw( confess );
+use IO::Detect       0.001 qw( is_filehandle );
+use overload         0     qw();
+use namespace::clean 0.19  qw();
+use Scalar::Util     1.20  qw( blessed reftype );
+
 use Sub::Exporter -setup => {
-	exports => [qw( does overloads blessed )],
+	exports => [
+		qw( does overloads blessed reftype ),
+		custom => \&_build_custom,
+	],
 	groups  => {
 		default => [qw( does )],
 	},
+	installer => sub {
+		my @subs = grep { !ref } @{ $_[1] };
+		namespace::clean->import( -cleanee => $_[0]{into}, @subs );
+		goto \&Sub::Exporter::default_installer;
+	},
 };
 
 no warnings;
 	IO       => \&is_filehandle,
 	VSTRING  => sub { reftype($_) eq 'VSTRING' or reftype($_) eq 'VSTRING' },
 	Regexp   => sub { reftype($_) eq 'Regexp'  or overloads($_, q[qr]) },
+	q[bool]  => sub { !blessed($_) or !overload::Overloaded($_) or overloads($_, q[bool]) },
+	q[""]    => sub { !ref($_)     or !overload::Overloaded($_) or overloads($_, q[""]) },
+	q[0+]    => sub { !ref($_)     or !overload::Overloaded($_) or overloads($_, q[0+]) },
+	q[<>]    => sub { overloads($_, q[<>])     or is_filehandle($_) },
+	q[~~]    => sub { overloads($_, q[~~])     or not blessed($_) },
 	q[${}]   => 'SCALAR',
 	q[@{}]   => 'ARRAY',
 	q[%{}]   => 'HASH',
 	q[&{}]   => 'CODE',
 	q[*{}]   => 'GLOB',
-	q[bool]  => sub { !blessed($_) or !overload::Overloaded($_) or overloads($_, q[bool]) },
-	q[""]    => sub { !ref($_)     or !overload::Overloaded($_) or overloads($_, q[""]) },
-	q[0+]    => sub { !ref($_)     or !overload::Overloaded($_) or overloads($_, q[0+]) },
-	q[qr]    => sub { reftype($_) eq 'Regexp'  or overloads($_, q[qr]) },
-	q[<>]    => sub { overloads($_, q[<>])     or is_filehandle($_) },
-	q[~~]    => sub { overloads($_, q[~~])     or not blessed($_) },
+	q[qr]    => 'Regexp',
 );
 
 while (my ($k, $v) = each %ROLES)
 	my ($thing, $role) = @_;
 	
 	# curry (kinda)
-	return sub { overloads(shift, $thing) } if @_ < 2;
+	return sub { overloads($_[0], $thing) } if @_==1;
 	
 	goto \&overload::Method;
 }
 	my ($thing, $role) = @_;
 	
 	# curry (kinda)
-	return sub { does(shift, $thing) } if @_ < 2;
+	return sub { does($_[0], $thing) } if @_==1;
+	
+#	use Data::Dumper;
+#	warn Dumper(@_);
 	
 	if (my $test = $ROLES{$role})
 	{
 	return;
 }
 
+use constant MISSING_ROLE_MESSAGE => (
+	"Please supply a '-role' argument when exporting custom functions, died"
+);
+
+sub _build_custom
+{
+	my ($class, $name, $arg) = @_;
+	my $role = $arg->{ -role } or confess MISSING_ROLE_MESSAGE;
+	
+	return sub (;$) {
+		push @_, $role;
+		goto \&does;
+	}
+}
+
 "it does"
 __END__
 
 A check that C<< ref($thing) eq 'ARRAY' >> doesn't allow you to accept an
 object that uses overloading to provide an array-like interface.
 
+=head2 Functions
+
 This module provides a prototype C<< does() >> function which can be used in
 as a standard function, or using a pseudo-infix notation (via smart match).
 
 
 =back
 
+=item C<< overloads($scalar, $role) >>
+
+A function C<overloads> (which just checks overloading) is also available.
+It can be called using the same syntax as C<does>.
+
+=item C<< blessed($scalar) >>, C<< reftype($scalar) >>
+
+For convenience, this module can also re-export these functions from
+L<Scalar::Util>.
+
 =back
 
+=head2 Export
+
+By default, only C<does> is exported. This module uses L<Sub::Exporter>, so
+functions can be renamed:
+
+  use Scalar::Does does => { -as => 'performs_role' };
+
+Scalar::Does also plays some tricks with L<namespace::clean> to ensure that
+any functions it exports to your namespace are cleaned up when you're finished
+with them. This ensures that if you're writing object-oriented code C<does>
+and C<overloads> will not be left hanging around as methods of your classes.
+L<Moose::Object> provides a C<does> method, and you should be able to use
+Scalar::Does without interfering with that.
+
+=head2 Custom Role Checks
+
+  use Scalar::Does
+    custom => { -as => 'does_array', -role => 'ARRAY' },
+    custom => { -as => 'does_hash',  -role => 'HASH'  };
+  
+  does_array($thing);
+  does_hash($thing);
+  $thing ~~does_array;
+  $thing ~~does_hash;
+
 =head1 BUGS
 
 Please report any bugs to
 
 =head1 SEE ALSO
 
-L<Scalar::Util>.
+L<Scalar::Util>, L<Moose::Role>, L<MooseX::Types>.
 
-L<http://perldoc.perl.org/5.10.0/perltodo.html#A-does()-built-in>
+L<http://perldoc.perl.org/5.10.0/perltodo.html#A-does()-built-in>.
 
 =head1 AUTHOR
 
 }
 
 my %tests = (
+	ARRAY => [
+		[],
+		does   => [qw( ARRAY @{} )],
+		doesnt => [qw( HASH %{} )],
+	],
+	HASH => [
+		+{},
+		does   => [qw( HASH %{} )],
+		doesnt => [qw( ARRAY @{} )],
+	],
 	SCALAR => [
 		\"Hello World",
 		does   => [qw( SCALAR ${} )],
-		doesnt => [qw( ARRAY HASH @{} %{} CODE Regexp Foo::Bar UNIVERSAL )]
+		doesnt => [qw( ARRAY HASH @{} %{} CODE Regexp Foo::Bar UNIVERSAL )],
 	],
 	CODE => [
 		sub { 1 },
 		does   => [qw( CODE &{} )],
-		doesnt => [qw( SCALAR @{} UNIVERSAL )]
+		doesnt => [qw( SCALAR @{} UNIVERSAL )],
 	],
 	Blessed_CODE => [
 		bless(sub { 1 } => 'Foo::Bar'),
 		does   => [qw( CODE &{} Foo::Bar UNIVERSAL )],
-		doesnt => [qw( SCALAR @{} Regexp )]
+		doesnt => [qw( SCALAR @{} Regexp )],
 	],
 	Overloaded_Object => [
 		Local::Does::Array->new,
 	STDOUT => [
 		\*STDOUT,
 		does   => [qw( IO <> GLOB *{} )],
-		doesnt => [qw( SCALAR @{} Regexp CODE &{} Foo::Bar UNIVERSAL )]
+		doesnt => [qw( SCALAR @{} Regexp CODE &{} Foo::Bar UNIVERSAL )],
 	],
 	Lvalue => [
 		\(substr($INC[0], 0, 1)),
 		does   => [qw( LVALUE )],
-		doesnt => [qw( SCALAR @{} Regexp CODE &{} Foo::Bar UNIVERSAL IO GLOB )]
+		doesnt => [qw( SCALAR @{} Regexp CODE &{} Foo::Bar UNIVERSAL IO GLOB )],
 	],
 );
 
 	}
 }
 
-done_testing();
+done_testing();

File t/04cleanliness.t

+use Test::More tests => 2;
+
+{
+	package Local::Foo;
+	use Scalar::Does;
+	sub check_does {
+		my ($class, $thing, $role) = @_;
+		does($thing, $role);
+	}
+}
+
+ok(
+	!Local::Foo->can('does'),
+	"does is cleaned up",
+);
+
+ok(
+	Local::Foo->check_does( [] => 'ARRAY' ),
+	"does still works",
+);

File t/05custom.t

+use Test::More tests => 4;
+use Scalar::Does
+	custom => { -role => 'ARRAY', -as => 'does_array' },
+	custom => { -role => 'HASH',  -as => 'does_hash'  };
+
+ok  does_array( +[] );
+ok !does_array( +{} );
+ok !does_hash(  +[] );
+ok  does_hash(  +{} );

File t/06smartmatch.t

+use if $] < 5.010,
+	'Test::More' => (skip_all => "Perl $] is too old");
+
+use Test::More;
+use Scalar::Does
+	qw( does overloads ),
+	custom => { -role => 'ARRAY', -as => 'does_array' },
+	custom => { -role => 'HASH',  -as => 'does_hash'  };
+
+my $A = +[];
+my $H = +{};
+	
+my $curried = does 'ARRAY';
+
+#use B::Deparse ();
+#note( B::Deparse->new->coderef2text($curried) );
+
+ok(
+	ref $curried eq 'CODE',
+	q(ref $curried eq 'CODE'),
+);
+
+ok(
+	$curried->($A),
+	q($curried->($A)),
+);
+ok(
+	not($curried->($H)),
+	q(not($curried->($H))),
+);
+
+ok(
+	$A ~~ $curried,
+	q($A ~~ $curried),
+);
+ok(
+	not($H ~~ $curried),
+	q(not($H ~~ $curried)),
+);
+
+ok(
+	($A ~~does 'ARRAY'),
+	q(($A ~~does 'ARRAY')),
+);
+
+ok(
+	$A ~~does_array,
+	q($A ~~does_array),
+);
+
+ok(
+	not($H ~~does 'ARRAY'),
+	q(not($H ~~does 'ARRAY')),
+);
+
+ok(
+	not($H ~~does_array),
+	q(not($H ~~does_array)),
+);
+
+ok(
+	($H ~~does 'HASH'),
+	q(($H ~~does 'HASH')),
+);
+
+ok(
+	$H ~~does_hash,
+	q($H ~~does_hash),
+);
+
+ok(
+	not($A ~~does 'HASH'),
+	q(not($A ~~does 'HASH')),
+);
+
+ok(
+	not($A ~~does_hash),
+	q(not($A ~~does_hash)),
+);
+
+ok(
+	not($A ~~overloads 'ARRAY'),
+	q(not($A ~~overloads 'ARRAY')),
+);
+
+done_testing();