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