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 | |
38bf2a25 |
70 | ## method |
71 | |
72 | sub _initialize_body { |
73 | my $self = shift; |
74 | my $method_name = '_generate_constructor_method'; |
75 | |
76 | $method_name .= '_inline' if $self->is_inline; |
77 | |
78 | $self->{'body'} = $self->$method_name; |
79 | } |
80 | |
81 | sub _eval_environment { |
82 | my $self = shift; |
96fec633 |
83 | return $self->associated_metaclass->_eval_environment; |
38bf2a25 |
84 | } |
85 | |
86 | sub _generate_constructor_method { |
87 | return sub { Class::MOP::Class->initialize(shift)->new_object(@_) } |
88 | } |
89 | |
90 | sub _generate_constructor_method_inline { |
91 | my $self = shift; |
92 | |
93 | my $meta = $self->associated_metaclass; |
94 | |
95 | my @source = ( |
96 | 'sub {', |
97 | $meta->_inline_new_object, |
98 | '}', |
99 | ); |
100 | |
101 | warn join("\n", @source) if $self->options->{debug}; |
102 | |
103 | my $code = try { |
104 | $self->_compile_code(\@source); |
105 | } |
106 | catch { |
107 | my $source = join("\n", @source); |
108 | confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_"; |
109 | }; |
110 | |
111 | return $code; |
112 | } |
113 | |
114 | 1; |
115 | |
116 | # ABSTRACT: Method Meta Object for constructors |
117 | |
118 | __END__ |
119 | |
120 | =pod |
121 | |
122 | =head1 SYNOPSIS |
123 | |
124 | use Class::MOP::Method::Constructor; |
125 | |
126 | my $constructor = Class::MOP::Method::Constructor->new( |
127 | metaclass => $metaclass, |
128 | options => { |
129 | debug => 1, # this is all for now |
130 | }, |
131 | ); |
132 | |
133 | # calling the constructor ... |
134 | $constructor->body->execute($metaclass->name, %params); |
135 | |
136 | =head1 DESCRIPTION |
137 | |
138 | This is a subclass of C<Class::MOP::Method> which generates |
139 | constructor methods. |
140 | |
141 | =head1 METHODS |
142 | |
143 | =over 4 |
144 | |
145 | =item B<< Class::MOP::Method::Constructor->new(%options) >> |
146 | |
147 | This creates a new constructor object. It accepts a hash reference of |
148 | options. |
149 | |
150 | =over 8 |
151 | |
152 | =item * metaclass |
153 | |
154 | This should be a L<Class::MOP::Class> object. It is required. |
155 | |
156 | =item * name |
157 | |
158 | The method name (without a package name). This is required. |
159 | |
160 | =item * package_name |
161 | |
162 | The package name for the method. This is required. |
163 | |
164 | =item * is_inline |
165 | |
166 | This indicates whether or not the constructor should be inlined. This |
167 | defaults to false. |
168 | |
169 | =back |
170 | |
171 | =item B<< $metamethod->is_inline >> |
172 | |
173 | Returns a boolean indicating whether or not the constructor is |
174 | inlined. |
175 | |
176 | =item B<< $metamethod->associated_metaclass >> |
177 | |
178 | This returns the L<Class::MOP::Class> object for the method. |
179 | |
180 | =back |
181 | |
182 | =cut |
183 | |