2 package Class::MOP::Method::Constructor;
8 use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
10 our $VERSION = '0.81';
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 Carp::cluck('The meta_instance method has been made private.'
66 . " The public version is deprecated and will be removed in a future release.\n");
67 shift->_meta_instance;
72 $self->{'meta_instance'} ||= $self->associated_metaclass->get_meta_instance;
76 Carp::cluck('The attributes method has been made private.'
77 . " The public version is deprecated and will be removed in a future release.\n");
79 return shift->_attributes;
84 $self->{'attributes'} ||= [ $self->associated_metaclass->get_all_attributes ]
90 Carp::cluck('The initialize_body method has been made private.'
91 . " The public version is deprecated and will be removed in a future release.\n");
92 shift->_initialize_body;
95 sub _initialize_body {
97 my $method_name = '_generate_constructor_method';
99 $method_name .= '_inline' if $self->is_inline;
101 $self->{'body'} = $self->$method_name;
104 sub generate_constructor_method {
105 Carp::cluck('The generate_constructor_method method has been made private.'
106 . " The public version is deprecated and will be removed in a future release.\n");
107 shift->_generate_constructor_method;
110 sub _generate_constructor_method {
111 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
114 sub generate_constructor_method_inline {
115 Carp::cluck('The generate_constructor_method_inline method has been made private.'
116 . " The public version is deprecated and will be removed in a future release.\n");
117 shift->_generate_constructor_method_inline;
120 sub _generate_constructor_method_inline {
125 my $source = 'sub {';
126 $source .= "\n" . 'my $class = shift;';
128 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
129 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
131 $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
133 $source .= "\n" . 'my $instance = ' . $self->_meta_instance->inline_create_instance('$class');
134 $source .= ";\n" . (join ";\n" => map {
135 $self->_generate_slot_initializer($_, $close_over)
136 } @{ $self->_attributes });
137 $source .= ";\n" . 'return $instance';
138 $source .= ";\n" . '}';
139 warn $source if $self->options->{debug};
141 my $code = $self->_eval_closure(
145 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
150 sub _generate_slot_initializer {
156 if ($attr->has_default) {
158 # default values can either be CODE refs
159 # in which case we need to call them. Or
160 # they can be scalars (strings/numbers)
161 # in which case we can just deal with them
162 # in the code we eval.
163 if ($attr->is_default_a_coderef) {
164 my $idx = @{$close->{'@defaults'}||=[]};
165 push(@{$close->{'@defaults'}}, $attr->default);
166 $default = '$defaults[' . $idx . ']->($instance)';
169 $default = $attr->default;
170 # make sure to quote strings ...
171 unless (looks_like_number($default)) {
172 $default = "'$default'";
175 } elsif( $attr->has_builder ) {
176 $default = '$instance->'.$attr->builder;
179 if ( defined $attr->init_arg ) {
181 'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
182 $self->_meta_instance->inline_set_slot_value(
185 '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
186 '} ' . (!defined $default ? '' : 'else {' . "\n" .
187 $self->_meta_instance->inline_set_slot_value(
193 } elsif ( defined $default ) {
195 $self->_meta_instance->inline_set_slot_value(
211 Class::MOP::Method::Constructor - Method Meta Object for constructors
215 use Class::MOP::Method::Constructor;
217 my $constructor = Class::MOP::Method::Constructor->new(
218 metaclass => $metaclass,
220 debug => 1, # this is all for now
224 # calling the constructor ...
225 $constructor->body->execute($metaclass->name, %params);
229 This is a subclass of C<Class::MOP::Method> which generates
236 =item B<< Class::MOP::Method::Constructor->new(%options) >>
238 This creates a new constructor object. It accepts a hash reference of
245 This should be a L<Class::MOP::Class> object. It is required.
249 The method name (without a package name). This is required.
253 The package name for the method. This is required.
257 This indicates whether or not the constructor should be inlined. This
262 =item B<< $metamethod->is_inline >>
264 Returns a boolean indicating whether or not the constructor is
267 =item B<< $metamethod->associated_metaclass >>
269 This returns the L<Class::MOP::Class> object for the method.
271 =item B<< $metamethod->can_be_inlined >>
273 This method always returns true in this class. It exists so that
274 subclasses (as in Moose) can do some sort of checking to determine
275 whether or not inlining the constructor is safe.
281 Stevan Little E<lt>stevan@iinteractive.comE<gt>
283 =head1 COPYRIGHT AND LICENSE
285 Copyright 2006-2009 by Infinity Interactive, Inc.
287 L<http://www.iinteractive.com>
289 This library is free software; you can redistribute it and/or modify
290 it under the same terms as Perl itself.