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'} }
66 $self->{'meta_instance'} ||= $self->associated_metaclass->get_meta_instance;
71 $self->{'attributes'} ||= [ $self->associated_metaclass->compute_all_applicable_attributes ]
78 my $method_name = 'generate_constructor_method';
80 $method_name .= '_inline' if $self->is_inline;
82 $self->{'body'} = $self->$method_name;
85 sub generate_constructor_method {
86 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
89 sub generate_constructor_method_inline {
95 $source .= "\n" . 'my $class = shift;';
97 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
98 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
100 $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
102 $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
103 $source .= ";\n" . (join ";\n" => map {
104 $self->_generate_slot_initializer($_, $close_over)
105 } 0 .. (@{$self->attributes} - 1));
106 $source .= ";\n" . 'return $instance';
107 $source .= ";\n" . '}';
108 warn $source if $self->options->{debug};
110 my $code = $self->_eval_closure(
114 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
119 sub _generate_slot_initializer {
124 my $attr = $self->attributes->[$index];
127 if ($attr->has_default) {
129 # default values can either be CODE refs
130 # in which case we need to call them. Or
131 # they can be scalars (strings/numbers)
132 # in which case we can just deal with them
133 # in the code we eval.
134 if ($attr->is_default_a_coderef) {
135 my $idx = @{$close->{'@defaults'}||=[]};
136 push(@{$close->{'@defaults'}}, $attr->default);
137 $default = '$defaults[' . $idx . ']->($instance)';
140 $default = $attr->default;
141 # make sure to quote strings ...
142 unless (looks_like_number($default)) {
143 $default = "'$default'";
146 } elsif( $attr->has_builder ) {
147 $default = '$instance->'.$attr->builder;
150 if ( defined $attr->init_arg ) {
152 'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
153 $self->meta_instance->inline_set_slot_value(
156 '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
157 '} ' . (!defined $default ? '' : 'else {' . "\n" .
158 $self->meta_instance->inline_set_slot_value(
164 } elsif ( defined $default ) {
166 $self->meta_instance->inline_set_slot_value(
182 Class::MOP::Method::Constructor - Method Meta Object for constructors
186 use Class::MOP::Method::Constructor;
188 my $constructor = Class::MOP::Method::Constructor->new(
189 metaclass => $metaclass,
191 debug => 1, # this is all for now
195 # calling the constructor ...
196 $constructor->body->execute($metaclass->name, %params);
200 This is a subclass of C<Class::MOP::Method> which deals with
201 class constructors. This is used when making a class immutable
202 to generate an optimized constructor.
208 =item B<new (metaclass => $meta, options => \%options)>
212 This returns the options HASH which is passed into C<new>.
214 =item B<associated_metaclass>
216 This returns the metaclass which is passed into C<new>.
220 This returns the list of attributes which are associated with the
221 metaclass which is passed into C<new>.
223 =item B<meta_instance>
225 This returns the meta instance which is associated with the
226 metaclass which is passed into C<new>.
230 This returns a boolean, but since constructors are very rarely
231 not inlined, this always returns true for now.
233 =item B<can_be_inlined>
235 This method always returns true in this class. It exists so that
236 subclasses (like in Moose) can override and do some sort of checking
237 to determine whether or not inlining the constructor is safe.
239 =item B<initialize_body>
241 This creates the code reference for the constructor itself.
245 =head2 Method Generators
249 =item B<generate_constructor_method>
251 =item B<generate_constructor_method_inline>
257 Stevan Little E<lt>stevan@iinteractive.comE<gt>
259 =head1 COPYRIGHT AND LICENSE
261 Copyright 2006-2009 by Infinity Interactive, Inc.
263 L<http://www.iinteractive.com>
265 This library is free software; you can redistribute it and/or modify
266 it under the same terms as Perl itself.