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