t/070_native_traits/060_trait_number.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         abs         => 'abs',
  18         add         => 'add',
  19         inc         => [ add => 1 ],
  20         div         => 'div',
  21         cut_in_half => [ div => 2 ],
  22         mod         => 'mod',
  23         odd         => [ mod => 2 ],
  24         mul         => 'mul',
  25         set         => 'set',
  26         sub         => 'sub',
  27         dec         => [ sub => 1 ],
  28     );
  29
  30     my $name = 'Foo1';
  31
  32     sub build_class {
  33         my %attr = @_;
  34
  35         my $class = Moose::Meta::Class->create(
  36             $name++,
  37             superclasses => ['Moose::Object'],
  38         );
  39
  40         my @traits = 'Number';
  41         push @traits, 'NoInlineAttribute'
  42             if delete $attr{no_inline};
  43
  44         $class->add_attribute(
  45             integer => (
  46                 traits  => \@traits,
  47                 is      => 'ro',
  48                 isa     => 'Int',
  49                 default => 5,
  50                 handles => \%handles,
  51                 clearer => '_clear_integer',
  52                 %attr,
  53             ),
  54         );
  55
  56         return ( $class->name, \%handles );
  57     }
  58 }
  59
  60 {
  61     run_tests(build_class);
  62     run_tests( build_class( lazy => 1 ) );
  63     run_tests( build_class( trigger => sub { } ) );
  64     run_tests( build_class( no_inline => 1 ) );
  65
  66     # Will force the inlining code to check the entire hashref when it is modified.
  67     subtype 'MyInt', as 'Int', where { 1 };
  68
  69     run_tests( build_class( isa => 'MyInt' ) );
  70
  71     coerce 'MyInt', from 'Int', via { $_ };
  72
  73     run_tests( build_class( isa => 'MyInt', coerce => 1 ) );
  74 }
  75
  76 sub run_tests {
  77     my ( $class, $handles ) = @_;
  78
  79     can_ok( $class, $_ ) for sort keys %{$handles};
  80
  81     with_immutable {
  82         my $obj = $class->new;
  83
  84         is( $obj->integer, 5, 'Default to five' );
  85
  86         is( $obj->add(10), 15, 'add returns new value' );
  87
  88         is( $obj->integer, 15, 'Add ten for fithteen' );
  89
  90         like( exception { $obj->add( 10, 2 ) }, qr/Cannot call add with more than 1 argument/, 'add throws an error when 2 arguments are passed' );
  91
  92         is( $obj->sub(3), 12, 'sub returns new value' );
  93
  94         is( $obj->integer, 12, 'Subtract three for 12' );
  95
  96         like( exception { $obj->sub( 10, 2 ) }, qr/Cannot call sub with more than 1 argument/, 'sub throws an error when 2 arguments are passed' );
  97
  98         is( $obj->set(10), 10, 'set returns new value' );
  99
 100         is( $obj->integer, 10, 'Set to ten' );
 101
 102         like( exception { $obj->set( 10, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when 2 arguments are passed' );
 103
 104         is( $obj->div(2), 5, 'div returns new value' );
 105
 106         is( $obj->integer, 5, 'divide by 2' );
 107
 108         like( exception { $obj->div( 10, 2 ) }, qr/Cannot call div with more than 1 argument/, 'div throws an error when 2 arguments are passed' );
 109
 110         is( $obj->mul(2), 10, 'mul returns new value' );
 111
 112         is( $obj->integer, 10, 'multiplied by 2' );
 113
 114         like( exception { $obj->mul( 10, 2 ) }, qr/Cannot call mul with more than 1 argument/, 'mul throws an error when 2 arguments are passed' );
 115
 116         is( $obj->mod(2), 0, 'mod returns new value' );
 117
 118         is( $obj->integer, 0, 'Mod by 2' );
 119
 120         like( exception { $obj->mod( 10, 2 ) }, qr/Cannot call mod with more than 1 argument/, 'mod throws an error when 2 arguments are passed' );
 121
 122         $obj->set(7);
 123
 124         $obj->mod(5);
 125
 126         is( $obj->integer, 2, 'Mod by 5' );
 127
 128         $obj->set(-1);
 129
 130         is( $obj->abs, 1, 'abs returns new value' );
 131
 132         like( exception { $obj->abs(10) }, qr/Cannot call abs with any arguments/, 'abs throws an error when an argument is passed' );
 133
 134         is( $obj->integer, 1, 'abs 1' );
 135
 136         $obj->set(12);
 137
 138         $obj->inc;
 139
 140         is( $obj->integer, 13, 'inc 12' );
 141
 142         $obj->dec;
 143
 144         is( $obj->integer, 12, 'dec 13' );
 145
 146         if ( $class->meta->get_attribute('integer')->is_lazy ) {
 147             my $obj = $class->new;
 148
 149             $obj->add(2);
 150
 151             is( $obj->integer, 7, 'add with lazy default' );
 152
 153             $obj->_clear_integer;
 154
 155             $obj->mod(2);
 156
 157             is( $obj->integer, 1, 'mod with lazy default' );
 158         }
 159     }
 160     $class;
 161 }
 162
 163 done_testing;