Commit | Line | Data |
e3c07b19 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
8b9641b8 |
6 | use lib 't/lib'; |
7 | |
26a79215 |
8 | use Moose (); |
2c963694 |
9 | use Moose::Util::TypeConstraints; |
8b9641b8 |
10 | use NoInlineAttribute; |
a28e50e4 |
11 | use Test::More; |
b10dde3a |
12 | use Test::Fatal; |
26a79215 |
13 | use Test::Moose; |
e3c07b19 |
14 | |
15 | { |
26a79215 |
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 | |
8b9641b8 |
33 | my @traits = 'Bool'; |
34 | push @traits, 'NoInlineAttribute' |
35 | if delete $attr{no_inline}; |
36 | |
26a79215 |
37 | $class->add_attribute( |
38 | is_lit => ( |
8b9641b8 |
39 | traits => \@traits, |
26a79215 |
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 ) ); |
cf0da4e2 |
56 | run_tests( build_class( trigger => sub { } ) ); |
8b9641b8 |
57 | run_tests( build_class( no_inline => 1 ) ); |
2c963694 |
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 ) ); |
e3c07b19 |
67 | } |
68 | |
26a79215 |
69 | sub run_tests { |
70 | my ( $class, $handles ) = @_; |
e3c07b19 |
71 | |
26a79215 |
72 | can_ok( $class, $_ ) for sort keys %{$handles}; |
e3c07b19 |
73 | |
26a79215 |
74 | with_immutable { |
75 | my $obj = $class->new; |
e3c07b19 |
76 | |
7f5ec80d |
77 | ok( $obj->illuminate, 'set returns true' ); |
26a79215 |
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 | |
b10dde3a |
81 | like( exception { $obj->illuminate(1) }, qr/Cannot call set with any arguments/, 'set throws an error when an argument is passed' ); |
26a79215 |
82 | |
7f5ec80d |
83 | ok( !$obj->darken, 'unset returns false' ); |
26a79215 |
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 | |
b10dde3a |
87 | like( exception { $obj->darken(1) }, qr/Cannot call unset with any arguments/, 'unset throws an error when an argument is passed' ); |
26a79215 |
88 | |
7f5ec80d |
89 | ok( $obj->flip_switch, 'toggle returns new value' ); |
26a79215 |
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 | |
b10dde3a |
93 | like( exception { $obj->flip_switch(1) }, qr/Cannot call toggle with any arguments/, 'toggle throws an error when an argument is passed' ); |
26a79215 |
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 | } |
e3c07b19 |
102 | |
a28e50e4 |
103 | done_testing; |