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;
70 warn 'The attributes method is deprecated.'
71 . " Use ->associated_metaclass->compute_all_applicable_attributes instead.\n";
74 $self->{'attributes'} ||= [ $self->associated_metaclass->compute_all_applicable_attributes ]
80 warn 'The initialize_body method has been made private.'
81 . " The public version is deprecated and will be removed in a future release.\n";
82 goto &_initialize_body;
85 sub _initialize_body {
87 my $method_name = '_generate_constructor_method';
89 $method_name .= '_inline' if $self->is_inline;
91 $self->{'body'} = $self->$method_name;
94 sub generate_constructor_method {
95 warn 'The generate_constructor_method method has been made private.'
96 . " The public version is deprecated and will be removed in a future release.\n";
97 goto &_generate_constructor_method;
100 sub _generate_constructor_method {
101 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
104 sub generate_constructor_method_inline {
105 warn 'The generate_constructor_method_inline method has been made private.'
106 . " The public version is deprecated and will be removed in a future release.\n";
107 goto &_generate_constructor_method_inline;
110 sub _generate_constructor_method_inline {
115 my $source = 'sub {';
116 $source .= "\n" . 'my $class = shift;';
118 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
119 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
121 $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
123 $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
124 $source .= ";\n" . (join ";\n" => map {
125 $self->_generate_slot_initializer($_, $close_over)
126 } $self->associated_metaclass->compute_all_applicable_attributes);
127 $source .= ";\n" . 'return $instance';
128 $source .= ";\n" . '}';
129 warn $source if $self->options->{debug};
131 my $code = $self->_eval_closure(
135 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
140 sub _generate_slot_initializer {
146 if ($attr->has_default) {
148 # default values can either be CODE refs
149 # in which case we need to call them. Or
150 # they can be scalars (strings/numbers)
151 # in which case we can just deal with them
152 # in the code we eval.
153 if ($attr->is_default_a_coderef) {
154 my $idx = @{$close->{'@defaults'}||=[]};
155 push(@{$close->{'@defaults'}}, $attr->default);
156 $default = '$defaults[' . $idx . ']->($instance)';
159 $default = $attr->default;
160 # make sure to quote strings ...
161 unless (looks_like_number($default)) {
162 $default = "'$default'";
165 } elsif( $attr->has_builder ) {
166 $default = '$instance->'.$attr->builder;
169 if ( defined $attr->init_arg ) {
171 'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
172 $self->meta_instance->inline_set_slot_value(
175 '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
176 '} ' . (!defined $default ? '' : 'else {' . "\n" .
177 $self->meta_instance->inline_set_slot_value(
183 } elsif ( defined $default ) {
185 $self->meta_instance->inline_set_slot_value(
201 Class::MOP::Method::Constructor - Method Meta Object for constructors
205 use Class::MOP::Method::Constructor;
207 my $constructor = Class::MOP::Method::Constructor->new(
208 metaclass => $metaclass,
210 debug => 1, # this is all for now
214 # calling the constructor ...
215 $constructor->body->execute($metaclass->name, %params);
219 This is a subclass of C<Class::MOP::Method> which generates
226 =item B<< Class::MOP::Method::Constructor->new(%options) >>
228 This creates a new constructor object. It accepts a hash reference of
235 This should be a L<Class::MOP::Class> object. It is required.
239 The method name (without a package name). This is required.
243 The package name for the method. This is required.
247 This indicates whether or not the constructor should be inlined. This
252 =item B<< $metamethod->is_inline >>
254 Returns a boolean indicating whether or not the constructor is
257 =item B<< $metamethod->associated_metaclass >>
259 This returns the L<Class::MOP::Class> object for the method.
261 =item B<< $metamethod->is_inline >>
263 Returns a boolean indicating whether or not the constructor is
266 =item B<< $metamethod->can_be_inlined >>
268 This method always returns true in this class. It exists so that
269 subclasses (as in Moose) can do some sort of checking to determine
270 whether or not inlining the constructor is safe.
276 Stevan Little E<lt>stevan@iinteractive.comE<gt>
278 =head1 COPYRIGHT AND LICENSE
280 Copyright 2006-2009 by Infinity Interactive, Inc.
282 L<http://www.iinteractive.com>
284 This library is free software; you can redistribute it and/or modify
285 it under the same terms as Perl itself.