t/070_native_traits/070_trait_string.t

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