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     run_tests( build_class( trigger => sub { } ) );
  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 ) );
  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         );
 121
 122         throws_ok { $obj->chomp(42) }
 123         qr/Cannot call chomp with any arguments/,
 124             'chomp throws an error when an argument is passed';
 125
 126         $obj->chop;
 127         is( $obj->_string, 'has n', 'chopped string' );
 128
 129         throws_ok { $obj->chop(42) }
 130         qr/Cannot call chop with any arguments/,
 131             'chop throws an error when an argument is passed';
 132
 133         $obj->_string('x');
 134         $obj->prepend('bar');
 135         is( $obj->_string, 'barx', 'prepended to string' );
 136
 137         $obj->prepend_curried;
 138         is( $obj->_string, '-barx', 'prepend_curried prepended to string' );
 139
 140         $obj->replace( qr/([ao])/, sub { uc($1) } );
 141         is(
 142             $obj->_string, '-bArx',
 143             'substitution using coderef for replacement'
 144         );
 145
 146         $obj->replace( qr/A/, 'X' );
 147         is(
 148             $obj->_string, '-bXrx',
 149             'substitution using string as replacement'
 150         );
 151
 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';
 155
 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';
 159
 160         $obj->_string('Moosex');
 161         $obj->replace_curried;
 162         is( $obj->_string, 'MooseX', 'capitalize last' );
 163
 164         $obj->_string('abcdef');
 165
 166         is_deeply(
 167             [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ],
 168             'match -barx against /[aq]/ returns matches'
 169         );
 170
 171         ok(
 172             scalar $obj->match('b'),
 173             'match with string as argument returns true'
 174         );
 175
 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';
 179
 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';
 183
 184         $obj->_string('1234');
 185         ok( !$obj->match_curried, 'match_curried returns false' );
 186
 187         $obj->_string('one two three four');
 188         ok( $obj->match_curried, 'match curried returns true' );
 189
 190         $obj->clear;
 191         is( $obj->_string, q{}, 'clear' );
 192
 193         throws_ok { $obj->clear(42) }
 194         qr/Cannot call clear with any arguments/,
 195             'clear throws an error when an argument is passed';
 196
 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         );
 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         }
 288     }
 289     $class;
 290 }
 291
 292 done_testing;