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 => 25;
   9 use Test::Exception;
  10
  11
  12
  13 {
  14     package Foo;
  15     use Moose;
  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 Moose;
  35
  36     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
  37
  38     package Baz;
  39     use Moose;
  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 Moose;
 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