Commit | Line | Data |
4c98ebb0 |
1 | #!/usr/bin/perl |
c47cf415 |
2 | # This is automatically generated by author/import-moose-test.pl. |
3 | # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!! |
4 | use t::lib::MooseCompat; |
4c98ebb0 |
5 | |
6 | use strict; |
7 | use warnings; |
8 | |
c47cf415 |
9 | use Test::More; |
10 | $TODO = q{Mouse is not yet completed}; |
4c98ebb0 |
11 | use Test::Exception; |
12 | |
13 | { |
14 | package Foo; |
15 | |
16 | sub new { |
17 | bless({}, 'Foo') |
18 | } |
19 | |
20 | sub a { 'Foo::a' } |
21 | } |
22 | |
23 | { |
24 | package Bar; |
25 | use Mouse; |
26 | |
27 | ::lives_ok { |
28 | has 'baz' => ( |
29 | is => 'ro', |
30 | isa => 'Foo', |
31 | lazy => 1, |
32 | default => sub { Foo->new() }, |
33 | handles => qr/^a$/, |
34 | ); |
35 | } '... can create the attribute with delegations'; |
36 | |
37 | } |
38 | |
39 | my $bar; |
40 | lives_ok { |
41 | $bar = Bar->new; |
42 | } '... created the object ok'; |
43 | isa_ok($bar, 'Bar'); |
44 | |
45 | is($bar->a, 'Foo::a', '... got the right delgated value'); |
46 | |
47 | my @w; |
48 | $SIG{__WARN__} = sub { push @w, "@_" }; |
49 | { |
50 | package Baz; |
51 | use Mouse; |
52 | |
53 | ::lives_ok { |
54 | has 'bar' => ( |
55 | is => 'ro', |
56 | isa => 'Foo', |
57 | lazy => 1, |
58 | default => sub { Foo->new() }, |
59 | handles => qr/.*/, |
60 | ); |
61 | } '... can create the attribute with delegations'; |
62 | |
63 | } |
64 | |
65 | is(@w, 0, "no warnings"); |
66 | |
67 | |
68 | my $baz; |
69 | lives_ok { |
70 | $baz = Baz->new; |
71 | } '... created the object ok'; |
72 | isa_ok($baz, 'Baz'); |
73 | |
74 | is($baz->a, 'Foo::a', '... got the right delgated value'); |
75 | |
76 | |
77 | |
78 | |
79 | |
80 | @w = (); |
81 | |
82 | { |
83 | package Blart; |
84 | use Mouse; |
85 | |
86 | ::lives_ok { |
87 | has 'bar' => ( |
88 | is => 'ro', |
89 | isa => 'Foo', |
90 | lazy => 1, |
91 | default => sub { Foo->new() }, |
92 | handles => [qw(a new)], |
93 | ); |
94 | } '... can create the attribute with delegations'; |
95 | |
96 | } |
97 | |
98 | { |
99 | local $TODO = "warning not yet implemented"; |
100 | |
101 | is(@w, 1, "one warning"); |
102 | like($w[0], qr/not delegating.*new/i, "warned"); |
103 | } |
104 | |
105 | |
106 | |
107 | my $blart; |
108 | lives_ok { |
109 | $blart = Blart->new; |
110 | } '... created the object ok'; |
111 | isa_ok($blart, 'Blart'); |
112 | |
113 | is($blart->a, 'Foo::a', '... got the right delgated value'); |
114 | |
c47cf415 |
115 | done_testing; |