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 Test::More;
   8 use Test::Exception;
   9 use Test::Moose;
  10
  11 {
  12     my %handles = (
  13         inc             => 'inc',
  14         append          => 'append',
  15         append_curried  => [ append => '!' ],
  16         prepend         => 'prepend',
  17         prepend_curried => [ prepend => '-' ],
  18         replace         => 'replace',
  19         replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
  20         chop            => 'chop',
  21         chomp           => 'chomp',
  22         clear           => 'clear',
  23         match           => 'match',
  24         match_curried    => [ match  => qr/\D/ ],
  25         length           => 'length',
  26         substr           => 'substr',
  27         substr_curried_1 => [ substr => (1) ],
  28         substr_curried_2 => [ substr => ( 1, 3 ) ],
  29         substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
  30     );
  31
  32     my $name = 'Foo1';
  33
  34     sub build_class {
  35         my %attr = @_;
  36
  37         my $class = Moose::Meta::Class->create(
  38             $name++,
  39             superclasses => ['Moose::Object'],
  40         );
  41
  42         $class->add_attribute(
  43             _string => (
  44                 traits  => ['String'],
  45                 is      => 'rw',
  46                 isa     => 'Str',
  47                 default => q{},
  48                 handles => \%handles,
  49                 clearer => '_clear_string',
  50                 %attr,
  51             ),
  52         );
  53
  54         return ( $class->name, \%handles );
  55     }
  56 }
  57
  58 {
  59     run_tests(build_class);
  60     run_tests( build_class( lazy => 1, default => q{} ) );
  61 }
  62
  63 sub run_tests {
  64     my ( $class, $handles ) = @_;
  65
  66     can_ok( $class, $_ ) for sort keys %{$handles};
  67
  68     with_immutable {
  69         my $obj = $class->new();
  70
  71         is( $obj->length, 0, 'length returns zero' );
  72
  73         $obj->_string('a');
  74         is( $obj->length, 1, 'length returns 1 for new string' );
  75
  76         throws_ok { $obj->length(42) }
  77         qr/Cannot call length with any arguments/,
  78             'length throws an error when an argument is passed';
  79
  80         $obj->inc;
  81         is( $obj->_string, 'b', 'a becomes b after inc' );
  82
  83         throws_ok { $obj->inc(42) }
  84         qr/Cannot call inc with any arguments/,
  85             'inc throws an error when an argument is passed';
  86
  87         $obj->append('foo');
  88         is( $obj->_string, 'bfoo', 'appended to the string' );
  89
  90         throws_ok { $obj->append( 'foo', 2 ) }
  91         qr/Cannot call append with more than 1 argument/,
  92             'append throws an error when two arguments are passed';
  93
  94         $obj->append_curried;
  95         is( $obj->_string, 'bfoo!', 'append_curried appended to the string' );
  96
  97         throws_ok { $obj->append_curried('foo') }
  98         qr/Cannot call append with more than 1 argument/,
  99             'append_curried throws an error when two arguments are passed';
 100
 101         $obj->_string("has nl$/");
 102         $obj->chomp;
 103         is( $obj->_string, 'has nl', 'chomped string' );
 104
 105         $obj->chomp;
 106         is(
 107             $obj->_string, 'has nl',
 108             'chomp is a no-op when string has no line ending'
 109         );
 110
 111         throws_ok { $obj->chomp(42) }
 112         qr/Cannot call chomp with any arguments/,
 113             'chomp throws an error when an argument is passed';
 114
 115         $obj->chop;
 116         is( $obj->_string, 'has n', 'chopped string' );
 117
 118         throws_ok { $obj->chop(42) }
 119         qr/Cannot call chop with any arguments/,
 120             'chop throws an error when an argument is passed';
 121
 122         $obj->_string('x');
 123         $obj->prepend('bar');
 124         is( $obj->_string, 'barx', 'prepended to string' );
 125
 126         $obj->prepend_curried;
 127         is( $obj->_string, '-barx', 'prepend_curried prepended to string' );
 128
 129         $obj->replace( qr/([ao])/, sub { uc($1) } );
 130         is(
 131             $obj->_string, '-bArx',
 132             'substitution using coderef for replacement'
 133         );
 134
 135         $obj->replace( qr/A/, 'X' );
 136         is(
 137             $obj->_string, '-bXrx',
 138             'substitution using string as replacement'
 139         );
 140
 141         throws_ok { $obj->replace( {}, 'x' ) }
 142         qr/The first argument passed to replace must be a string or regexp reference/,
 143             'replace throws an error when the first argument is not a string or regexp';
 144
 145         throws_ok { $obj->replace( qr/x/, {} ) }
 146         qr/The second argument passed to replace must be a string or code reference/,
 147             'replace throws an error when the first argument is not a string or regexp';
 148
 149         $obj->_string('Moosex');
 150         $obj->replace_curried;
 151         is( $obj->_string, 'MooseX', 'capitalize last' );
 152
 153         $obj->_string('abcdef');
 154
 155         is_deeply(
 156             [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ],
 157             'match -barx against /[aq]/ returns matches'
 158         );
 159
 160         ok(
 161             scalar $obj->match('b'),
 162             'match with string as argument returns true'
 163         );
 164
 165         throws_ok { $obj->match }
 166         qr/Cannot call match without at least 1 argument/,
 167             'match throws an error when no arguments are passed';
 168
 169         throws_ok { $obj->match( {} ) }
 170         qr/The argument passed to match must be a string or regexp reference/,
 171             'match throws an error when an invalid argument is passed';
 172
 173         $obj->_string('1234');
 174         ok( !$obj->match_curried, 'match_curried returns false' );
 175
 176         $obj->_string('one two three four');
 177         ok( $obj->match_curried, 'match curried returns true' );
 178
 179         $obj->clear;
 180         is( $obj->_string, q{}, 'clear' );
 181
 182         throws_ok { $obj->clear(42) }
 183         qr/Cannot call clear with any arguments/,
 184             'clear throws an error when an argument is passed';
 185
 186         $obj->_string('some long string');
 187         is(
 188             $obj->substr(1), 'ome long string',
 189             'substr as getter with one argument'
 190         );
 191
 192         $obj->_string('some long string');
 193         is(
 194             $obj->substr( 1, 3 ), 'ome',
 195             'substr as getter with two arguments'
 196         );
 197
 198         $obj->substr( 1, 3, 'ong' );
 199
 200         is(
 201             $obj->_string, 'song long string',
 202             'substr as setter with three arguments'
 203         );
 204
 205         throws_ok { $obj->substr }
 206         qr/Cannot call substr without at least 1 argument/,
 207             'substr throws an error when no argumemts are passed';
 208
 209         throws_ok { $obj->substr( 1, 2, 3, 4 ) }
 210         qr/Cannot call substr with more than 3 arguments/,
 211             'substr throws an error when four argumemts are passed';
 212
 213         throws_ok { $obj->substr( {} ) }
 214         qr/The first argument passed to substr must be an integer/,
 215             'substr throws an error when first argument is not an integer';
 216
 217         throws_ok { $obj->substr( 1, {} ) }
 218         qr/The second argument passed to substr must be a positive integer/,
 219             'substr throws an error when second argument is not a positive integer';
 220
 221         throws_ok { $obj->substr( 1, 2, {} ) }
 222         qr/The third argument passed to substr must be a string/,
 223             'substr throws an error when third argument is not a string';
 224
 225         $obj->_string('some long string');
 226
 227         is(
 228             $obj->substr_curried_1, 'ome long string',
 229             'substr_curried_1 returns expected value'
 230         );
 231
 232         is(
 233             $obj->substr_curried_1(3), 'ome',
 234             'substr_curried_1 with one argument returns expected value'
 235         );
 236
 237         $obj->substr_curried_1( 3, 'ong' );
 238
 239         is(
 240             $obj->_string, 'song long string',
 241             'substr_curried_1 as setter with two arguments'
 242         );
 243
 244         $obj->_string('some long string');
 245
 246         is(
 247             $obj->substr_curried_2, 'ome',
 248             'substr_curried_2 returns expected value'
 249         );
 250
 251         $obj->substr_curried_2('ong');
 252
 253         is(
 254             $obj->_string, 'song long string',
 255             'substr_curried_2 as setter with one arguments'
 256         );
 257
 258         $obj->_string('some long string');
 259
 260         $obj->substr_curried_3;
 261
 262         is(
 263             $obj->_string, 'song long string',
 264             'substr_curried_3 as setter'
 265         );
 266
 267         if ( $class->meta->get_attribute('_string')->is_lazy ) {
 268             my $obj = $class->new;
 269
 270             $obj->append('foo');
 271
 272             is(
 273                 $obj->_string, 'foo',
 274                 'append with lazy default'
 275             );
 276         }
 277     }
 278     $class;
 279 }
 280
 281 done_testing;