Commit | Line | Data |
e56de0ef |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
4 | use Test::More; |
5 | use Test::Exception; |
6 | |
7 | use Class::MOP; |
8 | |
9 | my $instance; |
10 | { |
11 | package Foo; |
12 | |
13 | sub new { |
14 | my $class = shift; |
15 | $instance = bless {@_}, $class; |
16 | return $instance; |
17 | } |
18 | |
19 | sub foo { shift->{foo} } |
20 | } |
21 | |
22 | { |
23 | package Foo::Sub; |
24 | use base 'Foo'; |
25 | use metaclass; |
26 | |
27 | sub new { |
28 | my $class = shift; |
29 | $class->meta->new_object( |
30 | __INSTANCE__ => $class->SUPER::new(@_), |
31 | @_, |
32 | ); |
33 | } |
34 | |
35 | __PACKAGE__->meta->add_attribute( |
36 | bar => ( |
37 | reader => 'bar', |
38 | initializer => sub { |
39 | my $self = shift; |
40 | my ($value, $writer, $attr) = @_; |
41 | $writer->(uc $value); |
42 | }, |
43 | ), |
44 | ); |
45 | } |
46 | |
47 | undef $instance; |
48 | lives_and { |
49 | my $foo = Foo::Sub->new; |
50 | isa_ok($foo, 'Foo'); |
51 | isa_ok($foo, 'Foo::Sub'); |
52 | is($foo, $instance, "used the passed-in instance"); |
53 | }; |
54 | |
55 | undef $instance; |
56 | lives_and { |
57 | my $foo = Foo::Sub->new(foo => 'FOO'); |
58 | isa_ok($foo, 'Foo'); |
59 | isa_ok($foo, 'Foo::Sub'); |
60 | is($foo, $instance, "used the passed-in instance"); |
61 | is($foo->foo, 'FOO', "set non-CMOP constructor args"); |
62 | }; |
63 | |
64 | undef $instance; |
65 | lives_and { |
66 | my $foo = Foo::Sub->new(bar => 'bar'); |
67 | isa_ok($foo, 'Foo'); |
68 | isa_ok($foo, 'Foo::Sub'); |
69 | is($foo, $instance, "used the passed-in instance"); |
70 | is($foo->bar, 'BAR', "set CMOP attributes"); |
71 | }; |
72 | |
73 | undef $instance; |
74 | lives_and { |
75 | my $foo = Foo::Sub->new(foo => 'FOO', bar => 'bar'); |
76 | isa_ok($foo, 'Foo'); |
77 | isa_ok($foo, 'Foo::Sub'); |
78 | is($foo, $instance, "used the passed-in instance"); |
79 | is($foo->foo, 'FOO', "set non-CMOP constructor arg"); |
80 | is($foo->bar, 'BAR', "set correct CMOP attribute"); |
81 | }; |
82 | |
83 | { |
84 | package BadFoo; |
85 | |
86 | sub new { |
87 | my $class = shift; |
88 | $instance = bless {@_}; |
89 | return $instance; |
90 | } |
91 | |
92 | sub foo { shift->{foo} } |
93 | } |
94 | |
95 | { |
96 | package BadFoo::Sub; |
97 | use base 'BadFoo'; |
98 | use metaclass; |
99 | |
100 | sub new { |
101 | my $class = shift; |
102 | $class->meta->new_object( |
103 | __INSTANCE__ => $class->SUPER::new(@_), |
104 | @_, |
105 | ); |
106 | } |
107 | |
108 | __PACKAGE__->meta->add_attribute( |
109 | bar => ( |
110 | reader => 'bar', |
111 | initializer => sub { |
112 | my $self = shift; |
113 | my ($value, $writer, $attr) = @_; |
114 | $writer->(uc $value); |
115 | }, |
116 | ), |
117 | ); |
118 | } |
119 | |
120 | throws_ok { BadFoo::Sub->new } |
121 | qr/BadFoo=HASH.*is not a BadFoo::Sub/, |
122 | "error with incorrect constructors"; |
123 | |
124 | { |
125 | my $meta = Class::MOP::Class->create('Really::Bad::Foo'); |
126 | throws_ok { |
127 | $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class')) |
128 | } qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/, |
129 | "error with completely invalid class"; |
130 | } |
131 | |
132 | { |
133 | my $meta = Class::MOP::Class->create('Really::Bad::Foo::2'); |
134 | for my $invalid ('foo', 1, 0, '') { |
135 | throws_ok { |
136 | $meta->new_object(__INSTANCE__ => $invalid) |
137 | } qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/, |
138 | "error with unblessed thing"; |
139 | } |
140 | } |
141 | |
142 | done_testing; |