Commit | Line | Data |
38bf2a25 |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
4 | use Test::More; |
5 | use Test::Fatal; |
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 | is( exception { |
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 | }, undef ); |
54 | |
55 | undef $instance; |
56 | is( exception { |
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 | }, undef ); |
63 | |
64 | undef $instance; |
65 | is( exception { |
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 | }, undef ); |
72 | |
73 | undef $instance; |
74 | is( exception { |
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 | }, undef ); |
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 | like( exception { BadFoo::Sub->new }, qr/BadFoo=HASH.*is not a BadFoo::Sub/, "error with incorrect constructors" ); |
121 | |
122 | { |
123 | my $meta = Class::MOP::Class->create('Really::Bad::Foo'); |
124 | like( exception { |
125 | $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class')) |
126 | }, qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/, "error with completely invalid class" ); |
127 | } |
128 | |
129 | { |
130 | my $meta = Class::MOP::Class->create('Really::Bad::Foo::2'); |
131 | for my $invalid ('foo', 1, 0, '') { |
132 | like( exception { |
133 | $meta->new_object(__INSTANCE__ => $invalid) |
134 | }, qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/, "error with unblessed thing" ); |
135 | } |
136 | } |
137 | |
138 | done_testing; |