t/020_attributes/failing/004_attribute_triggers.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Scalar::Util 'isweak';
   7
   8 use Test::More tests => 43;
   9 use Test::Exception;
  10
  11
  12
  13 {
  14     package Foo;
  15     use Mouse;
  16
  17     has 'bar' => (is      => 'rw',
  18                   isa     => 'Maybe[Bar]',
  19                   trigger => sub {
  20                       my ($self, $bar) = @_;
  21                       $bar->foo($self) if defined $bar;
  22                   });
  23
  24     has 'baz' => (writer => 'set_baz',
  25                   reader => 'get_baz',
  26                   isa    => 'Baz',
  27                   trigger => sub {
  28                       my ($self, $baz) = @_;
  29                       $baz->foo($self);
  30                   });
  31
  32
  33     package Bar;
  34     use Mouse;
  35
  36     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
  37
  38     package Baz;
  39     use Mouse;
  40
  41     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
  42 }
  43
  44 {
  45     my $foo = Foo->new;
  46     isa_ok($foo, 'Foo');
  47
  48     my $bar = Bar->new;
  49     isa_ok($bar, 'Bar');
  50
  51     my $baz = Baz->new;
  52     isa_ok($baz, 'Baz');
  53
  54     lives_ok {
  55         $foo->bar($bar);
  56     } '... did not die setting bar';
  57
  58     is($foo->bar, $bar, '... set the value foo.bar correctly');
  59     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
  60
  61     ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
  62
  63     lives_ok {
  64         $foo->bar(undef);
  65     } '... did not die un-setting bar';
  66
  67     is($foo->bar, undef, '... set the value foo.bar correctly');
  68     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
  69
  70     # test the writer
  71
  72     lives_ok {
  73         $foo->set_baz($baz);
  74     } '... did not die setting baz';
  75
  76     is($foo->get_baz, $baz, '... set the value foo.baz correctly');
  77     is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
  78
  79     ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
  80 }
  81
  82 {
  83     my $bar = Bar->new;
  84     isa_ok($bar, 'Bar');
  85
  86     my $baz = Baz->new;
  87     isa_ok($baz, 'Baz');
  88
  89     my $foo = Foo->new(bar => $bar, baz => $baz);
  90     isa_ok($foo, 'Foo');
  91
  92     is($foo->bar, $bar, '... set the value foo.bar correctly');
  93     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
  94
  95     ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
  96
  97     is($foo->get_baz, $baz, '... set the value foo.baz correctly');
  98     is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
  99
 100     ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
 101 }
 102
 103 # some errors
 104
 105 {
 106     package Bling;
 107     use Mouse;
 108
 109     ::dies_ok {
 110         has('bling' => (is => 'rw', trigger => 'Fail'));
 111     } '... a trigger must be a CODE ref';
 112
 113     ::dies_ok {
 114         has('bling' => (is => 'rw', trigger => []));
 115     } '... a trigger must be a CODE ref';
 116 }
 117
 118 # Triggers do not fire on built values
 119
 120 {
 121     package Blarg;
 122     use Mouse;
 123
 124     our %trigger_calls;
 125     our %trigger_vals;
 126     has foo => (is => 'rw', default => sub { 'default foo value' },
 127                 trigger => sub { my ($self, $val, $attr) = @_;
 128                                  $trigger_calls{foo}++;
 129                                  $trigger_vals{foo} = $val });
 130     has bar => (is => 'rw', lazy_build => 1,
 131                 trigger => sub { my ($self, $val, $attr) = @_;
 132                                  $trigger_calls{bar}++;
 133                                  $trigger_vals{bar} = $val });
 134     sub _build_bar { return 'default bar value' }
 135     has baz => (is => 'rw', builder => '_build_baz',
 136                 trigger => sub { my ($self, $val, $attr) = @_;
 137                                  $trigger_calls{baz}++;
 138                                  $trigger_vals{baz} = $val });
 139     sub _build_baz { return 'default baz value' }
 140 }
 141
 142 {
 143     my $blarg;
 144     lives_ok { $blarg = Blarg->new; } 'Blarg->new() lives';
 145     ok($blarg, 'Have a $blarg');
 146     foreach my $attr (qw/foo bar baz/) {
 147         is($blarg->$attr(), "default $attr value", "$attr has default value");
 148     }
 149     is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired');
 150     foreach my $attr (qw/foo bar baz/) {
 151         $blarg->$attr("Different $attr value");
 152     }
 153     is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign');
 154     is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
 155
 156     lives_ok { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) } '->new() with parameters';
 157     is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct');
 158     is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
 159 }
 160
 161 # Triggers do not receive the meta-attribute as an argument, but do
 162 # receive the old value
 163
 164 {
 165     package Foo;
 166     use Mouse;
 167     our @calls;
 168     has foo => (is => 'rw', trigger => sub { push @calls, [@_] });
 169 }
 170
 171 {
 172     my $attr = Foo->meta->get_attribute('foo');
 173
 174     my $foo = Foo->new;
 175     $attr->set_value( $foo, 2 );
 176
 177     is_deeply(
 178         \@Foo::calls,
 179         [ [ $foo, 2 ] ],
 180         'trigger called correctly on initial set via meta-API',
 181     );
 182     @Foo::calls = ();
 183
 184     $attr->set_value( $foo, 3 );
 185
 186     is_deeply(
 187         \@Foo::calls,
 188         [ [ $foo, 3, 2 ] ],
 189         'trigger called correctly on second set via meta-API',
 190     );
 191     @Foo::calls = ();
 192
 193     $attr->set_raw_value( $foo, 4 );
 194
 195     is_deeply(
 196         \@Foo::calls,
 197         [ ],
 198         'trigger not called using set_raw_value method',
 199     );
 200     @Foo::calls = ();
 201 }
 202
 203 {
 204     my $foo = Foo->new(foo => 2);
 205     is_deeply(
 206         \@Foo::calls,
 207         [ [ $foo, 2 ] ],
 208         'trigger called correctly on construction',
 209     );
 210     @Foo::calls = ();
 211
 212     $foo->foo(3);
 213     is_deeply(
 214         \@Foo::calls,
 215         [ [ $foo, 3, 2 ] ],
 216         'trigger called correctly on set (with old value)',
 217     );
 218     @Foo::calls = ();
 219     Foo->meta->make_immutable, redo if Foo->meta->is_mutable;
 220 }
 221
 222