Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Method::Constructor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed', 'weaken'; |
9 | use Try::Tiny; |
10 | |
38bf2a25 |
11 | use base 'Class::MOP::Method::Inlined'; |
12 | |
13 | sub new { |
14 | my $class = shift; |
15 | my %options = @_; |
16 | |
17 | (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) |
18 | || confess "You must pass a metaclass instance if you want to inline" |
19 | if $options{is_inline}; |
20 | |
21 | ($options{package_name} && $options{name}) |
22 | || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; |
23 | |
24 | my $self = $class->_new(\%options); |
25 | |
26 | # we don't want this creating |
27 | # a cycle in the code, if not |
28 | # needed |
29 | weaken($self->{'associated_metaclass'}); |
30 | |
31 | $self->_initialize_body; |
32 | |
33 | return $self; |
34 | } |
35 | |
36 | sub _new { |
37 | my $class = shift; |
38 | |
39 | return Class::MOP::Class->initialize($class)->new_object(@_) |
40 | if $class ne __PACKAGE__; |
41 | |
42 | my $params = @_ == 1 ? $_[0] : {@_}; |
43 | |
44 | return bless { |
45 | # inherited from Class::MOP::Method |
46 | body => $params->{body}, |
47 | # associated_metaclass => $params->{associated_metaclass}, # overriden |
48 | package_name => $params->{package_name}, |
49 | name => $params->{name}, |
50 | original_method => $params->{original_method}, |
51 | |
52 | # inherited from Class::MOP::Generated |
53 | is_inline => $params->{is_inline} || 0, |
54 | definition_context => $params->{definition_context}, |
55 | |
56 | # inherited from Class::MOP::Inlined |
57 | _expected_method_class => $params->{_expected_method_class}, |
58 | |
59 | # defined in this subclass |
60 | options => $params->{options} || {}, |
61 | associated_metaclass => $params->{metaclass}, |
62 | }, $class; |
63 | } |
64 | |
65 | ## accessors |
66 | |
67 | sub options { (shift)->{'options'} } |
68 | sub associated_metaclass { (shift)->{'associated_metaclass'} } |
69 | |
70 | ## cached values ... |
71 | |
72 | sub _attributes { |
73 | my $self = shift; |
74 | $self->{'attributes'} ||= [ |
75 | sort { $a->name cmp $b->name } |
76 | $self->associated_metaclass->get_all_attributes |
77 | ] |
78 | } |
79 | |
80 | ## method |
81 | |
82 | sub _initialize_body { |
83 | my $self = shift; |
84 | my $method_name = '_generate_constructor_method'; |
85 | |
86 | $method_name .= '_inline' if $self->is_inline; |
87 | |
88 | $self->{'body'} = $self->$method_name; |
89 | } |
90 | |
91 | sub _eval_environment { |
92 | my $self = shift; |
93 | my $defaults = [map { $_->default } @{ $self->_attributes }]; |
94 | return { |
95 | '$defaults' => \$defaults, |
96 | }; |
97 | } |
98 | |
99 | sub _generate_constructor_method { |
100 | return sub { Class::MOP::Class->initialize(shift)->new_object(@_) } |
101 | } |
102 | |
103 | sub _generate_constructor_method_inline { |
104 | my $self = shift; |
105 | |
106 | my $meta = $self->associated_metaclass; |
107 | |
108 | my @source = ( |
109 | 'sub {', |
110 | $meta->_inline_new_object, |
111 | '}', |
112 | ); |
113 | |
114 | warn join("\n", @source) if $self->options->{debug}; |
115 | |
116 | my $code = try { |
117 | $self->_compile_code(\@source); |
118 | } |
119 | catch { |
120 | my $source = join("\n", @source); |
121 | confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_"; |
122 | }; |
123 | |
124 | return $code; |
125 | } |
126 | |
127 | 1; |
128 | |
129 | # ABSTRACT: Method Meta Object for constructors |
130 | |
131 | __END__ |
132 | |
133 | =pod |
134 | |
135 | =head1 SYNOPSIS |
136 | |
137 | use Class::MOP::Method::Constructor; |
138 | |
139 | my $constructor = Class::MOP::Method::Constructor->new( |
140 | metaclass => $metaclass, |
141 | options => { |
142 | debug => 1, # this is all for now |
143 | }, |
144 | ); |
145 | |
146 | # calling the constructor ... |
147 | $constructor->body->execute($metaclass->name, %params); |
148 | |
149 | =head1 DESCRIPTION |
150 | |
151 | This is a subclass of C<Class::MOP::Method> which generates |
152 | constructor methods. |
153 | |
154 | =head1 METHODS |
155 | |
156 | =over 4 |
157 | |
158 | =item B<< Class::MOP::Method::Constructor->new(%options) >> |
159 | |
160 | This creates a new constructor object. It accepts a hash reference of |
161 | options. |
162 | |
163 | =over 8 |
164 | |
165 | =item * metaclass |
166 | |
167 | This should be a L<Class::MOP::Class> object. It is required. |
168 | |
169 | =item * name |
170 | |
171 | The method name (without a package name). This is required. |
172 | |
173 | =item * package_name |
174 | |
175 | The package name for the method. This is required. |
176 | |
177 | =item * is_inline |
178 | |
179 | This indicates whether or not the constructor should be inlined. This |
180 | defaults to false. |
181 | |
182 | =back |
183 | |
184 | =item B<< $metamethod->is_inline >> |
185 | |
186 | Returns a boolean indicating whether or not the constructor is |
187 | inlined. |
188 | |
189 | =item B<< $metamethod->associated_metaclass >> |
190 | |
191 | This returns the L<Class::MOP::Class> object for the method. |
192 | |
193 | =back |
194 | |
195 | =cut |
196 | |