t/016-trigger.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 10;
   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     ::throws_ok {
  23         has error => (
  24             is => 'ro',
  25             trigger => sub { },
  26         );
  27     } qr/Trigger is not allowed on read-only attribute 'error'/;
  28 };
  29
  30 can_ok(Class => 'attr');
  31
  32 my $object = Class->new;
  33 is(@trigger, 0, "trigger not called yet");
  34
  35 is($object->attr, 10, "default value");
  36 is(@trigger, 0, "trigger not called on read");
  37
  38 is($object->attr(50), 50, "setting the value");
  39 is(@trigger, 1, "trigger was called on read");
  40 is_deeply(shift(@trigger), [$object, 50, $object->meta->get_attribute('attr')], "correct arguments to trigger in the accessor");
  41
  42 my $object2 = Class->new(attr => 100);
  43 is(@trigger, 1, "trigger was called on new with the attribute specified");
  44 is_deeply(shift(@trigger), [$object2, 100, $object2->meta->get_attribute('attr')], "correct arguments to trigger in the constructor");
  45