1. Toby Inkster
  2. p5-scalar-does

Commits

Toby Inkster  committed d929839

improve test suite; 100% coverage according to Devel::Cover

  • Participants
  • Parent commits 38b14f6
  • Branches default

Comments (0)

Files changed (4)

File lib/Scalar/Does.pm

View file
 	my ($thing, $role) = @_;
 	
 	# curry (kinda)
-	return sub { overloads($_[0], $thing) } if @_==1;
+	return sub { overloads(shift, $thing) } if @_==1;
 	
 	goto \&overload::Method;
 }
 	my ($thing, $role) = @_;
 	
 	# curry (kinda)
-	return sub { does($_[0], $thing) } if @_==1;
+	return sub { does(shift, $thing) } if @_==1;
 	
 #	warn Dumper(@_);
 	
 C<< $scalar->DOES($role) >> is also called, and the string "0E0" is
 returned, which evaluates to 0 in a numeric context but true in a
 boolean context. This is an experimental feature; it has not yet
-been decided whether true or false is the correct response.
+been decided whether true or false is the correct response. Testing
+class names is a little dodgy, because you might get a different
+when testing instances of the class. For example, instances are
+typically blessed hashes, so C<< does($obj, 'HASH') >> is true.
+However, it is impossible to tell that from the class name.
 
 Note that the C<DOES> method is only defined in L<UNIVERSAL> in
 Perl 5.10+. You may wish to load L<UNIVERSAL::DOES> on earlier versions

File t/02does.t

View file
 	sub DOES  { return 1 if $_[1] eq 'Monkey'; shift->SUPER::DOES(@_) }
 }
 
+{
+	package Local::Does::Not;
+	sub new   { bless +{ array=>[] }, pop };
+	sub can   { return if $_[1] eq 'DOES'; shift->SUPER::can(@_) }
+}
+
+{
+	package Cruddy::Role;
+	sub new   { bless +{ array=>[] }, pop };
+}
+
+{
+	package Permissive::Role;
+	sub new   { bless +{ array=>[] }, pop };
+	sub check { 1 }
+}
+
 my %tests = (
 	ARRAY => [
 		[],
 	Overloaded_Object => [
 		Local::Does::Array->new,
 		does   => [qw( ARRAY @{} HASH %{} Local::Does::Array UNIVERSAL Monkey )],
-		doesnt => [qw( CODE bool "" )],
+		doesnt => [qw( CODE bool "" Gorilla )],
+	],
+	Overloaded_Class => [
+		'Local::Does::Array',
+		does   => [qw( bool "" ARRAY @{} Local::Does::Array UNIVERSAL Monkey )],
+		doesnt => [qw( CODE Gorilla HASH %{} )],
 	],
 	STDOUT => [
 		\*STDOUT,
 		does   => [qw( LVALUE )],
 		doesnt => [qw( SCALAR @{} Regexp CODE &{} Foo::Bar UNIVERSAL IO GLOB )],
 	],
+	Object_without_DOES_method => [
+		Local::Does::Not->new,
+		does   => [qw( HASH )],
+		doesnt => [qw( Local::Does::Not )],
+	],
+	Class_without_DOES_method => [
+		'Local::Does::Not',
+		does   => [qw( )],
+		doesnt => [qw( Local::Does::Not HASH )],
+	],
+);
+
+
+
+my @uncheck = (
+	Cruddy::Role->new,
+	[],
+	'FlibbleSocks',
+);
+my @check = (
+	Permissive::Role->new,
 );
 
 foreach my $name (sort keys %tests)
 	foreach my $tc (@{ $cases{doesnt} }) {
 		ok(!does($value, $tc), "$name doesn't $tc");
 	}
+	
+	ok( does($value, $_), "$name does $_") for @check;
+	ok(!does($value, $_), "$name doesn't do uncheckable role $_") for @uncheck;
 }
 
 done_testing();

File t/05custom.t

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

File t/99smartmatch.t

View file
+# This is an experimental feature.
+#
+
+use Test::More;
+BEGIN { $] >= 5.10.1 or plan skip_all => "Perl 5.10.1+" };
+
+plan tests => 4;
+
+use Scalar::Does qw( does overloads -constants );
+
+BEGIN {
+	package Local::OL;
+	use overload q[@{}] => sub { [] };
+	sub new { bless +{} }
+}
+
+ok(  ("a" ~~ does STRING)  );
+ok( !("a" ~~ does SCALAR) );
+
+my $obj = Local::OL->new;
+ok(  ($obj ~~ overloads '@{}') );
+ok( !($obj ~~ overloads '${}') );
+