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 ]
77 warn 'The initialize_body method has been made private.'
78 . " The public version is deprecated and will be removed in a future release.\n";
79 goto &_initialize_body;
82 sub _initialize_body {
84 my $method_name = 'generate_constructor_method';
86 $method_name .= '_inline' if $self->is_inline;
88 $self->{'body'} = $self->$method_name;
91 sub generate_constructor_method {
92 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
95 sub generate_constructor_method_inline {
100 my $source = 'sub {';
101 $source .= "\n" . 'my $class = shift;';
103 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
104 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
106 $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
108 $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
109 $source .= ";\n" . (join ";\n" => map {
110 $self->_generate_slot_initializer($_, $close_over)
111 } @{$self->attributes});
112 $source .= ";\n" . 'return $instance';
113 $source .= ";\n" . '}';
114 warn $source if $self->options->{debug};
116 my $code = $self->_eval_closure(
120 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
125 sub _generate_slot_initializer {
131 if ($attr->has_default) {
133 # default values can either be CODE refs
134 # in which case we need to call them. Or
135 # they can be scalars (strings/numbers)
136 # in which case we can just deal with them
137 # in the code we eval.
138 if ($attr->is_default_a_coderef) {
139 my $idx = @{$close->{'@defaults'}||=[]};
140 push(@{$close->{'@defaults'}}, $attr->default);
141 $default = '$defaults[' . $idx . ']->($instance)';
144 $default = $attr->default;
145 # make sure to quote strings ...
146 unless (looks_like_number($default)) {
147 $default = "'$default'";
150 } elsif( $attr->has_builder ) {
151 $default = '$instance->'.$attr->builder;
154 if ( defined $attr->init_arg ) {
156 'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
157 $self->meta_instance->inline_set_slot_value(
160 '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
161 '} ' . (!defined $default ? '' : 'else {' . "\n" .
162 $self->meta_instance->inline_set_slot_value(
168 } elsif ( defined $default ) {
170 $self->meta_instance->inline_set_slot_value(
186 Class::MOP::Method::Constructor - Method Meta Object for constructors
190 use Class::MOP::Method::Constructor;
192 my $constructor = Class::MOP::Method::Constructor->new(
193 metaclass => $metaclass,
195 debug => 1, # this is all for now
199 # calling the constructor ...
200 $constructor->body->execute($metaclass->name, %params);
204 This is a subclass of C<Class::MOP::Method> which generates
211 =item B<< Class::MOP::Method::Constructor->new(%options) >>
213 This creates a new constructor object. It accepts a hash reference of
220 This should be a L<Class::MOP::Class> object. It is required.
224 The method name (without a package name). This is required.
228 The package name for the method. This is required.
232 This indicates whether or not the constructor should be inlined. This
237 =item B<< $metamethod->is_inline >>
239 Returns a boolean indicating whether or not the constructor is
242 =item B<< $metamethod->associated_metaclass >>
244 This returns the L<Class::MOP::Class> object for the method.
246 =item B<< $metamethod->is_inline >>
248 Returns a boolean indicating whether or not the constructor is
251 =item B<< $metamethod->can_be_inlined >>
253 This method always returns true in this class. It exists so that
254 subclasses (as in Moose) can do some sort of checking to determine
255 whether or not inlining the constructor is safe.
261 Stevan Little E<lt>stevan@iinteractive.comE<gt>
263 =head1 COPYRIGHT AND LICENSE
265 Copyright 2006-2009 by Infinity Interactive, Inc.
267 L<http://www.iinteractive.com>
269 This library is free software; you can redistribute it and/or modify
270 it under the same terms as Perl itself.