2 package Class::MOP::Method::Constructor;
8 use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
10 our $VERSION = '0.74';
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 {
93 $source .= "\n" . 'my $class = shift;';
95 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
96 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
98 $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
100 $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
101 $source .= ";\n" . (join ";\n" => map {
102 $self->_generate_slot_initializer($_)
103 } 0 .. (@{$self->attributes} - 1));
104 $source .= ";\n" . 'return $instance';
105 $source .= ";\n" . '}';
106 warn $source if $self->options->{debug};
111 # create the nessecary lexicals
112 # to be picked up in the eval
113 my $attrs = $self->attributes;
115 $code = eval $source;
116 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
121 sub _generate_slot_initializer {
125 my $attr = $self->attributes->[$index];
128 if ($attr->has_default) {
130 # default values can either be CODE refs
131 # in which case we need to call them. Or
132 # they can be scalars (strings/numbers)
133 # in which case we can just deal with them
134 # in the code we eval.
135 if ($attr->is_default_a_coderef) {
136 $default = '$attrs->[' . $index . ']->default($instance)';
139 $default = $attr->default;
140 # make sure to quote strings ...
141 unless (looks_like_number($default)) {
142 $default = "'$default'";
145 } elsif( $attr->has_builder ) {
146 $default = '$instance->'.$attr->builder;
149 if ( defined $attr->init_arg ) {
151 'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
152 $self->meta_instance->inline_set_slot_value(
154 ("'" . $attr->name . "'"),
155 '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
156 '} ' . (!defined $default ? '' : 'else {' . "\n" .
157 $self->meta_instance->inline_set_slot_value(
159 ("'" . $attr->name . "'"),
163 } elsif ( defined $default ) {
165 $self->meta_instance->inline_set_slot_value(
167 ("'" . $attr->name . "'"),
181 Class::MOP::Method::Constructor - Method Meta Object for constructors
185 use Class::MOP::Method::Constructor;
187 my $constructor = Class::MOP::Method::Constructor->new(
188 metaclass => $metaclass,
190 debug => 1, # this is all for now
194 # calling the constructor ...
195 $constructor->body->execute($metaclass->name, %params);
199 This is a subclass of C<Class::MOP::Method> which deals with
200 class constructors. This is used when making a class immutable
201 to generate an optimized constructor.
207 =item B<new (metaclass => $meta, options => \%options)>
211 This returns the options HASH which is passed into C<new>.
213 =item B<associated_metaclass>
215 This returns the metaclass which is passed into C<new>.
219 This returns the list of attributes which are associated with the
220 metaclass which is passed into C<new>.
222 =item B<meta_instance>
224 This returns the meta instance which is associated with the
225 metaclass which is passed into C<new>.
229 This returns a boolean, but since constructors are very rarely
230 not inlined, this always returns true for now.
232 =item B<can_be_inlined>
234 This method always returns true in this class. It exists so that
235 subclasses (like in Moose) can override and do some sort of checking
236 to determine whether or not inlining the constructor is safe.
238 =item B<initialize_body>
240 This creates the code reference for the constructor itself.
244 =head2 Method Generators
248 =item B<generate_constructor_method>
250 =item B<generate_constructor_method_inline>
256 Stevan Little E<lt>stevan@iinteractive.comE<gt>
258 =head1 COPYRIGHT AND LICENSE
260 Copyright 2006-2008 by Infinity Interactive, Inc.
262 L<http://www.iinteractive.com>
264 This library is free software; you can redistribute it and/or modify
265 it under the same terms as Perl itself.