2 package Class::MOP::Method::Constructor;
8 use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
10 our $VERSION = '0.82_01';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Class::MOP::Method::Inlined';
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),
57 sub options { (shift)->{'options'} }
58 sub associated_metaclass { (shift)->{'associated_metaclass'} }
63 Carp::cluck('The meta_instance method has been made private.'
64 . " The public version is deprecated and will be removed in a future release.\n");
65 shift->_meta_instance;
70 $self->{'meta_instance'} ||= $self->associated_metaclass->get_meta_instance;
74 Carp::cluck('The attributes method has been made private.'
75 . " The public version is deprecated and will be removed in a future release.\n");
77 return shift->_attributes;
82 $self->{'attributes'} ||= [ $self->associated_metaclass->get_all_attributes ]
88 Carp::cluck('The initialize_body method has been made private.'
89 . " The public version is deprecated and will be removed in a future release.\n");
90 shift->_initialize_body;
93 sub _initialize_body {
95 my $method_name = '_generate_constructor_method';
97 $method_name .= '_inline' if $self->is_inline;
99 $self->{'body'} = $self->$method_name;
102 sub generate_constructor_method {
103 Carp::cluck('The generate_constructor_method method has been made private.'
104 . " The public version is deprecated and will be removed in a future release.\n");
105 shift->_generate_constructor_method;
108 sub _generate_constructor_method {
109 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
112 sub generate_constructor_method_inline {
113 Carp::cluck('The generate_constructor_method_inline method has been made private.'
114 . " The public version is deprecated and will be removed in a future release.\n");
115 shift->_generate_constructor_method_inline;
118 sub _generate_constructor_method_inline {
123 my $source = 'sub {';
124 $source .= "\n" . 'my $class = shift;';
126 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
127 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
129 $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
131 $source .= "\n" . 'my $instance = ' . $self->_meta_instance->inline_create_instance('$class');
132 $source .= ";\n" . (join ";\n" => map {
133 $self->_generate_slot_initializer($_, $close_over)
134 } @{ $self->_attributes });
135 $source .= ";\n" . 'return $instance';
136 $source .= ";\n" . '}';
137 warn $source if $self->options->{debug};
139 my $code = $self->_eval_closure(
143 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
148 sub _generate_slot_initializer {
154 if ($attr->has_default) {
156 # default values can either be CODE refs
157 # in which case we need to call them. Or
158 # they can be scalars (strings/numbers)
159 # in which case we can just deal with them
160 # in the code we eval.
161 if ($attr->is_default_a_coderef) {
162 my $idx = @{$close->{'@defaults'}||=[]};
163 push(@{$close->{'@defaults'}}, $attr->default);
164 $default = '$defaults[' . $idx . ']->($instance)';
167 $default = $attr->default;
168 # make sure to quote strings ...
169 unless (looks_like_number($default)) {
170 $default = "'$default'";
173 } elsif( $attr->has_builder ) {
174 $default = '$instance->'.$attr->builder;
177 if ( defined $attr->init_arg ) {
179 'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
180 $self->_meta_instance->inline_set_slot_value(
183 '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
184 '} ' . (!defined $default ? '' : 'else {' . "\n" .
185 $self->_meta_instance->inline_set_slot_value(
191 } elsif ( defined $default ) {
193 $self->_meta_instance->inline_set_slot_value(
209 Class::MOP::Method::Constructor - Method Meta Object for constructors
213 use Class::MOP::Method::Constructor;
215 my $constructor = Class::MOP::Method::Constructor->new(
216 metaclass => $metaclass,
218 debug => 1, # this is all for now
222 # calling the constructor ...
223 $constructor->body->execute($metaclass->name, %params);
227 This is a subclass of C<Class::MOP::Method> which generates
234 =item B<< Class::MOP::Method::Constructor->new(%options) >>
236 This creates a new constructor object. It accepts a hash reference of
243 This should be a L<Class::MOP::Class> object. It is required.
247 The method name (without a package name). This is required.
251 The package name for the method. This is required.
255 This indicates whether or not the constructor should be inlined. This
260 =item B<< $metamethod->is_inline >>
262 Returns a boolean indicating whether or not the constructor is
265 =item B<< $metamethod->associated_metaclass >>
267 This returns the L<Class::MOP::Class> object for the method.
269 =item B<< $metamethod->can_be_inlined >>
271 This method always returns true in this class. It exists so that
272 subclasses (as in Moose) can do some sort of checking to determine
273 whether or not inlining the constructor is safe.
279 Stevan Little E<lt>stevan@iinteractive.comE<gt>
281 =head1 COPYRIGHT AND LICENSE
283 Copyright 2006-2009 by Infinity Interactive, Inc.
285 L<http://www.iinteractive.com>
287 This library is free software; you can redistribute it and/or modify
288 it under the same terms as Perl itself.