t/016-trigger.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 21;
   5 use Test::Exception;
   6
   7 my @trigger;
   8
   9 do {
  10     package Class;
  11     use Mouse;
  12
  13     has attr => (
  14         is => 'rw',
  15         default => 10,
  16         trigger => sub {
  17             my ($self, $value, $attr) = @_;
  18             push @trigger, [$self, $value, $attr];
  19         },
  20     );
  21
  22     ::lives_ok {
  23         has not_error => (
  24             is => 'ro',
  25             trigger => sub { },
  26         );
  27     } "it's no longer an error to have trigger on a readonly attribute";
  28
  29     ::throws_ok {
  30         has error => (
  31             is => 'ro',
  32             trigger => [],
  33         );
  34     } qr/Trigger must be a CODE ref on attribute \(error\)/;
  35 };
  36
  37 can_ok(Class => 'attr');
  38
  39 my $object = Class->new;
  40 is(@trigger, 0, "trigger not called yet");
  41
  42 is($object->attr, 10, "default value");
  43 is(@trigger, 0, "trigger not called on read");
  44
  45 is($object->attr(50), 50, "setting the value");
  46 is(@trigger, 1, "trigger was called on read");
  47 is_deeply([splice @trigger], [[$object, 50, $object->meta->get_attribute('attr')]], "correct arguments to trigger in the accessor");
  48
  49 my $object2 = Class->new(attr => 100);
  50 is(@trigger, 1, "trigger was called on new with the attribute specified");
  51 is_deeply([splice @trigger], [[$object2, 100, $object2->meta->get_attribute('attr')]], "correct arguments to trigger in the constructor");
  52
  53 do {
  54     package Parent;
  55     use Mouse;
  56
  57     has attr => (
  58         is      => 'rw',
  59         trigger => {
  60             before => sub {
  61                 push @trigger, ['before', @_];
  62             },
  63             after => sub {
  64                 push @trigger, ['after', @_];
  65             },
  66             around => sub {
  67                 my $code = shift;
  68                 my ($self, $value, $attr) = @_;
  69
  70                 push @trigger, ['around-before', $self, $value, $attr];
  71                 $code->($self, 4 * $value, $attr);
  72                 push @trigger, ['around-after', $self, $value, $attr];
  73             },
  74         },
  75     );
  76
  77     package Child;
  78     use Mouse;
  79     extends 'Parent';
  80
  81     has '+attr' => (
  82         default => 10,
  83     );
  84 };
  85
  86 my $child = Child->new;
  87 is(@trigger, 0, "trigger not called on constructor with default");
  88
  89 is($child->attr, 10, "reader");
  90 is(@trigger, 0, "trigger not called on reader");
  91
  92 is($child->attr(5), 20, "writer");
  93 is_deeply([splice @trigger], [
  94     ['before',        $child,  5, Child->meta->get_attribute('attr')],
  95     ['around-before', $child,  5, Child->meta->get_attribute('attr')],
  96     ['around-after',  $child,  5, Child->meta->get_attribute('attr')],
  97     ['after',         $child, 20, Child->meta->get_attribute('attr')],
  98 ]);
  99
 100 my $parent = Parent->new(attr => 2);
 101 is_deeply([splice @trigger], [
 102     ['before',        $parent, 2, Parent->meta->get_attribute('attr')],
 103     ['around-before', $parent, 2, Parent->meta->get_attribute('attr')],
 104     ['around-after',  $parent, 2, Parent->meta->get_attribute('attr')],
 105     ['after',         $parent, 8, Parent->meta->get_attribute('attr')],
 106 ]);
 107
 108 is($parent->attr, 8, "reader");
 109 is(@trigger, 0, "trigger not called on reader");
 110
 111 is($parent->attr(10), 40, "writer");
 112 is_deeply([splice @trigger], [
 113     ['before',        $parent, 10, Parent->meta->get_attribute('attr')],
 114     ['around-before', $parent, 10, Parent->meta->get_attribute('attr')],
 115     ['around-after',  $parent, 10, Parent->meta->get_attribute('attr')],
 116     ['after',         $parent, 40, Parent->meta->get_attribute('attr')],
 117 ]);
 118