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