t/native_traits/trait_counter.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::Fatal;
  12 use Test::More;
  13 use Test::Moose;
  14
  15 {
  16     my %handles = (
  17         inc_counter    => 'inc',
  18         inc_counter_2  => [ inc => 2 ],
  19         dec_counter    => 'dec',
  20         dec_counter_2  => [ dec => 2 ],
  21         reset_counter  => 'reset',
  22         set_counter    => 'set',
  23         set_counter_42 => [ set => 42 ],
  24     );
  25
  26     my $name = 'Foo1';
  27
  28     sub build_class {
  29         my %attr = @_;
  30
  31         my $class = Moose::Meta::Class->create(
  32             $name++,
  33             superclasses => ['Moose::Object'],
  34         );
  35
  36         my @traits = 'Counter';
  37         push @traits, 'NoInlineAttribute'
  38             if delete $attr{no_inline};
  39
  40         $class->add_attribute(
  41             counter => (
  42                 traits  => \@traits,
  43                 is      => 'ro',
  44                 isa     => 'Int',
  45                 default => 0,
  46                 handles => \%handles,
  47                 clearer => '_clear_counter',
  48                 %attr,
  49             ),
  50         );
  51
  52         return ( $class->name, \%handles );
  53     }
  54 }
  55
  56 {
  57     run_tests(build_class);
  58     run_tests( build_class( lazy => 1 ) );
  59     run_tests( build_class( trigger => sub { } ) );
  60     run_tests( build_class( no_inline => 1 ) );
  61
  62     # Will force the inlining code to check the entire hashref when it is modified.
  63     subtype 'MyInt', as 'Int', where { 1 };
  64
  65     run_tests( build_class( isa => 'MyInt' ) );
  66
  67     coerce 'MyInt', from 'Int', via { $_ };
  68
  69     run_tests( build_class( isa => 'MyInt', coerce => 1 ) );
  70 }
  71
  72 sub run_tests {
  73     my ( $class, $handles ) = @_;
  74
  75     can_ok( $class, $_ ) for sort keys %{$handles};
  76
  77     with_immutable {
  78         my $obj = $class->new();
  79
  80         is( $obj->counter, 0, '... got the default value' );
  81
  82         is( $obj->inc_counter, 1, 'inc returns new value' );
  83         is( $obj->counter, 1, '... got the incremented value' );
  84
  85         is( $obj->inc_counter, 2, 'inc returns new value' );
  86         is( $obj->counter, 2, '... got the incremented value (again)' );
  87
  88         like( exception { $obj->inc_counter( 1, 2 ) }, qr/Cannot call inc with more than 1 argument/, 'inc throws an error when two arguments are passed' );
  89
  90         is( $obj->dec_counter, 1, 'dec returns new value' );
  91         is( $obj->counter, 1, '... got the decremented value' );
  92
  93         like( exception { $obj->dec_counter( 1, 2 ) }, qr/Cannot call dec with more than 1 argument/, 'dec throws an error when two arguments are passed' );
  94
  95         is( $obj->reset_counter, 0, 'reset returns new value' );
  96         is( $obj->counter, 0, '... got the original value' );
  97
  98         like( exception { $obj->reset_counter(2) }, qr/Cannot call reset with any arguments/, 'reset throws an error when an argument is passed' );
  99
 100         is( $obj->set_counter(5), 5, 'set returns new value' );
 101         is( $obj->counter, 5, '... set the value' );
 102
 103         like( exception { $obj->set_counter( 1, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when two arguments are passed' );
 104
 105         $obj->inc_counter(2);
 106         is( $obj->counter, 7, '... increment by arg' );
 107
 108         $obj->dec_counter(5);
 109         is( $obj->counter, 2, '... decrement by arg' );
 110
 111         $obj->inc_counter_2;
 112         is( $obj->counter, 4, '... curried increment' );
 113
 114         $obj->dec_counter_2;
 115         is( $obj->counter, 2, '... curried deccrement' );
 116
 117         $obj->set_counter_42;
 118         is( $obj->counter, 42, '... curried set' );
 119
 120         if ( $class->meta->get_attribute('counter')->is_lazy ) {
 121             my $obj = $class->new;
 122
 123             $obj->inc_counter;
 124             is( $obj->counter, 1, 'inc increments - with lazy default' );
 125
 126             $obj->_clear_counter;
 127
 128             $obj->dec_counter;
 129             is( $obj->counter, -1, 'dec decrements - with lazy default' );
 130         }
 131     }
 132     $class;
 133 }
 134
 135 {
 136     package WithBuilder;
 137     use Moose;
 138
 139     has nonlazy => (
 140         traits  => ['Counter'],
 141         is      => 'rw',
 142         isa     => 'Int',
 143         builder => '_builder',
 144         handles => {
 145             reset_nonlazy => 'reset',
 146         },
 147     );
 148
 149     has lazy => (
 150         traits  => ['Counter'],
 151         is      => 'rw',
 152         isa     => 'Int',
 153         lazy    => 1,
 154         builder => '_builder',
 155         handles => {
 156             reset_lazy => 'reset',
 157         },
 158     );
 159
 160     sub _builder { 1 }
 161 }
 162
 163 for my $attr ('lazy', 'nonlazy') {
 164     my $obj = WithBuilder->new;
 165     is($obj->$attr, 1, "built properly");
 166     $obj->$attr(0);
 167     is($obj->$attr, 0, "can be manually set");
 168     $obj->${\"reset_$attr"};
 169     is($obj->$attr, 1, "reset resets it to its default value");
 170 }
 171
 172 done_testing;