t/020_attributes/004_attribute_triggers.t

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