Commit | Line | Data |
e3c07b19 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
e7724627 |
6 | use Moose (); |
2c963694 |
7 | use Moose::Util::TypeConstraints; |
a28e50e4 |
8 | use Test::More; |
e7724627 |
9 | use Test::Exception; |
10 | use Test::Moose; |
e3c07b19 |
11 | |
e3c07b19 |
12 | { |
e7724627 |
13 | my %handles = ( |
14 | inc => 'inc', |
15 | append => 'append', |
16 | append_curried => [ append => '!' ], |
17 | prepend => 'prepend', |
18 | prepend_curried => [ prepend => '-' ], |
19 | replace => 'replace', |
20 | replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], |
21 | chop => 'chop', |
22 | chomp => 'chomp', |
23 | clear => 'clear', |
24 | match => 'match', |
25 | match_curried => [ match => qr/\D/ ], |
26 | length => 'length', |
27 | substr => 'substr', |
28 | substr_curried_1 => [ substr => (1) ], |
29 | substr_curried_2 => [ substr => ( 1, 3 ) ], |
30 | substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], |
e3c07b19 |
31 | ); |
e7724627 |
32 | |
33 | my $name = 'Foo1'; |
34 | |
35 | sub build_class { |
36 | my %attr = @_; |
37 | |
38 | my $class = Moose::Meta::Class->create( |
39 | $name++, |
40 | superclasses => ['Moose::Object'], |
41 | ); |
42 | |
43 | $class->add_attribute( |
44 | _string => ( |
45 | traits => ['String'], |
46 | is => 'rw', |
47 | isa => 'Str', |
48 | default => q{}, |
49 | handles => \%handles, |
50 | clearer => '_clear_string', |
51 | %attr, |
52 | ), |
53 | ); |
54 | |
55 | return ( $class->name, \%handles ); |
56 | } |
e3c07b19 |
57 | } |
58 | |
e7724627 |
59 | { |
60 | run_tests(build_class); |
61 | run_tests( build_class( lazy => 1, default => q{} ) ); |
cf0da4e2 |
62 | run_tests( build_class( trigger => sub { } ) ); |
2c963694 |
63 | |
64 | # Will force the inlining code to check the entire hashref when it is modified. |
65 | subtype 'MyStr', as 'Str', where { 1 }; |
66 | |
67 | run_tests( build_class( isa => 'MyStr' ) ); |
68 | |
69 | coerce 'MyStr', from 'Str', via { $_ }; |
70 | |
71 | run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); |
e7724627 |
72 | } |
73 | |
74 | sub run_tests { |
75 | my ( $class, $handles ) = @_; |
76 | |
77 | can_ok( $class, $_ ) for sort keys %{$handles}; |
78 | |
79 | with_immutable { |
80 | my $obj = $class->new(); |
81 | |
82 | is( $obj->length, 0, 'length returns zero' ); |
83 | |
84 | $obj->_string('a'); |
85 | is( $obj->length, 1, 'length returns 1 for new string' ); |
86 | |
87 | throws_ok { $obj->length(42) } |
88 | qr/Cannot call length with any arguments/, |
89 | 'length throws an error when an argument is passed'; |
90 | |
91 | $obj->inc; |
92 | is( $obj->_string, 'b', 'a becomes b after inc' ); |
93 | |
94 | throws_ok { $obj->inc(42) } |
95 | qr/Cannot call inc with any arguments/, |
96 | 'inc throws an error when an argument is passed'; |
97 | |
98 | $obj->append('foo'); |
99 | is( $obj->_string, 'bfoo', 'appended to the string' ); |
100 | |
101 | throws_ok { $obj->append( 'foo', 2 ) } |
102 | qr/Cannot call append with more than 1 argument/, |
103 | 'append throws an error when two arguments are passed'; |
104 | |
105 | $obj->append_curried; |
106 | is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); |
107 | |
108 | throws_ok { $obj->append_curried('foo') } |
109 | qr/Cannot call append with more than 1 argument/, |
110 | 'append_curried throws an error when two arguments are passed'; |
111 | |
112 | $obj->_string("has nl$/"); |
113 | $obj->chomp; |
114 | is( $obj->_string, 'has nl', 'chomped string' ); |
115 | |
116 | $obj->chomp; |
117 | is( |
118 | $obj->_string, 'has nl', |
119 | 'chomp is a no-op when string has no line ending' |
120 | ); |
e3c07b19 |
121 | |
e7724627 |
122 | throws_ok { $obj->chomp(42) } |
123 | qr/Cannot call chomp with any arguments/, |
124 | 'chomp throws an error when an argument is passed'; |
e3c07b19 |
125 | |
e7724627 |
126 | $obj->chop; |
127 | is( $obj->_string, 'has n', 'chopped string' ); |
e3c07b19 |
128 | |
e7724627 |
129 | throws_ok { $obj->chop(42) } |
130 | qr/Cannot call chop with any arguments/, |
131 | 'chop throws an error when an argument is passed'; |
e3c07b19 |
132 | |
e7724627 |
133 | $obj->_string('x'); |
134 | $obj->prepend('bar'); |
135 | is( $obj->_string, 'barx', 'prepended to string' ); |
e3c07b19 |
136 | |
e7724627 |
137 | $obj->prepend_curried; |
138 | is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); |
e3c07b19 |
139 | |
e7724627 |
140 | $obj->replace( qr/([ao])/, sub { uc($1) } ); |
141 | is( |
142 | $obj->_string, '-bArx', |
143 | 'substitution using coderef for replacement' |
144 | ); |
e3c07b19 |
145 | |
e7724627 |
146 | $obj->replace( qr/A/, 'X' ); |
147 | is( |
148 | $obj->_string, '-bXrx', |
149 | 'substitution using string as replacement' |
150 | ); |
e3c07b19 |
151 | |
e7724627 |
152 | throws_ok { $obj->replace( {}, 'x' ) } |
153 | qr/The first argument passed to replace must be a string or regexp reference/, |
154 | 'replace throws an error when the first argument is not a string or regexp'; |
e3c07b19 |
155 | |
e7724627 |
156 | throws_ok { $obj->replace( qr/x/, {} ) } |
157 | qr/The second argument passed to replace must be a string or code reference/, |
158 | 'replace throws an error when the first argument is not a string or regexp'; |
e3c07b19 |
159 | |
e7724627 |
160 | $obj->_string('Moosex'); |
161 | $obj->replace_curried; |
162 | is( $obj->_string, 'MooseX', 'capitalize last' ); |
e3c07b19 |
163 | |
e7724627 |
164 | $obj->_string('abcdef'); |
e3c07b19 |
165 | |
e7724627 |
166 | is_deeply( |
167 | [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], |
168 | 'match -barx against /[aq]/ returns matches' |
169 | ); |
59de9de4 |
170 | |
e7724627 |
171 | ok( |
172 | scalar $obj->match('b'), |
173 | 'match with string as argument returns true' |
174 | ); |
59de9de4 |
175 | |
e7724627 |
176 | throws_ok { $obj->match } |
177 | qr/Cannot call match without at least 1 argument/, |
178 | 'match throws an error when no arguments are passed'; |
59de9de4 |
179 | |
e7724627 |
180 | throws_ok { $obj->match( {} ) } |
181 | qr/The argument passed to match must be a string or regexp reference/, |
182 | 'match throws an error when an invalid argument is passed'; |
59de9de4 |
183 | |
e7724627 |
184 | $obj->_string('1234'); |
185 | ok( !$obj->match_curried, 'match_curried returns false' ); |
e3c07b19 |
186 | |
e7724627 |
187 | $obj->_string('one two three four'); |
188 | ok( $obj->match_curried, 'match curried returns true' ); |
e3c07b19 |
189 | |
e7724627 |
190 | $obj->clear; |
191 | is( $obj->_string, q{}, 'clear' ); |
d50fc84a |
192 | |
e7724627 |
193 | throws_ok { $obj->clear(42) } |
194 | qr/Cannot call clear with any arguments/, |
195 | 'clear throws an error when an argument is passed'; |
d50fc84a |
196 | |
e7724627 |
197 | $obj->_string('some long string'); |
198 | is( |
199 | $obj->substr(1), 'ome long string', |
200 | 'substr as getter with one argument' |
201 | ); |
202 | |
203 | $obj->_string('some long string'); |
204 | is( |
205 | $obj->substr( 1, 3 ), 'ome', |
206 | 'substr as getter with two arguments' |
207 | ); |
208 | |
209 | $obj->substr( 1, 3, 'ong' ); |
210 | |
211 | is( |
212 | $obj->_string, 'song long string', |
213 | 'substr as setter with three arguments' |
214 | ); |
215 | |
216 | throws_ok { $obj->substr } |
217 | qr/Cannot call substr without at least 1 argument/, |
218 | 'substr throws an error when no argumemts are passed'; |
219 | |
220 | throws_ok { $obj->substr( 1, 2, 3, 4 ) } |
221 | qr/Cannot call substr with more than 3 arguments/, |
222 | 'substr throws an error when four argumemts are passed'; |
223 | |
224 | throws_ok { $obj->substr( {} ) } |
225 | qr/The first argument passed to substr must be an integer/, |
226 | 'substr throws an error when first argument is not an integer'; |
227 | |
228 | throws_ok { $obj->substr( 1, {} ) } |
229 | qr/The second argument passed to substr must be a positive integer/, |
230 | 'substr throws an error when second argument is not a positive integer'; |
231 | |
232 | throws_ok { $obj->substr( 1, 2, {} ) } |
233 | qr/The third argument passed to substr must be a string/, |
234 | 'substr throws an error when third argument is not a string'; |
235 | |
236 | $obj->_string('some long string'); |
237 | |
238 | is( |
239 | $obj->substr_curried_1, 'ome long string', |
240 | 'substr_curried_1 returns expected value' |
241 | ); |
242 | |
243 | is( |
244 | $obj->substr_curried_1(3), 'ome', |
245 | 'substr_curried_1 with one argument returns expected value' |
246 | ); |
247 | |
248 | $obj->substr_curried_1( 3, 'ong' ); |
249 | |
250 | is( |
251 | $obj->_string, 'song long string', |
252 | 'substr_curried_1 as setter with two arguments' |
253 | ); |
254 | |
255 | $obj->_string('some long string'); |
256 | |
257 | is( |
258 | $obj->substr_curried_2, 'ome', |
259 | 'substr_curried_2 returns expected value' |
260 | ); |
261 | |
262 | $obj->substr_curried_2('ong'); |
263 | |
264 | is( |
265 | $obj->_string, 'song long string', |
266 | 'substr_curried_2 as setter with one arguments' |
267 | ); |
268 | |
269 | $obj->_string('some long string'); |
270 | |
271 | $obj->substr_curried_3; |
272 | |
273 | is( |
274 | $obj->_string, 'song long string', |
275 | 'substr_curried_3 as setter' |
276 | ); |
69048e4e |
277 | |
278 | if ( $class->meta->get_attribute('_string')->is_lazy ) { |
279 | my $obj = $class->new; |
280 | |
281 | $obj->append('foo'); |
282 | |
283 | is( |
284 | $obj->_string, 'foo', |
285 | 'append with lazy default' |
286 | ); |
287 | } |
e7724627 |
288 | } |
289 | $class; |
290 | } |
e3c07b19 |
291 | |
a28e50e4 |
292 | done_testing; |