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