Added a new test, essentially the code posted in RT bug #42992. It
[gitmo/Mouse.git] / t / 016-trigger.t
1 #!/usr/bin/env perl
2 use strict;
3 use warnings;
4 use Test::More tests => 11;
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