X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F025-more-isa.t;h=6e621a7e3a1689cb5a202de6b83a60d232e3c32a;hb=c9313657717f78bd96f0325c6aa1c93d0b0d41a5;hp=e68e0ec7f4cc5222ad323eb3580cd35eb6e54fc3;hpb=fb706f5c1e60ddafe873717be7209066d47b8998;p=gitmo%2FMouse.git diff --git a/t/025-more-isa.t b/t/025-more-isa.t old mode 100644 new mode 100755 index e68e0ec..6e621a7 --- a/t/025-more-isa.t +++ b/t/025-more-isa.t @@ -1,7 +1,7 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 10; +use Test::More tests => 34; use Test::Exception; do { @@ -12,6 +12,9 @@ do { is => 'rw', isa => 'Test::Builder', ); + + package Test::Builder::Subclass; + our @ISA = qw(Test::Builder); }; can_ok(Class => 'tb'); @@ -21,6 +24,13 @@ lives_ok { }; lives_ok { + # Test::Builder was a bizarre choice, because it's a singleton. Because of + # that calling new on T:B:S won't work. Blessing directly -- rjbs, + # 2008-12-04 + Class->new(tb => (bless {} => 'Test::Builder::Subclass')); +}; + +lives_ok { my $class = Class->new; $class->tb(Test::Builder->new); isa_ok($class->tb, 'Test::Builder'); @@ -44,6 +54,7 @@ do { use Mouse; has oops => ( + is => 'bare', isa => 'Int', default => "yikes", ); @@ -57,3 +68,115 @@ lives_ok { Other->new(oops => 10); }; +# ClassName coverage tests + +do { + package A; + our @VERSION; + + package Bx; # 'B' conflicts the B module + our $VERSION = 1; + + package C; + our %ISA; + + package D; + our @ISA = 'Mouse::Object'; + + package E; + sub foo {} + + package F; + + package G::H; + sub bar {} + + package I; + no warnings 'once'; # work around 5.6.2 + our $NOT_CODE = 1; +}; + +do { + package ClassNameTests; + use Mouse; + + has class => ( + is => 'rw', + isa => 'ClassName', + ); +}; + +for ('Bx', 'D'..'E', 'G::H') { + lives_ok { + ClassNameTests->new(class => $_); + }; + + lives_ok { + my $obj = ClassNameTests->new; + $obj->class($_); + }; +} + +throws_ok { + ClassNameTests->new(class => 'A'); +} qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value A/; + +throws_ok { + my $obj = ClassNameTests->new; + $obj->class('A'); +} qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value A/; + +throws_ok { + ClassNameTests->new(class => 'C'); +} qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value C/; + +throws_ok { + my $obj = ClassNameTests->new; + $obj->class('C'); +} qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value C/; + +for ('F', 'G', 'I', 'Z') { + throws_ok { + ClassNameTests->new(class => $_); + } qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value $_/; + + throws_ok { + my $obj = ClassNameTests->new; + $obj->class($_); + } qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value $_/; +}; + + +# Check that Roles can be used in 'isa' and they are constrained with +# 'does' +do { + package SausageRole; + use Mouse::Role; + + package DoesSausage; + use Mouse; + with 'SausageRole'; + + package HasSausage; + use Mouse; + + has sausage => + (isa => 'SausageRole', + is => 'rw'); + +}; + +my $hs; +lives_ok { + $hs = HasSausage->new(sausage => DoesSausage->new); +}; +lives_ok { + $hs->sausage(DoesSausage->new); +}; +throws_ok { + HasSausage->new(sausage => Class->new); +} qr/^Attribute \(sausage\) does not pass the type constraint because: Validation failed for 'SausageRole' failed with value Class=/; +throws_ok { + $hs->sausage(Class->new); +} qr/^Attribute \(sausage\) does not pass the type constraint because: Validation failed for 'SausageRole' failed with value Class=/; +