Remove extra newline
[gitmo/Moose.git] / t / 070_native_traits / 050_trait_hash.t
CommitLineData
e3c07b19 1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
1c08fd75 6use Moose ();
6197a68c 7use Moose::Util::TypeConstraints;
e3c07b19 8use Test::Exception;
1c08fd75 9use Test::More;
10use Test::Moose;
e3c07b19 11
e3c07b19 12{
1c08fd75 13 my %handles = (
14 option_accessor => 'accessor',
15 quantity => [ accessor => 'quantity' ],
16 clear_options => 'clear',
17 num_options => 'count',
18 delete_option => 'delete',
19 is_defined => 'defined',
20 options_elements => 'elements',
21 has_option => 'exists',
22 get_option => 'get',
23 has_no_options => 'is_empty',
24 key_value => 'kv',
25 set_option => 'set',
e3c07b19 26 );
85592815 27
1c08fd75 28 my $name = 'Foo1';
29
30 sub build_class {
31 my %attr = @_;
32
33 my $class = Moose::Meta::Class->create(
34 $name++,
35 superclasses => ['Moose::Object'],
36 );
37
38 $class->add_attribute(
39 options => (
40 traits => ['Hash'],
41 is => 'ro',
42 isa => 'HashRef[Str]',
43 default => sub { {} },
44 handles => \%handles,
45 clearer => '_clear_options',
46 %attr,
47 ),
48 );
49
50 return ( $class->name, \%handles );
51 }
d50fc84a 52}
e3c07b19 53
1c08fd75 54{
55 run_tests(build_class);
56 run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) );
cf0da4e2 57 run_tests( build_class( trigger => sub { } ) );
6197a68c 58
59 # Will force the inlining code to check the entire hashref when it is modified.
60 subtype 'MyHashRef', as 'HashRef[Str]', where { 1 };
61
62 run_tests( build_class( isa => 'MyHashRef' ) );
63
64 coerce 'MyHashRef', from 'HashRef', via { $_ };
65
66 run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) );
d50fc84a 67}
59de9de4 68
1c08fd75 69sub run_tests {
70 my ( $class, $handles ) = @_;
59de9de4 71
1c08fd75 72 can_ok( $class, $_ ) for sort keys %{$handles};
e3c07b19 73
1c08fd75 74 with_immutable {
75 my $obj = $class->new( options => {} );
e3c07b19 76
1c08fd75 77 ok( $obj->has_no_options, '... we have no options' );
78 is( $obj->num_options, 0, '... we have no options' );
79
80 is_deeply( $obj->options, {}, '... no options yet' );
81 ok( !$obj->has_option('foo'), '... we have no foo option' );
82
83 lives_ok {
84 $obj->set_option( foo => 'bar' );
85 }
86 '... set the option okay';
87
88 ok( $obj->is_defined('foo'), '... foo is defined' );
89
90 ok( !$obj->has_no_options, '... we have options' );
91 is( $obj->num_options, 1, '... we have 1 option(s)' );
92 ok( $obj->has_option('foo'), '... we have a foo option' );
93 is_deeply( $obj->options, { foo => 'bar' }, '... got options now' );
94
95 lives_ok {
96 $obj->set_option( bar => 'baz' );
97 }
98 '... set the option okay';
99
100 is( $obj->num_options, 2, '... we have 2 option(s)' );
101 is_deeply(
102 $obj->options, { foo => 'bar', bar => 'baz' },
103 '... got more options now'
104 );
105
106 is( $obj->get_option('foo'), 'bar', '... got the right option' );
107
108 is_deeply(
109 [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)],
110 "get multiple options at once"
111 );
112
113 is(
114 scalar( $obj->get_option(qw( foo bar)) ), "baz",
115 '... got last option in scalar context'
116 );
117
118 lives_ok {
119 $obj->set_option( oink => "blah", xxy => "flop" );
120 }
121 '... set the option okay';
122
123 is( $obj->num_options, 4, "4 options" );
124 is_deeply(
125 [ $obj->get_option(qw(foo bar oink xxy)) ],
126 [qw(bar baz blah flop)], "get multiple options at once"
127 );
128
129 lives_ok {
130 $obj->delete_option('bar');
131 }
132 '... deleted the option okay';
133
134 lives_ok {
135 $obj->delete_option( 'oink', 'xxy' );
136 }
137 '... deleted multiple option okay';
138
139 is( $obj->num_options, 1, '... we have 1 option(s)' );
140 is_deeply(
141 $obj->options, { foo => 'bar' },
142 '... got more options now'
143 );
144
145 $obj->clear_options;
146
147 is_deeply( $obj->options, {}, "... cleared options" );
148
149 lives_ok {
150 $obj->quantity(4);
151 }
152 '... options added okay with defaults';
153
154 is( $obj->quantity, 4, 'reader part of curried accessor works' );
155
156 is_deeply(
157 $obj->options, { quantity => 4 },
158 '... returns what we expect'
159 );
160
161 lives_ok {
162 $class->new( options => { foo => 'BAR' } );
163 }
164 '... good constructor params';
165
166 dies_ok {
167 $obj->set_option( bar => {} );
168 }
169 '... could not add a hash ref where an string is expected';
170
171 dies_ok {
172 $class->new( options => { foo => [] } );
173 }
174 '... bad constructor params';
175
176 $obj->set_option( oink => "blah", xxy => "flop" );
177 my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value;
178 is_deeply(
179 \@key_value,
180 [
181 sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ],
182 [ 'quantity', 4 ],
183 [ 'oink', 'blah' ]
184 ],
185 '... got the right key value pairs'
186 )
187 or do {
188 require Data::Dumper;
189 diag( Data::Dumper::Dumper( \@key_value ) );
190 };
191
192 my %options_elements = $obj->options_elements;
193 is_deeply(
194 \%options_elements, {
195 'oink' => 'blah',
196 'quantity' => 4,
197 'xxy' => 'flop'
198 },
199 '... got the right hash elements'
200 );
201
202 if ( $class->meta->get_attribute('options')->is_lazy ) {
203 my $obj = $class->new;
204
205 $obj->set_option( y => 2 );
206
207 is_deeply(
208 $obj->options, { x => 1, y => 2 },
209 'set_option with lazy default'
210 );
211
212 $obj->_clear_options;
213
214 ok(
215 $obj->has_option('x'),
216 'key for x exists - lazy default'
217 );
218
219 $obj->_clear_options;
220
221 ok(
222 $obj->is_defined('x'),
223 'key for x is defined - lazy default'
224 );
225
226 $obj->_clear_options;
227
228 is_deeply(
229 [ $obj->key_value ],
230 [ [ x => 1 ] ],
231 'kv returns lazy default'
232 );
233 }
234 }
235 $class;
d50fc84a 236}
a28e50e4 237
238done_testing;