t/070_native_traits/050_trait_hash.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Moose ();
   7 use Moose::Util::TypeConstraints;
   8 use Test::Exception;
   9 use Test::More;
  10 use Test::Moose;
  11
  12 {
  13     my %handles = (
  14         option_accessor  => 'accessor',
  15         quantity         => [ accessor => 'quantity' ],
  16         clear_options    => 'clear',
  17         num_options      => 'count',
  18         delete_option    => 'delete',
  19         is_defined       => 'defined',
  20         options_elements => 'elements',
  21         has_option       => 'exists',
  22         get_option       => 'get',
  23         has_no_options   => 'is_empty',
  24         key_value        => 'kv',
  25         set_option       => 'set',
  26     );
  27
  28     my $name = 'Foo1';
  29
  30     sub build_class {
  31         my %attr = @_;
  32
  33         my $class = Moose::Meta::Class->create(
  34             $name++,
  35             superclasses => ['Moose::Object'],
  36         );
  37
  38         $class->add_attribute(
  39             options => (
  40                 traits  => ['Hash'],
  41                 is      => 'ro',
  42                 isa     => 'HashRef[Str]',
  43                 default => sub { {} },
  44                 handles => \%handles,
  45                 clearer => '_clear_options',
  46                 %attr,
  47             ),
  48         );
  49
  50         return ( $class->name, \%handles );
  51     }
  52 }
  53
  54 {
  55     run_tests(build_class);
  56     run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) );
  57
  58     # Will force the inlining code to check the entire hashref when it is modified.
  59     subtype 'MyHashRef', as 'HashRef[Str]', where { 1 };
  60
  61     run_tests( build_class( isa => 'MyHashRef' ) );
  62
  63     coerce 'MyHashRef', from 'HashRef', via { $_ };
  64
  65     run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) );
  66 }
  67
  68 sub run_tests {
  69     my ( $class, $handles ) = @_;
  70
  71     can_ok( $class, $_ ) for sort keys %{$handles};
  72
  73     with_immutable {
  74         my $obj = $class->new( options => {} );
  75
  76         ok( $obj->has_no_options, '... we have no options' );
  77         is( $obj->num_options, 0, '... we have no options' );
  78
  79         is_deeply( $obj->options, {}, '... no options yet' );
  80         ok( !$obj->has_option('foo'), '... we have no foo option' );
  81
  82         lives_ok {
  83             $obj->set_option( foo => 'bar' );
  84         }
  85         '... set the option okay';
  86
  87         ok( $obj->is_defined('foo'), '... foo is defined' );
  88
  89         ok( !$obj->has_no_options, '... we have options' );
  90         is( $obj->num_options, 1, '... we have 1 option(s)' );
  91         ok( $obj->has_option('foo'), '... we have a foo option' );
  92         is_deeply( $obj->options, { foo => 'bar' }, '... got options now' );
  93
  94         lives_ok {
  95             $obj->set_option( bar => 'baz' );
  96         }
  97         '... set the option okay';
  98
  99         is( $obj->num_options, 2, '... we have 2 option(s)' );
 100         is_deeply(
 101             $obj->options, { foo => 'bar', bar => 'baz' },
 102             '... got more options now'
 103         );
 104
 105         is( $obj->get_option('foo'), 'bar', '... got the right option' );
 106
 107         is_deeply(
 108             [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)],
 109             "get multiple options at once"
 110         );
 111
 112         is(
 113             scalar( $obj->get_option(qw( foo bar)) ), "baz",
 114             '... got last option in scalar context'
 115         );
 116
 117         lives_ok {
 118             $obj->set_option( oink => "blah", xxy => "flop" );
 119         }
 120         '... set the option okay';
 121
 122         is( $obj->num_options, 4, "4 options" );
 123         is_deeply(
 124             [ $obj->get_option(qw(foo bar oink xxy)) ],
 125             [qw(bar baz blah flop)], "get multiple options at once"
 126         );
 127
 128         lives_ok {
 129             $obj->delete_option('bar');
 130         }
 131         '... deleted the option okay';
 132
 133         lives_ok {
 134             $obj->delete_option( 'oink', 'xxy' );
 135         }
 136         '... deleted multiple option okay';
 137
 138         is( $obj->num_options, 1, '... we have 1 option(s)' );
 139         is_deeply(
 140             $obj->options, { foo => 'bar' },
 141             '... got more options now'
 142         );
 143
 144         $obj->clear_options;
 145
 146         is_deeply( $obj->options, {}, "... cleared options" );
 147
 148         lives_ok {
 149             $obj->quantity(4);
 150         }
 151         '... options added okay with defaults';
 152
 153         is( $obj->quantity, 4, 'reader part of curried accessor works' );
 154
 155         is_deeply(
 156             $obj->options, { quantity => 4 },
 157             '... returns what we expect'
 158         );
 159
 160         lives_ok {
 161             $class->new( options => { foo => 'BAR' } );
 162         }
 163         '... good constructor params';
 164
 165         dies_ok {
 166             $obj->set_option( bar => {} );
 167         }
 168         '... could not add a hash ref where an string is expected';
 169
 170         dies_ok {
 171             $class->new( options => { foo => [] } );
 172         }
 173         '... bad constructor params';
 174
 175         $obj->set_option( oink => "blah", xxy => "flop" );
 176         my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value;
 177         is_deeply(
 178             \@key_value,
 179             [
 180                 sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ],
 181                 [ 'quantity', 4 ],
 182                 [ 'oink',     'blah' ]
 183             ],
 184             '... got the right key value pairs'
 185             )
 186             or do {
 187             require Data::Dumper;
 188             diag( Data::Dumper::Dumper( \@key_value ) );
 189             };
 190
 191         my %options_elements = $obj->options_elements;
 192         is_deeply(
 193             \%options_elements, {
 194                 'oink'     => 'blah',
 195                 'quantity' => 4,
 196                 'xxy'      => 'flop'
 197             },
 198             '... got the right hash elements'
 199         );
 200
 201         if ( $class->meta->get_attribute('options')->is_lazy ) {
 202             my $obj = $class->new;
 203
 204             $obj->set_option( y => 2 );
 205
 206             is_deeply(
 207                 $obj->options, { x => 1, y => 2 },
 208                 'set_option with lazy default'
 209             );
 210
 211             $obj->_clear_options;
 212
 213             ok(
 214                 $obj->has_option('x'),
 215                 'key for x exists - lazy default'
 216             );
 217
 218             $obj->_clear_options;
 219
 220             ok(
 221                 $obj->is_defined('x'),
 222                 'key for x is defined - lazy default'
 223             );
 224
 225             $obj->_clear_options;
 226
 227             is_deeply(
 228                 [ $obj->key_value ],
 229                 [ [ x => 1 ] ],
 230                 'kv returns lazy default'
 231             );
 232         }
 233     }
 234     $class;
 235 }
 236
 237 done_testing;