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 } @{$self->attributes});
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 {
125 if ($attr->has_default) {
127 # default values can either be CODE refs
128 # in which case we need to call them. Or
129 # they can be scalars (strings/numbers)
130 # in which case we can just deal with them
131 # in the code we eval.
132 if ($attr->is_default_a_coderef) {
133 my $idx = @{$close->{'@defaults'}||=[]};
134 push(@{$close->{'@defaults'}}, $attr->default);
135 $default = '$defaults[' . $idx . ']->($instance)';
138 $default = $attr->default;
139 # make sure to quote strings ...
140 unless (looks_like_number($default)) {
141 $default = "'$default'";
144 } elsif( $attr->has_builder ) {
145 $default = '$instance->'.$attr->builder;
148 if ( defined $attr->init_arg ) {
150 'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
151 $self->meta_instance->inline_set_slot_value(
154 '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
155 '} ' . (!defined $default ? '' : 'else {' . "\n" .
156 $self->meta_instance->inline_set_slot_value(
162 } elsif ( defined $default ) {
164 $self->meta_instance->inline_set_slot_value(
180 Class::MOP::Method::Constructor - Method Meta Object for constructors
184 use Class::MOP::Method::Constructor;
186 my $constructor = Class::MOP::Method::Constructor->new(
187 metaclass => $metaclass,
189 debug => 1, # this is all for now
193 # calling the constructor ...
194 $constructor->body->execute($metaclass->name, %params);
198 This is a subclass of C<Class::MOP::Method> which generates
205 =item B<< Class::MOP::Method::Constructor->new(%options) >>
207 This creates a new constructor object. It accepts a hash reference of
214 This should be a L<Class::MOP::Class> object. It is required.
218 The method name (without a package name). This is required.
222 The package name for the method. This is required.
226 This indicates whether or not the constructor should be inlined. This
231 =item B<< $metamethod->is_inline >>
233 Returns a boolean indicating whether or not the constructor is
236 =item B<< $metamethod->associated_metaclass >>
238 This returns the L<Class::MOP::Class> object for the method.
240 =item B<< $metamethod->is_inline >>
242 Returns a boolean indicating whether or not the constructor is
245 =item B<< $metamethod->can_be_inlined >>
247 This method always returns true in this class. It exists so that
248 subclasses (as in Moose) can do some sort of checking to determine
249 whether or not inlining the constructor is safe.
255 Stevan Little E<lt>stevan@iinteractive.comE<gt>
257 =head1 COPYRIGHT AND LICENSE
259 Copyright 2006-2009 by Infinity Interactive, Inc.
261 L<http://www.iinteractive.com>
263 This library is free software; you can redistribute it and/or modify
264 it under the same terms as Perl itself.