1use strict; 2use warnings; 3use Test::More 0.88; 4use Test::Fatal; 5 6my %args; 7do { 8 package MyRole::Storage; 9 use MooseX::Role::Parameterized; 10 use Moose::Util::TypeConstraints 'enum'; 11 12 parameter format => ( 13 isa => (enum ['Dumper', 'Storable']), 14 required => 1, 15 ); 16 17 parameter freeze_method => ( 18 isa => 'Str', 19 lazy => 1, 20 default => sub { "freeze_" . shift->format }, 21 ); 22 23 parameter thaw_method => ( 24 isa => 'Str', 25 lazy => 1, 26 default => sub { "thaw_" . shift->format }, 27 ); 28 29 role { 30 my $p = shift; 31 %args = @_; 32 33 my $format = $p->format; 34 35 my ($freezer, $thawer); 36 37 if ($format eq 'Dumper') { 38 require Data::Dumper; 39 $freezer = \&Data::Dumper::Dumper; 40 $thawer = sub { eval "@_" }; 41 42 } 43 elsif ($format eq 'Storable') { 44 require Storable; 45 $freezer = \&Storable::nfreeze; 46 $thawer = \&Storable::thaw; 47 } 48 else { 49 die "Unknown format ($format)"; 50 } 51 52 method $p->freeze_method => $freezer; 53 method $p->thaw_method => $thawer; 54 }; 55}; 56 57do { 58 package MyClass::Dumper; 59 use Moose; 60 with 'MyRole::Storage' => { 61 format => 'Dumper', 62 }; 63}; 64 65can_ok('MyClass::Dumper' => qw(freeze_Dumper thaw_Dumper)); 66cant_ok('MyClass::Dumper' => qw(freeze_Storable thaw_Storable)); 67 68is($args{consumer}, MyClass::Dumper->meta, 'Role block receives consumer'); 69is(MyClass::Dumper->meta->roles->[0]->genitor, MyRole::Storage->meta, 'genitor'); 70 71do { 72 package MyClass::Storable; 73 use Moose; 74 with 'MyRole::Storage' => { 75 format => 'Storable', 76 }; 77}; 78 79can_ok('MyClass::Storable' => qw(freeze_Storable thaw_Storable)); 80cant_ok('MyClass::Storable' => qw(freeze_Dumper thaw_Dumper)); 81 82is($args{consumer}, MyClass::Storable->meta, 'Role block receives consumer'); 83 84do { 85 package MyClass::DumperRenamed; 86 use Moose; 87 with 'MyRole::Storage' => { 88 format => 'Dumper', 89 freeze_method => 'save', 90 thaw_method => 'load', 91 }; 92}; 93 94can_ok('MyClass::DumperRenamed' => qw(save load)); 95cant_ok('MyClass::DumperRenamed' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable)); 96 97is($args{consumer}, MyClass::DumperRenamed->meta, 'Role block receives consumer'); 98 99do { 100 package MyClass::Both; 101 use Moose; 102 with 'MyRole::Storage' => { format => 'Dumper' }; 103 with 'MyRole::Storage' => { format => 'Storable' }; 104}; 105 106can_ok('MyClass::Both' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable)); 107is($args{consumer}, MyClass::Both->meta, 'Role block receives consumer'); 108 109do { 110 package MyClass::Three; 111 use Moose; 112 with 'MyRole::Storage' => { format => 'Dumper' }; 113 with 'MyRole::Storage' => { format => 'Storable' }; 114 with 'MyRole::Storage' => { 115 format => 'Storable', 116 freeze_method => 'store', 117 thaw_method => 'dump', 118 }; 119}; 120 121can_ok('MyClass::Three' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable store dump)); 122is($args{consumer}, MyClass::Three->meta, 'Role block receives consumer'); 123 124like( exception { 125 package MyClass::Error::Required; 126 use Moose; 127 with 'MyRole::Storage'; 128}, qr/^Attribute \(format\) is required/); 129 130like( exception { 131 package MyClass::Error::Invalid; 132 use Moose; 133 with 'MyRole::Storage' => { 134 format => 'YAML', 135 }; 136}, qr/^Attribute \(format\) does not pass the type constraint/); 137 138like( exception { 139 package MyRole::Sans::Block; 140 use MooseX::Role::Parameterized; 141 142 parameter 'foo'; 143 144 package MyClass::Error::BlocklessRole; 145 use Moose; 146 with 'MyRole::Sans::Block' => {}; 147}, qr/^\QA role generator is required to apply parameterized roles (did you forget the 'role { ... }' block in your parameterized role 'MyRole::Sans::Block'?)\E/); 148 149sub cant_ok { 150 local $Test::Builder::Level = $Test::Builder::Level + 1; 151 my $instance = shift; 152 for my $method (@_) { 153 ok(!$instance->can($method), "$instance cannot $method"); 154 } 155} 156 157done_testing; 158