7 use Moose::Util::TypeConstraints;
16 append_curried => [ append => '!' ],
18 prepend_curried => [ prepend => '-' ],
20 replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
25 match_curried => [ match => qr/\D/ ],
28 substr_curried_1 => [ substr => (1) ],
29 substr_curried_2 => [ substr => ( 1, 3 ) ],
30 substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
38 my $class = Moose::Meta::Class->create(
40 superclasses => ['Moose::Object'],
43 $class->add_attribute(
50 clearer => '_clear_string',
55 return ( $class->name, \%handles );
60 run_tests(build_class);
61 run_tests( build_class( lazy => 1, default => q{} ) );
63 # Will force the inlining code to check the entire hashref when it is modified.
64 subtype 'MyStr', as 'Str', where { 1 };
66 run_tests( build_class( isa => 'MyStr' ) );
68 coerce 'MyStr', from 'Str', via { $_ };
70 run_tests( build_class( isa => 'MyStr', coerce => 1 ) );
74 my ( $class, $handles ) = @_;
76 can_ok( $class, $_ ) for sort keys %{$handles};
79 my $obj = $class->new();
81 is( $obj->length, 0, 'length returns zero' );
84 is( $obj->length, 1, 'length returns 1 for new string' );
86 throws_ok { $obj->length(42) }
87 qr/Cannot call length with any arguments/,
88 'length throws an error when an argument is passed';
91 is( $obj->_string, 'b', 'a becomes b after inc' );
93 throws_ok { $obj->inc(42) }
94 qr/Cannot call inc with any arguments/,
95 'inc throws an error when an argument is passed';
98 is( $obj->_string, 'bfoo', 'appended to the string' );
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';
104 $obj->append_curried;
105 is( $obj->_string, 'bfoo!', 'append_curried appended to the string' );
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';
111 $obj->_string("has nl$/");
113 is( $obj->_string, 'has nl', 'chomped string' );
117 $obj->_string, 'has nl',
118 'chomp is a no-op when string has no line ending'
121 throws_ok { $obj->chomp(42) }
122 qr/Cannot call chomp with any arguments/,
123 'chomp throws an error when an argument is passed';
126 is( $obj->_string, 'has n', 'chopped string' );
128 throws_ok { $obj->chop(42) }
129 qr/Cannot call chop with any arguments/,
130 'chop throws an error when an argument is passed';
133 $obj->prepend('bar');
134 is( $obj->_string, 'barx', 'prepended to string' );
136 $obj->prepend_curried;
137 is( $obj->_string, '-barx', 'prepend_curried prepended to string' );
139 $obj->replace( qr/([ao])/, sub { uc($1) } );
141 $obj->_string, '-bArx',
142 'substitution using coderef for replacement'
145 $obj->replace( qr/A/, 'X' );
147 $obj->_string, '-bXrx',
148 'substitution using string as replacement'
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';
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';
159 $obj->_string('Moosex');
160 $obj->replace_curried;
161 is( $obj->_string, 'MooseX', 'capitalize last' );
163 $obj->_string('abcdef');
166 [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ],
167 'match -barx against /[aq]/ returns matches'
171 scalar $obj->match('b'),
172 'match with string as argument returns true'
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';
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';
183 $obj->_string('1234');
184 ok( !$obj->match_curried, 'match_curried returns false' );
186 $obj->_string('one two three four');
187 ok( $obj->match_curried, 'match curried returns true' );
190 is( $obj->_string, q{}, 'clear' );
192 throws_ok { $obj->clear(42) }
193 qr/Cannot call clear with any arguments/,
194 'clear throws an error when an argument is passed';
196 $obj->_string('some long string');
198 $obj->substr(1), 'ome long string',
199 'substr as getter with one argument'
202 $obj->_string('some long string');
204 $obj->substr( 1, 3 ), 'ome',
205 'substr as getter with two arguments'
208 $obj->substr( 1, 3, 'ong' );
211 $obj->_string, 'song long string',
212 'substr as setter with three arguments'
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';
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';
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';
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';
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';
235 $obj->_string('some long string');
238 $obj->substr_curried_1, 'ome long string',
239 'substr_curried_1 returns expected value'
243 $obj->substr_curried_1(3), 'ome',
244 'substr_curried_1 with one argument returns expected value'
247 $obj->substr_curried_1( 3, 'ong' );
250 $obj->_string, 'song long string',
251 'substr_curried_1 as setter with two arguments'
254 $obj->_string('some long string');
257 $obj->substr_curried_2, 'ome',
258 'substr_curried_2 returns expected value'
261 $obj->substr_curried_2('ong');
264 $obj->_string, 'song long string',
265 'substr_curried_2 as setter with one arguments'
268 $obj->_string('some long string');
270 $obj->substr_curried_3;
273 $obj->_string, 'song long string',
274 'substr_curried_3 as setter'
277 if ( $class->meta->get_attribute('_string')->is_lazy ) {
278 my $obj = $class->new;
283 $obj->_string, 'foo',
284 'append with lazy default'