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 tests => 43;
   9 use Test::Exception;
  10
  11 BEGIN {
  12     use_ok('Moose');
  13 }
  14
  15 {
  16     package Foo;
  17     use Moose;
  18
  19     has 'bar' => (is      => 'rw',
  20                   isa     => 'Maybe[Bar]',
  21                   trigger => sub {
  22                       my ($self, $bar) = @_;
  23                       $bar->foo($self) if defined $bar;
  24                   });
  25
  26     has 'baz' => (writer => 'set_baz',
  27                   reader => 'get_baz',
  28                   isa    => 'Baz',
  29                   trigger => sub {
  30                       my ($self, $baz) = @_;
  31                       $baz->foo($self);
  32                   });
  33
  34
  35     package Bar;
  36     use Moose;
  37
  38     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
  39
  40     package Baz;
  41     use Moose;
  42
  43     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
  44 }
  45
  46 {
  47     my $foo = Foo->new;
  48     isa_ok($foo, 'Foo');
  49
  50     my $bar = Bar->new;
  51     isa_ok($bar, 'Bar');
  52
  53     my $baz = Baz->new;
  54     isa_ok($baz, 'Baz');
  55
  56     lives_ok {
  57         $foo->bar($bar);
  58     } '... did not die setting bar';
  59
  60     is($foo->bar, $bar, '... set the value foo.bar correctly');
  61     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
  62
  63     ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
  64
  65     lives_ok {
  66         $foo->bar(undef);
  67     } '... did not die un-setting bar';
  68
  69     is($foo->bar, undef, '... set the value foo.bar correctly');
  70     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
  71
  72     # test the writer
  73
  74     lives_ok {
  75         $foo->set_baz($baz);
  76     } '... did not die setting baz';
  77
  78     is($foo->get_baz, $baz, '... set the value foo.baz correctly');
  79     is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
  80
  81     ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
  82 }
  83
  84 {
  85     my $bar = Bar->new;
  86     isa_ok($bar, 'Bar');
  87
  88     my $baz = Baz->new;
  89     isa_ok($baz, 'Baz');
  90
  91     my $foo = Foo->new(bar => $bar, baz => $baz);
  92     isa_ok($foo, 'Foo');
  93
  94     is($foo->bar, $bar, '... set the value foo.bar correctly');
  95     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
  96
  97     ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
  98
  99     is($foo->get_baz, $baz, '... set the value foo.baz correctly');
 100     is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
 101
 102     ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
 103 }
 104
 105 # before/around/after triggers
 106 {
 107     package Fweet;
 108     use Moose;
 109
 110     has calls => (
 111         is      => 'ro',
 112         isa     => 'ArrayRef',
 113         default => sub {[]},
 114     );
 115
 116     sub called {
 117         my ($self, $str, @args) = @_;
 118         push(@{$self->calls}, $str);
 119     }
 120
 121     has noise => (
 122         is => 'rw',
 123         default => 'Sartak',
 124         trigger => {
 125             before => sub {
 126                 $_[0]->called('before');
 127             },
 128             around => sub {
 129                 my ($ori, $self, $val, @whatever) = @_;
 130                 $self->called('around');
 131                 $ori->($self, $val.'-diddly', @whatever);
 132             },
 133             after => sub {
 134                 $_[0]->called('after');
 135             },
 136         },
 137     );
 138 }
 139
 140 sub fancy_trigger_tests
 141 {
 142     my $type = shift;
 143     my $blah;
 144     ::lives_ok {
 145         $blah = Fweet->new;
 146     } "... $type constructor";
 147     my $expected_calls = [qw(before around after)];
 148
 149     is_deeply($blah->calls, $expected_calls, "$type default triggered");
 150     is($blah->noise, 'Sartak-diddly', "$type default around modified value");
 151     @{$blah->calls} = ();
 152
 153     $blah->noise('argle-bargle');
 154     is_deeply($blah->calls, $expected_calls, "$type set triggered");
 155     is($blah->noise, 'argle-bargle-diddly', "$type set around modified value");
 156
 157     $blah = Fweet->new(noise => 'woot');
 158     is_deeply($blah->calls, $expected_calls, "$type constructor triggered");
 159     is($blah->noise, 'woot-diddly', "$type constructor around modified value");
 160 }
 161
 162 {
 163   fancy_trigger_tests('normal');
 164   ::lives_ok {
 165     Fweet->meta->make_immutable;
 166   } '... make_immutable works';
 167   fancy_trigger_tests('inline');
 168 }
 169
 170 # some errors
 171
 172 {
 173     package Bling;
 174     use Moose;
 175
 176     ::dies_ok {
 177         has('bling' => (is => 'rw', trigger => {FAIL => sub {}}));
 178     } '... hash specifier has to be before/around/after';
 179
 180     ::dies_ok {
 181         has('bling' => (is => 'rw', trigger => {around => 'FAIL'}));
 182     } '... hash specifier value must be CODE ref';
 183
 184     ::dies_ok {
 185         has('bling' => (is => 'rw', trigger => 'Fail'));
 186     } '... a trigger must be a CODE or HASH ref';
 187
 188     ::dies_ok {
 189         has('bling' => (is => 'rw', trigger => []));
 190     } '... a trigger must be a CODE or HASH ref';
 191 }
 192
 193