lib/Class/MOP/Method/Constructor.pm

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