9 use Moose::Util::TypeConstraints;
10 use NoInlineAttribute;
19 append_curried => [ append => '!' ],
21 prepend_curried => [ prepend => '-' ],
23 replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
28 match_curried => [ match => qr/\D/ ],
31 substr_curried_1 => [ substr => (1) ],
32 substr_curried_2 => [ substr => ( 1, 3 ) ],
33 substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
41 my $class = Moose::Meta::Class->create(
43 superclasses => ['Moose::Object'],
46 my @traits = 'String';
47 push @traits, 'NoInlineAttribute'
48 if delete $attr{no_inline};
50 $class->add_attribute(
57 clearer => '_clear_string',
62 return ( $class->name, \%handles );
67 run_tests(build_class);
68 run_tests( build_class( lazy => 1, default => q{} ) );
69 run_tests( build_class( trigger => sub { } ) );
70 run_tests( build_class( no_inline => 1 ) );
72 # Will force the inlining code to check the entire hashref when it is modified.
73 subtype 'MyStr', as 'Str', where { 1 };
75 run_tests( build_class( isa => 'MyStr' ) );
77 coerce 'MyStr', from 'Str', via { $_ };
79 run_tests( build_class( isa => 'MyStr', coerce => 1 ) );
83 my ( $class, $handles ) = @_;
85 can_ok( $class, $_ ) for sort keys %{$handles};
88 my $obj = $class->new();
90 is( $obj->length, 0, 'length returns zero' );
93 is( $obj->length, 1, 'length returns 1 for new string' );
95 like exception { $obj->length(42) },
96 qr/Cannot call length with any arguments/,
97 'length throws an error when an argument is passed';
99 is( $obj->inc, 'b', 'inc returns new value' );
100 is( $obj->_string, 'b', 'a becomes b after inc' );
102 like exception { $obj->inc(42) },
103 qr/Cannot call inc with any arguments/,
104 'inc throws an error when an argument is passed';
106 is( $obj->append('foo'), 'bfoo', 'append returns new value' );
107 is( $obj->_string, 'bfoo', 'appended to the string' );
109 like exception { $obj->append( 'foo', 2 ) },
110 qr/Cannot call append with more than 1 argument/,
111 'append throws an error when two arguments are passed';
113 $obj->append_curried;
114 is( $obj->_string, 'bfoo!', 'append_curried appended to the string' );
116 like exception { $obj->append_curried('foo') },
117 qr/Cannot call append with more than 1 argument/,
118 'append_curried throws an error when two arguments are passed';
120 $obj->_string("has nl$/");
121 is( $obj->chomp, 1, 'chomp returns number of characters removed' );
122 is( $obj->_string, 'has nl', 'chomped string' );
124 is( $obj->chomp, 0, 'chomp returns number of characters removed' );
126 $obj->_string, 'has nl',
127 'chomp is a no-op when string has no line ending'
130 like exception { $obj->chomp(42) },
131 qr/Cannot call chomp with any arguments/,
132 'chomp throws an error when an argument is passed';
134 is( $obj->chop, 'l', 'chop returns character removed' );
135 is( $obj->_string, 'has n', 'chopped string' );
137 like exception { $obj->chop(42) },
138 qr/Cannot call chop with any arguments/,
139 'chop throws an error when an argument is passed';
142 is( $obj->prepend('bar'), 'barx', 'prepend returns new value' );
143 is( $obj->_string, 'barx', 'prepended to string' );
145 $obj->prepend_curried;
146 is( $obj->_string, '-barx', 'prepend_curried prepended to string' );
149 $obj->replace( qr/([ao])/, sub { uc($1) } ),
151 'replace returns new value'
155 $obj->_string, '-bArx',
156 'substitution using coderef for replacement'
159 $obj->replace( qr/A/, 'X' );
161 $obj->_string, '-bXrx',
162 'substitution using string as replacement'
165 $obj->_string('foo');
166 $obj->replace( qr/oo/, q{} );
168 is( $obj->_string, 'f',
169 'replace accepts an empty string as second argument' );
171 $obj->replace( q{}, 'a' );
173 is( $obj->_string, 'af',
174 'replace accepts an empty string as first argument' );
176 like exception { $obj->replace( {}, 'x' ) },
177 qr/The first argument passed to replace must be a string or regexp reference/,
178 'replace throws an error when the first argument is not a string or regexp';
180 like exception { $obj->replace( qr/x/, {} ) },
181 qr/The second argument passed to replace must be a string or code reference/,
182 'replace throws an error when the first argument is not a string or regexp';
184 $obj->_string('Moosex');
185 $obj->replace_curried;
186 is( $obj->_string, 'MooseX', 'capitalize last' );
188 $obj->_string('abcdef');
191 [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ],
192 'match -barx against /[aq]/ returns matches'
196 [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ],
197 'match -barx against /[aq]/ returns matches'
201 scalar $obj->match('b'),
202 'match with string as argument returns true'
206 scalar $obj->match(q{}),
207 'match with empty string as argument returns true'
210 like exception { $obj->match },
211 qr/Cannot call match without at least 1 argument/,
212 'match throws an error when no arguments are passed';
214 like exception { $obj->match( {} ) },
215 qr/The argument passed to match must be a string or regexp reference/,
216 'match throws an error when an invalid argument is passed';
218 $obj->_string('1234');
219 ok( !$obj->match_curried, 'match_curried returns false' );
221 $obj->_string('one two three four');
222 ok( $obj->match_curried, 'match curried returns true' );
225 is( $obj->_string, q{}, 'clear' );
227 like exception { $obj->clear(42) },
228 qr/Cannot call clear with any arguments/,
229 'clear throws an error when an argument is passed';
231 $obj->_string('some long string');
233 $obj->substr(1), 'ome long string',
234 'substr as getter with one argument'
237 $obj->_string('some long string');
239 $obj->substr( 1, 3 ), 'ome',
240 'substr as getter with two arguments'
244 $obj->substr( 1, 3, 'ong' ),
246 'substr as setter returns replaced string'
250 $obj->_string, 'song long string',
251 'substr as setter with three arguments'
254 $obj->substr( 1, 3, '' );
257 $obj->_string, 's long string',
258 'substr as setter with three arguments, replacment is empty string'
261 like exception { $obj->substr },
262 qr/Cannot call substr without at least 1 argument/,
263 'substr throws an error when no argumemts are passed';
265 like exception { $obj->substr( 1, 2, 3, 4 ) },
266 qr/Cannot call substr with more than 3 arguments/,
267 'substr throws an error when four argumemts are passed';
269 like exception { $obj->substr( {} ) },
270 qr/The first argument passed to substr must be an integer/,
271 'substr throws an error when first argument is not an integer';
273 like exception { $obj->substr( 1, {} ) },
274 qr/The second argument passed to substr must be an integer/,
275 'substr throws an error when second argument is not an integer';
277 like exception { $obj->substr( 1, 2, {} ) },
278 qr/The third argument passed to substr must be a string/,
279 'substr throws an error when third argument is not a string';
281 $obj->_string('some long string');
284 $obj->substr_curried_1, 'ome long string',
285 'substr_curried_1 returns expected value'
289 $obj->substr_curried_1(3), 'ome',
290 'substr_curried_1 with one argument returns expected value'
293 $obj->substr_curried_1( 3, 'ong' );
296 $obj->_string, 'song long string',
297 'substr_curried_1 as setter with two arguments'
300 $obj->_string('some long string');
303 $obj->substr_curried_2, 'ome',
304 'substr_curried_2 returns expected value'
307 $obj->substr_curried_2('ong');
310 $obj->_string, 'song long string',
311 'substr_curried_2 as setter with one arguments'
314 $obj->_string('some long string');
316 $obj->substr_curried_3;
319 $obj->_string, 'song long string',
320 'substr_curried_3 as setter'
323 if ( $class->meta->get_attribute('_string')->is_lazy ) {
324 my $obj = $class->new;
329 $obj->_string, 'foo',
330 'append with lazy default'