t/native_traits/trait_bool.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::More;
  12 use Test::Fatal;
  13 use Test::Moose;
  14
  15 {
  16     my %handles = (
  17         illuminate  => 'set',
  18         darken      => 'unset',
  19         flip_switch => 'toggle',
  20         is_dark     => 'not',
  21     );
  22
  23     my $name = 'Foo1';
  24
  25     sub build_class {
  26         my %attr = @_;
  27
  28         my $class = Moose::Meta::Class->create(
  29             $name++,
  30             superclasses => ['Moose::Object'],
  31         );
  32
  33         my @traits = 'Bool';
  34         push @traits, 'NoInlineAttribute'
  35             if delete $attr{no_inline};
  36
  37         $class->add_attribute(
  38             is_lit => (
  39                 traits  => \@traits,
  40                 is      => 'rw',
  41                 isa     => 'Bool',
  42                 default => 0,
  43                 handles => \%handles,
  44                 clearer => '_clear_is_list',
  45                 %attr,
  46             ),
  47         );
  48
  49         return ( $class->name, \%handles );
  50     }
  51 }
  52
  53 {
  54     run_tests(build_class);
  55     run_tests( build_class( lazy => 1 ) );
  56     run_tests( build_class( trigger => sub { } ) );
  57     run_tests( build_class( no_inline => 1 ) );
  58
  59     # Will force the inlining code to check the entire hashref when it is modified.
  60     subtype 'MyBool', as 'Bool', where { 1 };
  61
  62     run_tests( build_class( isa => 'MyBool' ) );
  63
  64     coerce 'MyBool', from 'Bool', via { $_ };
  65
  66     run_tests( build_class( isa => 'MyBool', coerce => 1 ) );
  67 }
  68
  69 sub run_tests {
  70     my ( $class, $handles ) = @_;
  71
  72     can_ok( $class, $_ ) for sort keys %{$handles};
  73
  74     with_immutable {
  75         my $obj = $class->new;
  76
  77         ok( $obj->illuminate, 'set returns true' );
  78         ok( $obj->is_lit,   'set is_lit to 1 using ->illuminate' );
  79         ok( !$obj->is_dark, 'check if is_dark does the right thing' );
  80
  81         like( exception { $obj->illuminate(1) }, qr/Cannot call set with any arguments/, 'set throws an error when an argument is passed' );
  82
  83         ok( !$obj->darken, 'unset returns false' );
  84         ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' );
  85         ok( $obj->is_dark, 'check if is_dark does the right thing' );
  86
  87         like( exception { $obj->darken(1) }, qr/Cannot call unset with any arguments/, 'unset throws an error when an argument is passed' );
  88
  89         ok( $obj->flip_switch, 'toggle returns new value' );
  90         ok( $obj->is_lit,   'toggle is_lit back to 1 using ->flip_switch' );
  91         ok( !$obj->is_dark, 'check if is_dark does the right thing' );
  92
  93         like( exception { $obj->flip_switch(1) }, qr/Cannot call toggle with any arguments/, 'toggle throws an error when an argument is passed' );
  94
  95         $obj->flip_switch;
  96         ok( !$obj->is_lit,
  97             'toggle is_lit back to 0 again using ->flip_switch' );
  98         ok( $obj->is_dark, 'check if is_dark does the right thing' );
  99     }
 100     $class;
 101 }
 102
 103 done_testing;