t/033_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 => 27;
   9 use Test::Exception;
  10
  11 BEGIN {
  12     use_ok('Moose');
  13 }
  14
  15 {
  16     package Foo;
  17     use strict;
  18     use warnings;
  19     use Moose;
  20
  21     has 'bar' => (is      => 'rw',
  22                   isa     => 'Bar',
  23                   trigger => sub {
  24                       my ($self, $bar) = @_;
  25                       $bar->foo($self) if defined $bar;
  26                   });
  27
  28     has 'baz' => (writer => 'set_baz',
  29                   reader => 'get_baz',
  30                   isa    => 'Baz',
  31                   trigger => sub {
  32                       my ($self, $baz) = @_;
  33                       $baz->foo($self);
  34                   });
  35
  36
  37     package Bar;
  38     use strict;
  39     use warnings;
  40     use Moose;
  41
  42     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
  43
  44     package Baz;
  45     use strict;
  46     use warnings;
  47     use Moose;
  48
  49     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
  50 }
  51
  52 {
  53     my $foo = Foo->new;
  54     isa_ok($foo, 'Foo');
  55
  56     my $bar = Bar->new;
  57     isa_ok($bar, 'Bar');
  58
  59     my $baz = Baz->new;
  60     isa_ok($baz, 'Baz');
  61
  62     lives_ok {
  63         $foo->bar($bar);
  64     } '... did not die setting bar';
  65
  66     is($foo->bar, $bar, '... set the value foo.bar correctly');
  67     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
  68
  69     ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
  70
  71     lives_ok {
  72         $foo->bar(undef);
  73     } '... did not die un-setting bar';
  74
  75     is($foo->bar, undef, '... set the value foo.bar correctly');
  76     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
  77
  78     # test the writer
  79
  80     lives_ok {
  81         $foo->set_baz($baz);
  82     } '... did not die setting baz';
  83
  84     is($foo->get_baz, $baz, '... set the value foo.baz correctly');
  85     is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
  86
  87     ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
  88 }
  89
  90 {
  91     my $bar = Bar->new;
  92     isa_ok($bar, 'Bar');
  93
  94     my $baz = Baz->new;
  95     isa_ok($baz, 'Baz');
  96
  97     my $foo = Foo->new(bar => $bar, baz => $baz);
  98     isa_ok($foo, 'Foo');
  99
 100     is($foo->bar, $bar, '... set the value foo.bar correctly');
 101     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
 102
 103     ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
 104
 105     is($foo->get_baz, $baz, '... set the value foo.baz correctly');
 106     is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
 107
 108     ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
 109 }
 110
 111 # some errors
 112
 113 {
 114     package Bling;
 115     use strict;
 116     use warnings;
 117     use Moose;
 118
 119     ::dies_ok {
 120         has('bling' => (is => 'ro', trigger => sub { 0 }));
 121     } '... cannot create trigger on a read-only attr';
 122 }
 123
 124 {
 125     package Bling::Bling;
 126     use strict;
 127     use warnings;
 128     use Moose;
 129
 130     ::dies_ok {
 131         has('bling' => (is => 'rw', trigger => 'Fail'));
 132     } '... a trigger must be a CODE ref';
 133
 134     ::dies_ok {
 135         has('bling' => (is => 'rw', trigger => []));
 136     } '... a trigger must be a CODE ref';
 137 }
 138
 139