2 package Class::MOP::Method::Constructor;
8 use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
10 our $VERSION = '0.78';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Class::MOP::Method::Generated';
20 (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
21 || confess "You must pass a metaclass instance if you want to inline"
22 if $options{is_inline};
24 ($options{package_name} && $options{name})
25 || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
27 my $self = $class->_new(\%options);
29 # we don't want this creating
30 # a cycle in the code, if not
32 weaken($self->{'associated_metaclass'});
34 $self->_initialize_body;
41 my $options = @_ == 1 ? $_[0] : {@_};
46 'package_name' => $options->{package_name},
47 'name' => $options->{name},
48 # specific to this subclass
49 'options' => $options->{options} || {},
50 'associated_metaclass' => $options->{metaclass},
51 'is_inline' => ($options->{is_inline} || 0),
55 sub can_be_inlined { 1 }
59 sub options { (shift)->{'options'} }
60 sub associated_metaclass { (shift)->{'associated_metaclass'} }
65 warn 'The meta_instance method has been made private.'
66 . " The public version is deprecated and will be removed in a future release.\n";
72 $self->{'meta_instance'} ||= $self->associated_metaclass->get_meta_instance;
76 warn 'The attributes method is deprecated.'
77 . " Use ->associated_metaclass->compute_all_applicable_attributes instead.\n";
80 $self->{'attributes'} ||= [ $self->associated_metaclass->compute_all_applicable_attributes ]
86 warn 'The initialize_body method has been made private.'
87 . " The public version is deprecated and will be removed in a future release.\n";
88 goto &_initialize_body;
91 sub _initialize_body {
93 my $method_name = '_generate_constructor_method';
95 $method_name .= '_inline' if $self->is_inline;
97 $self->{'body'} = $self->$method_name;
100 sub generate_constructor_method {
101 warn 'The generate_constructor_method method has been made private.'
102 . " The public version is deprecated and will be removed in a future release.\n";
103 goto &_generate_constructor_method;
106 sub _generate_constructor_method {
107 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
110 sub generate_constructor_method_inline {
111 warn 'The generate_constructor_method_inline method has been made private.'
112 . " The public version is deprecated and will be removed in a future release.\n";
113 goto &_generate_constructor_method_inline;
116 sub _generate_constructor_method_inline {
121 my $source = 'sub {';
122 $source .= "\n" . 'my $class = shift;';
124 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
125 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
127 $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
129 $source .= "\n" . 'my $instance = ' . $self->_meta_instance->inline_create_instance('$class');
130 $source .= ";\n" . (join ";\n" => map {
131 $self->_generate_slot_initializer($_, $close_over)
132 } $self->associated_metaclass->compute_all_applicable_attributes);
133 $source .= ";\n" . 'return $instance';
134 $source .= ";\n" . '}';
135 warn $source if $self->options->{debug};
137 my $code = $self->_eval_closure(
141 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
146 sub _generate_slot_initializer {
152 if ($attr->has_default) {
154 # default values can either be CODE refs
155 # in which case we need to call them. Or
156 # they can be scalars (strings/numbers)
157 # in which case we can just deal with them
158 # in the code we eval.
159 if ($attr->is_default_a_coderef) {
160 my $idx = @{$close->{'@defaults'}||=[]};
161 push(@{$close->{'@defaults'}}, $attr->default);
162 $default = '$defaults[' . $idx . ']->($instance)';
165 $default = $attr->default;
166 # make sure to quote strings ...
167 unless (looks_like_number($default)) {
168 $default = "'$default'";
171 } elsif( $attr->has_builder ) {
172 $default = '$instance->'.$attr->builder;
175 if ( defined $attr->init_arg ) {
177 'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
178 $self->_meta_instance->inline_set_slot_value(
181 '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
182 '} ' . (!defined $default ? '' : 'else {' . "\n" .
183 $self->_meta_instance->inline_set_slot_value(
189 } elsif ( defined $default ) {
191 $self->_meta_instance->inline_set_slot_value(
207 Class::MOP::Method::Constructor - Method Meta Object for constructors
211 use Class::MOP::Method::Constructor;
213 my $constructor = Class::MOP::Method::Constructor->new(
214 metaclass => $metaclass,
216 debug => 1, # this is all for now
220 # calling the constructor ...
221 $constructor->body->execute($metaclass->name, %params);
225 This is a subclass of C<Class::MOP::Method> which generates
232 =item B<< Class::MOP::Method::Constructor->new(%options) >>
234 This creates a new constructor object. It accepts a hash reference of
241 This should be a L<Class::MOP::Class> object. It is required.
245 The method name (without a package name). This is required.
249 The package name for the method. This is required.
253 This indicates whether or not the constructor should be inlined. This
258 =item B<< $metamethod->is_inline >>
260 Returns a boolean indicating whether or not the constructor is
263 =item B<< $metamethod->associated_metaclass >>
265 This returns the L<Class::MOP::Class> object for the method.
267 =item B<< $metamethod->is_inline >>
269 Returns a boolean indicating whether or not the constructor is
272 =item B<< $metamethod->can_be_inlined >>
274 This method always returns true in this class. It exists so that
275 subclasses (as in Moose) can do some sort of checking to determine
276 whether or not inlining the constructor is safe.
282 Stevan Little E<lt>stevan@iinteractive.comE<gt>
284 =head1 COPYRIGHT AND LICENSE
286 Copyright 2006-2009 by Infinity Interactive, Inc.
288 L<http://www.iinteractive.com>
290 This library is free software; you can redistribute it and/or modify
291 it under the same terms as Perl itself.