Squashed commit of the following:
[gitmo/Class-MOP.git] / lib / Class / MOP / Method / Constructor.pm
CommitLineData
d90b42a6 1
2package Class::MOP::Method::Constructor;
3
4use strict;
5use warnings;
6
7use Carp 'confess';
8343d501 8use Scalar::Util 'blessed', 'weaken';
d90b42a6 9
67f694ad 10our $VERSION = '1.04';
d519662a 11$VERSION = eval $VERSION;
d90b42a6 12our $AUTHORITY = 'cpan:STEVAN';
13
29d4e92a 14use base 'Class::MOP::Method::Inlined';
d90b42a6 15
16sub new {
17 my $class = shift;
18 my %options = @_;
8d2d4c67 19
ad315b75 20 (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
21 || confess "You must pass a metaclass instance if you want to inline"
8d2d4c67 22 if $options{is_inline};
23
b38f3848 24 ($options{package_name} && $options{name})
32202ce2 25 || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
b38f3848 26
0bfc85b8 27 my $self = $class->_new(\%options);
d90b42a6 28
8d2d4c67 29 # we don't want this creating
30 # a cycle in the code, if not
d90b42a6 31 # needed
8683db0e 32 weaken($self->{'associated_metaclass'});
d90b42a6 33
8f7852d8 34 $self->_initialize_body;
d90b42a6 35
8d2d4c67 36 return $self;
d90b42a6 37}
38
28b97bef 39sub _new {
0bfc85b8 40 my $class = shift;
812d58f9 41
ec9e38e5 42 return Class::MOP::Class->initialize($class)->new_object(@_)
812d58f9 43 if $class ne __PACKAGE__;
ec9e38e5 44
45 my $params = @_ == 1 ? $_[0] : {@_};
46
47 return bless {
48 # inherited from Class::MOP::Method
49 body => $params->{body},
50 # associated_metaclass => $params->{associated_metaclass}, # overriden
51 package_name => $params->{package_name},
52 name => $params->{name},
53 original_method => $params->{original_method},
54
55 # inherited from Class::MOP::Generated
56 is_inline => $params->{is_inline} || 0,
57 definition_context => $params->{definition_context},
58
59 # inherited from Class::MOP::Inlined
60 _expected_method_class => $params->{_expected_method_class},
61
62 # defined in this subclass
63 options => $params->{options} || {},
64 associated_metaclass => $params->{metaclass},
28b97bef 65 }, $class;
66}
67
8d2d4c67 68## accessors
c23184fc 69
8683db0e 70sub options { (shift)->{'options'} }
71sub associated_metaclass { (shift)->{'associated_metaclass'} }
c23184fc 72
565f0cbb 73## cached values ...
d90b42a6 74
5a49fb79 75sub _meta_instance {
565f0cbb 76 my $self = shift;
8683db0e 77 $self->{'meta_instance'} ||= $self->associated_metaclass->get_meta_instance;
565f0cbb 78}
c23184fc 79
780f14c2 80sub _attributes {
565f0cbb 81 my $self = shift;
2620be77 82 $self->{'attributes'} ||= [ $self->associated_metaclass->get_all_attributes ]
565f0cbb 83}
d90b42a6 84
85## method
86
8f7852d8 87sub _initialize_body {
565f0cbb 88 my $self = shift;
ecb874a0 89 my $method_name = '_generate_constructor_method';
8d2d4c67 90
565f0cbb 91 $method_name .= '_inline' if $self->is_inline;
8d2d4c67 92
8683db0e 93 $self->{'body'} = $self->$method_name;
565f0cbb 94}
95
ecb874a0 96sub _generate_constructor_method {
2a2b8458 97 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
565f0cbb 98}
99
ecb874a0 100sub _generate_constructor_method_inline {
d90b42a6 101 my $self = shift;
565f0cbb 102
8343d501 103 my $defaults = [map { $_->default } @{ $self->_attributes }];
104
105 my $close_over = {
106 '$defaults' => \$defaults,
107 };
0c6f3280 108
d90b42a6 109 my $source = 'sub {';
26ffbb36 110 $source .= "\n" . 'my $class = shift;';
8d2d4c67 111
26ffbb36 112 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
8d2d4c67 113 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
114
26ffbb36 115 $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
116
5a49fb79 117 $source .= "\n" . 'my $instance = ' . $self->_meta_instance->inline_create_instance('$class');
8343d501 118 my $idx = 0;
8d2d4c67 119 $source .= ";\n" . (join ";\n" => map {
8343d501 120 $self->_generate_slot_initializer($_, $idx++)
780f14c2 121 } @{ $self->_attributes });
d90b42a6 122 $source .= ";\n" . 'return $instance';
8d2d4c67 123 $source .= ";\n" . '}';
124 warn $source if $self->options->{debug};
125
e24b19fb 126 my ( $code, $e ) = $self->_eval_closure(
ffe92c8b 127 $close_over,
128 $source
129 );
e24b19fb 130 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e" if $e;
a6eef5a3 131
132 return $code;
d90b42a6 133}
134
135sub _generate_slot_initializer {
136 my $self = shift;
64adcd8d 137 my $attr = shift;
8343d501 138 my $idx = shift;
8d2d4c67 139
d90b42a6 140 my $default;
141 if ($attr->has_default) {
8343d501 142 $default = $self->_generate_default_value($attr, $idx);
8d2d4c67 143 } elsif( $attr->has_builder ) {
144 $default = '$instance->'.$attr->builder;
d90b42a6 145 }
8d2d4c67 146
2f2329a4 147 if ( defined(my $init_arg = $attr->init_arg) ) {
c16c9c1b 148 return (
2f2329a4 149 'if(exists $params->{\'' . $init_arg . '\'}){' . "\n" .
5a49fb79 150 $self->_meta_instance->inline_set_slot_value(
c16c9c1b 151 '$instance',
e9a19694 152 $attr->name,
2f2329a4 153 '$params->{\'' . $init_arg . '\'}' ) . "\n" .
c16c9c1b 154 '} ' . (!defined $default ? '' : 'else {' . "\n" .
5a49fb79 155 $self->_meta_instance->inline_set_slot_value(
c16c9c1b 156 '$instance',
e9a19694 157 $attr->name,
c16c9c1b 158 $default ) . "\n" .
159 '}')
160 );
161 } elsif ( defined $default ) {
162 return (
5a49fb79 163 $self->_meta_instance->inline_set_slot_value(
c16c9c1b 164 '$instance',
e9a19694 165 $attr->name,
c16c9c1b 166 $default ) . "\n"
167 );
168 } else { return '' }
d90b42a6 169}
170
8343d501 171sub _generate_default_value {
172 my ($self, $attr, $index) = @_;
173 # NOTE:
174 # default values can either be CODE refs
175 # in which case we need to call them. Or
176 # they can be scalars (strings/numbers)
177 # in which case we can just deal with them
178 # in the code we eval.
179 if ($attr->is_default_a_coderef) {
180 return '$defaults->[' . $index . ']->($instance)';
181 }
182 else {
183 return '$defaults->[' . $index . ']';
184 }
185}
186
d90b42a6 1871;
188
d90b42a6 189__END__
190
191=pod
192
8d2d4c67 193=head1 NAME
d90b42a6 194
195Class::MOP::Method::Constructor - Method Meta Object for constructors
196
197=head1 SYNOPSIS
198
96e38ba6 199 use Class::MOP::Method::Constructor;
8d2d4c67 200
96e38ba6 201 my $constructor = Class::MOP::Method::Constructor->new(
8d2d4c67 202 metaclass => $metaclass,
96e38ba6 203 options => {
204 debug => 1, # this is all for now
8d2d4c67 205 },
96e38ba6 206 );
8d2d4c67 207
96e38ba6 208 # calling the constructor ...
b7045e66 209 $constructor->body->execute($metaclass->name, %params);
8d2d4c67 210
d90b42a6 211=head1 DESCRIPTION
212
3fd960d9 213This is a subclass of C<Class::MOP::Method> which generates
214constructor methods.
96e38ba6 215
d90b42a6 216=head1 METHODS
217
218=over 4
219
3fd960d9 220=item B<< Class::MOP::Method::Constructor->new(%options) >>
d90b42a6 221
3fd960d9 222This creates a new constructor object. It accepts a hash reference of
223options.
96e38ba6 224
3fd960d9 225=over 8
96e38ba6 226
3fd960d9 227=item * metaclass
96e38ba6 228
3fd960d9 229This should be a L<Class::MOP::Class> object. It is required.
c23184fc 230
3fd960d9 231=item * name
d90b42a6 232
3fd960d9 233The method name (without a package name). This is required.
96e38ba6 234
3fd960d9 235=item * package_name
d90b42a6 236
3fd960d9 237The package name for the method. This is required.
c23184fc 238
3fd960d9 239=item * is_inline
96e38ba6 240
3fd960d9 241This indicates whether or not the constructor should be inlined. This
242defaults to false.
d90b42a6 243
3fd960d9 244=back
f0de47d9 245
3fd960d9 246=item B<< $metamethod->is_inline >>
f0de47d9 247
3fd960d9 248Returns a boolean indicating whether or not the constructor is
249inlined.
d90b42a6 250
3fd960d9 251=item B<< $metamethod->associated_metaclass >>
96e38ba6 252
3fd960d9 253This returns the L<Class::MOP::Class> object for the method.
d90b42a6 254
565f0cbb 255=back
256
d90b42a6 257=head1 AUTHORS
258
259Stevan Little E<lt>stevan@iinteractive.comE<gt>
260
261=head1 COPYRIGHT AND LICENSE
262
3e2c8600 263Copyright 2006-2010 by Infinity Interactive, Inc.
d90b42a6 264
265L<http://www.iinteractive.com>
266
267This library is free software; you can redistribute it and/or modify
8d2d4c67 268it under the same terms as Perl itself.
d90b42a6 269
270=cut
271