t/016-trigger.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 16;
   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 or HASH 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 Class2;
  55     use Mouse;
  56
  57     has attr => (
  58         is      => 'rw',
  59         default => 10,
  60         trigger => {
  61             before => sub {
  62                 push @trigger, ['before', @_];
  63             },
  64             after => sub {
  65                 push @trigger, ['after', @_];
  66             },
  67             around => sub {
  68                 my $code = shift;
  69                 my ($self, $value, $attr) = @_;
  70
  71                 push @trigger, ['around-before', $self, $value, $attr];
  72                 $code->($self, 4 * $value, $attr);
  73                 push @trigger, ['around-after', $self, $value, $attr];
  74             },
  75         },
  76     );
  77 };
  78
  79 my $o2 = Class2->new;
  80 is(@trigger, 0, "trigger not called on constructor with default");
  81
  82 is($o2->attr, 10, "reader");
  83 is(@trigger, 0, "trigger not called on reader");
  84
  85 is($o2->attr(5), 20, "writer");
  86 is_deeply([splice @trigger], [
  87     ['before',        $o2,  5, $o2->meta->get_attribute('attr')],
  88     ['around-before', $o2,  5, $o2->meta->get_attribute('attr')],
  89     ['around-after',  $o2,  5, $o2->meta->get_attribute('attr')],
  90     ['after',         $o2, 20, $o2->meta->get_attribute('attr')],
  91 ]);
  92