just adjusting versions and writing changes
[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';
8use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
9
6c34db07 10our $VERSION = '0.05';
d90b42a6 11our $AUTHORITY = 'cpan:STEVAN';
12
565f0cbb 13use base 'Class::MOP::Method::Generated';
d90b42a6 14
15sub new {
16 my $class = shift;
17 my %options = @_;
8d2d4c67 18
ad315b75 19 (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
20 || confess "You must pass a metaclass instance if you want to inline"
8d2d4c67 21 if $options{is_inline};
22
b38f3848 23 ($options{package_name} && $options{name})
24 || confess "You must supply the package_name and name parameters";
25
d90b42a6 26 my $self = bless {
27 # from our superclass
4c105333 28 '&!body' => undef,
29 '$!package_name' => $options{package_name},
30 '$!name' => $options{name},
d90b42a6 31 # specific to this subclass
ad315b75 32 '%!options' => $options{options} || {},
c23184fc 33 '$!associated_metaclass' => $options{metaclass},
8d2d4c67 34 '$!is_inline' => ($options{is_inline} || 0),
d90b42a6 35 } => $class;
36
8d2d4c67 37 # we don't want this creating
38 # a cycle in the code, if not
d90b42a6 39 # needed
8d2d4c67 40 weaken($self->{'$!associated_metaclass'});
d90b42a6 41
565f0cbb 42 $self->initialize_body;
d90b42a6 43
8d2d4c67 44 return $self;
d90b42a6 45}
46
8d2d4c67 47## accessors
c23184fc 48
565f0cbb 49sub options { (shift)->{'%!options'} }
50sub associated_metaclass { (shift)->{'$!associated_metaclass'} }
c23184fc 51
565f0cbb 52## cached values ...
d90b42a6 53
8d2d4c67 54sub meta_instance {
565f0cbb 55 my $self = shift;
56 $self->{'$!meta_instance'} ||= $self->associated_metaclass->get_meta_instance;
57}
c23184fc 58
8d2d4c67 59sub attributes {
565f0cbb 60 my $self = shift;
61 $self->{'@!attributes'} ||= [ $self->associated_metaclass->compute_all_applicable_attributes ]
62}
d90b42a6 63
64## method
65
565f0cbb 66sub initialize_body {
67 my $self = shift;
68 my $method_name = 'generate_constructor_method';
8d2d4c67 69
565f0cbb 70 $method_name .= '_inline' if $self->is_inline;
8d2d4c67 71
565f0cbb 72 $self->{'&!body'} = $self->$method_name;
73}
74
75sub generate_constructor_method {
2a2b8458 76 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
565f0cbb 77}
78
79sub generate_constructor_method_inline {
d90b42a6 80 my $self = shift;
565f0cbb 81
d90b42a6 82 my $source = 'sub {';
83 $source .= "\n" . 'my ($class, %params) = @_;';
8d2d4c67 84
2a2b8458 85 $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(%params)';
8d2d4c67 86 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
87
d90b42a6 88 $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
8d2d4c67 89 $source .= ";\n" . (join ";\n" => map {
90 $self->_generate_slot_initializer($_)
d90b42a6 91 } 0 .. (@{$self->attributes} - 1));
92 $source .= ";\n" . 'return $instance';
8d2d4c67 93 $source .= ";\n" . '}';
94 warn $source if $self->options->{debug};
95
d90b42a6 96 my $code;
97 {
98 # NOTE:
99 # create the nessecary lexicals
8d2d4c67 100 # to be picked up in the eval
d90b42a6 101 my $attrs = $self->attributes;
8d2d4c67 102
d90b42a6 103 $code = eval $source;
104 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
105 }
565f0cbb 106 return $code;
d90b42a6 107}
108
109sub _generate_slot_initializer {
110 my $self = shift;
111 my $index = shift;
8d2d4c67 112
d90b42a6 113 my $attr = $self->attributes->[$index];
8d2d4c67 114
d90b42a6 115 my $default;
116 if ($attr->has_default) {
117 # NOTE:
118 # default values can either be CODE refs
8d2d4c67 119 # in which case we need to call them. Or
d90b42a6 120 # they can be scalars (strings/numbers)
121 # in which case we can just deal with them
122 # in the code we eval.
123 if ($attr->is_default_a_coderef) {
124 $default = '$attrs->[' . $index . ']->default($instance)';
125 }
126 else {
127 $default = $attr->default;
128 # make sure to quote strings ...
129 unless (looks_like_number($default)) {
130 $default = "'$default'";
131 }
132 }
8d2d4c67 133 } elsif( $attr->has_builder ) {
134 $default = '$instance->'.$attr->builder;
d90b42a6 135 }
8d2d4c67 136
c16c9c1b 137 if ( defined $attr->init_arg ) {
138 return (
139 'if(exists $params{\'' . $attr->init_arg . '\'}){' . "\n" .
140 $self->meta_instance->inline_set_slot_value(
141 '$instance',
142 ("'" . $attr->name . "'"),
143 '$params{\'' . $attr->init_arg . '\'}' ) . "\n" .
144 '} ' . (!defined $default ? '' : 'else {' . "\n" .
145 $self->meta_instance->inline_set_slot_value(
146 '$instance',
147 ("'" . $attr->name . "'"),
148 $default ) . "\n" .
149 '}')
150 );
151 } elsif ( defined $default ) {
152 return (
153 $self->meta_instance->inline_set_slot_value(
154 '$instance',
155 ("'" . $attr->name . "'"),
156 $default ) . "\n"
157 );
158 } else { return '' }
d90b42a6 159}
160
1611;
162
1631;
164
165__END__
166
167=pod
168
8d2d4c67 169=head1 NAME
d90b42a6 170
171Class::MOP::Method::Constructor - Method Meta Object for constructors
172
173=head1 SYNOPSIS
174
96e38ba6 175 use Class::MOP::Method::Constructor;
8d2d4c67 176
96e38ba6 177 my $constructor = Class::MOP::Method::Constructor->new(
8d2d4c67 178 metaclass => $metaclass,
96e38ba6 179 options => {
180 debug => 1, # this is all for now
8d2d4c67 181 },
96e38ba6 182 );
8d2d4c67 183
96e38ba6 184 # calling the constructor ...
185 $constructor->body->($metaclass->name, %params);
8d2d4c67 186
d90b42a6 187=head1 DESCRIPTION
188
8d2d4c67 189This is a subclass of C<Class::MOP::Method> which deals with
127d39a7 190class constructors. This is used when making a class immutable
191to generate an optimized constructor.
96e38ba6 192
d90b42a6 193=head1 METHODS
194
195=over 4
196
96e38ba6 197=item B<new (metaclass => $meta, options => \%options)>
d90b42a6 198
96e38ba6 199=item B<options>
200
201This returns the options HASH which is passed into C<new>.
202
203=item B<associated_metaclass>
204
205This returns the metaclass which is passed into C<new>.
c23184fc 206
d90b42a6 207=item B<attributes>
208
8d2d4c67 209This returns the list of attributes which are associated with the
96e38ba6 210metaclass which is passed into C<new>.
211
d90b42a6 212=item B<meta_instance>
213
8d2d4c67 214This returns the meta instance which is associated with the
96e38ba6 215metaclass which is passed into C<new>.
c23184fc 216
96e38ba6 217=item B<is_inline>
218
8d2d4c67 219This returns a boolean, but since constructors are very rarely
96e38ba6 220not inlined, this always returns true for now.
d90b42a6 221
565f0cbb 222=item B<initialize_body>
d90b42a6 223
8d2d4c67 224This creates the code reference for the constructor itself.
96e38ba6 225
d90b42a6 226=back
227
127d39a7 228=head2 Method Generators
565f0cbb 229
230=over 4
231
232=item B<generate_constructor_method>
233
234=item B<generate_constructor_method_inline>
235
236=back
237
d90b42a6 238=head1 AUTHORS
239
240Stevan Little E<lt>stevan@iinteractive.comE<gt>
241
242=head1 COPYRIGHT AND LICENSE
243
69e3ab0a 244Copyright 2006-2008 by Infinity Interactive, Inc.
d90b42a6 245
246L<http://www.iinteractive.com>
247
248This library is free software; you can redistribute it and/or modify
8d2d4c67 249it under the same terms as Perl itself.
d90b42a6 250
251=cut
252