1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
use strict;
use warnings;
use Test::More tests => 18;
use Test::Exception;
use Scalar::Util qw/isweak/;
{
package Headers;
use Mouse;
has data => (
is => 'rw',
isa => 'Str',
);
no Mouse;
}
{
package Types;
use MouseX::Types -declare => [qw/Foo/];
use MouseX::Types::Mouse 'HashRef';
subtype Foo, as 'Headers';
coerce Foo,
from HashRef,
via {
Headers->new($_);
};
}
&main; exit;
sub construct {
my $class = shift;
eval <<"...";
package $class;
use Mouse;
BEGIN { Types->import('Foo') }
has bone => (
is => 'rw',
required => 1,
);
has foo => (
is => 'rw',
isa => Foo,
coerce => 1,
);
has weak_foo => (
is => 'rw',
weak_ref => 1,
);
has trigger_foo => (
is => 'rw',
trigger => sub { \$_[0]->bone('eat') },
);
sub BUILD { main::ok "calling BUILD in SoftDog" }
no Mouse;
...
die $@ if $@;
}
sub test {
my $class = shift;
lives_ok { $class->new(bone => 'moo') } "$class new";
throws_ok { $class->new() } qr/\QAttribute (bone) is required/;
is($class->new(bone => 'moo', foo => { data => 3 })->foo->data, 3);
my $foo = Headers->new();
ok(Scalar::Util::isweak($class->new(bone => 'moo', weak_foo => $foo)->{weak_foo}));
{
my $o = $class->new(bone => 'moo');
$o->trigger_foo($foo);
is($o->bone, 'eat');
}
}
sub main {
construct('SoftDog');
test('SoftDog');
construct('HardDog');
HardDog->meta->make_immutable;
test('HardDog');
}
|
