t/088_attribute_triggers.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 40;
   7 use Test::Exception;
   8
   9 my $bar_set;
  10 my $baz_set;
  11 {
  12     package Foo;
  13     use metaclass;
  14
  15     sub new{
  16         my($class, @args) = @_;
  17         return $class->meta->new_object(@args);
  18     }
  19
  20    ::lives_ok{
  21         __PACKAGE__->meta->add_attribute('bar' =>
  22                       reader    => 'get_bar',
  23                       writer    => 'set_bar',
  24                       predicate => 'has_bar',
  25                       clearer   => 'clear_bar',
  26
  27                       trigger => sub {
  28                           my ($self, $bar) = @_;
  29                           $bar_set = $bar;
  30         });
  31     };
  32
  33    ::lives_ok{
  34        __PACKAGE__->meta->add_attribute('baz' =>
  35                      accessor  => 'baz',
  36                      predicate => 'has_baz',
  37                      clearer   => 'clear_baz',
  38                      trigger   => '_baz_set',
  39       );
  40    };
  41
  42    sub _baz_set {
  43        my ($self, $baz) = @_;
  44        $baz_set = $baz;
  45    }
  46 }
  47
  48 TEST:{
  49     my $foo = Foo->new(bar => '*bar*', baz => '*baz*');
  50
  51     isa_ok $foo, 'Foo';
  52
  53     is $foo->get_bar, '*bar*';
  54     is $foo->baz, '*baz*';
  55
  56     is $bar_set, '*bar*', 'trigger (CODE ref) on initialization';
  57     is $baz_set, '*baz*', 'trigger (method name) on initialization';
  58
  59     $foo->set_bar('_bar_');
  60     $foo->baz('_baz_');
  61
  62     is $foo->get_bar, '_bar_';
  63     is $foo->baz, '_baz_';
  64
  65     is $bar_set, '_bar_', 'trigger (CODE ref) on the writer';
  66     is $baz_set, '_baz_', 'trigger (method name) on the writer';
  67
  68     ok $foo->has_bar();
  69     ok $foo->has_baz();
  70
  71     is $bar_set, '_bar_', 'trigger (CODE ref) not called on the predicate';
  72     is $baz_set, '_baz_', 'trigger (method name) not called on the predicate';
  73
  74     $foo->clear_bar();
  75     $foo->clear_baz();
  76
  77     is $bar_set, undef, 'trigger (CODE ref) called on the clearer';
  78     is $baz_set, undef, 'trigger (method name) called on the clearer';
  79
  80     ok !$foo->has_bar();
  81     ok !$foo->has_baz();
  82
  83
  84     if($foo->meta->is_mutable){
  85         ok $foo->meta->make_immutable(replace_constructor => 1), 'make_immutable()';
  86         redo TEST;
  87     }
  88 }
  89
  90 # edge cases
  91 {
  92     package XXX;
  93     use metaclass;
  94
  95     ::throws_ok{
  96         __PACKAGE__->meta->add_attribute(fail =>
  97             trigger => {},
  98         );
  99     } qr/trigger/;
 100
 101     ::throws_ok{
 102         __PACKAGE__->meta->add_attribute(fail =>
 103             trigger => [],
 104         );
 105     } qr/trigger/;
 106
 107
 108     ::throws_ok{
 109         __PACKAGE__->meta->add_attribute(fail =>
 110             trigger => undef,
 111         );
 112     } qr/trigger/;
 113 }
 114