4 use Test::More tests => 14;
8 package MyRole::Storage;
9 use MooseX::Role::Parameterized;
10 use Moose::Util::TypeConstraints;
14 isa => (enum ['Dumper', 'Storable']),
18 parameter freeze_method => (
22 default => sub { "freeze_" . shift->format },
25 parameter thaw_method => (
29 default => sub { "thaw_" . shift->format },
34 my $format = $p->format;
36 my ($freezer, $thawer);
38 if ($format eq 'Dumper') {
40 $freezer = \&Data::Dumper::Dumper;
41 $thawer = sub { eval "@_" };
44 elsif ($format eq 'Storable') {
46 $freezer = \&Storable::nfreeze;
47 $thawer = \&Storable::thaw;
50 die "Unknown format ($format)";
53 method $p->freeze_method => $freezer;
54 method $p->thaw_method => $thawer;
59 package MyClass::Error;
61 with 'MyRole::Storage';
62 } qr/^Attribute \(format\) is required/;
65 package MyClass::Dumper;
67 with 'MyRole::Storage' => {
72 can_ok('MyClass::Dumper' => qw(freeze_Dumper thaw_Dumper));
73 cant_ok('MyClass::Storable' => qw(freeze_Storable thaw_Storable));
76 package MyClass::Storable;
78 with 'MyRole::Storage' => {
83 can_ok('MyClass::Storable' => qw(freeze_Storable thaw_Storable));
84 cant_ok('MyClass::Storable' => qw(freeze_Dumper thaw_Dumper));
87 package MyClass::DumperRenamed;
89 with 'MyRole::Storage' => {
91 freeze_method => 'save',
92 thaw_method => 'load',
96 can_ok('MyClass::DumperRenamed' => qw(save load));
97 cant_ok('MyClass::DumperRenamed' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable));
100 package MyClass::Both;
102 with 'MyRole::Storage' => { format => 'Dumper' };
103 with 'MyRole::Storage' => { format => 'Storable' };
106 can_ok('MyClass::Both' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable));
109 package MyClass::Three;
111 with 'MyRole::Storage' => { format => 'Dumper' };
112 with 'MyRole::Storage' => { format => 'Storable' };
113 with 'MyRole::Storage' => {
114 format => 'Storable',
115 freeze_method => 'store',
116 thaw_method => 'dump',
120 can_ok('MyClass::Three' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable store dump));
123 local $Test::Builder::Level = $Test::Builder::Level + 1;
124 my $instance = shift;
125 for my $method (@_) {
126 ok(!$instance->can($method), "$instance cannot $method");