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.71_01';
  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 $source = 'sub {';
  93     $source .= "\n" . 'my $class = shift;';
  94
  95     $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
  96     $source .= "\n" . '    if $class ne \'' . $self->associated_metaclass->name . '\';';
  97
  98     $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
  99
 100     $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
 101     $source .= ";\n" . (join ";\n" => map {
 102         $self->_generate_slot_initializer($_)
 103     } 0 .. (@{$self->attributes} - 1));
 104     $source .= ";\n" . 'return $instance';
 105     $source .= ";\n" . '}';
 106     warn $source if $self->options->{debug};
 107
 108     my $code;
 109     {
 110         # NOTE:
 111         # create the nessecary lexicals
 112         # to be picked up in the eval
 113
 114         $code = $self->_eval_closure(
 115             q{my $attrs = $self->attributes;},
 116             $source
 117         );
 118         confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
 119     }
 120     return $code;
 121 }
 122
 123 sub _generate_slot_initializer {
 124     my $self  = shift;
 125     my $index = shift;
 126
 127     my $attr = $self->attributes->[$index];
 128
 129     my $default;
 130     if ($attr->has_default) {
 131         # NOTE:
 132         # default values can either be CODE refs
 133         # in which case we need to call them. Or
 134         # they can be scalars (strings/numbers)
 135         # in which case we can just deal with them
 136         # in the code we eval.
 137         if ($attr->is_default_a_coderef) {
 138             $default = '$attrs->[' . $index . ']->default($instance)';
 139         }
 140         else {
 141             $default = $attr->default;
 142             # make sure to quote strings ...
 143             unless (looks_like_number($default)) {
 144                 $default = "'$default'";
 145             }
 146         }
 147     } elsif( $attr->has_builder ) {
 148         $default = '$instance->'.$attr->builder;
 149     }
 150
 151     if ( defined $attr->init_arg ) {
 152       return (
 153           'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
 154                 $self->meta_instance->inline_set_slot_value(
 155                     '$instance',
 156                     ("'" . $attr->name . "'"),
 157                     '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
 158            '} ' . (!defined $default ? '' : 'else {' . "\n" .
 159                 $self->meta_instance->inline_set_slot_value(
 160                     '$instance',
 161                     ("'" . $attr->name . "'"),
 162                      $default ) . "\n" .
 163            '}')
 164         );
 165     } elsif ( defined $default ) {
 166         return (
 167             $self->meta_instance->inline_set_slot_value(
 168                 '$instance',
 169                 ("'" . $attr->name . "'"),
 170                  $default ) . "\n"
 171         );
 172     } else { return '' }
 173 }
 174
 175 1;
 176
 177 __END__
 178
 179 =pod
 180
 181 =head1 NAME
 182
 183 Class::MOP::Method::Constructor - Method Meta Object for constructors
 184
 185 =head1 SYNOPSIS
 186
 187   use Class::MOP::Method::Constructor;
 188
 189   my $constructor = Class::MOP::Method::Constructor->new(
 190       metaclass => $metaclass,
 191       options   => {
 192           debug => 1, # this is all for now
 193       },
 194   );
 195
 196   # calling the constructor ...
 197   $constructor->body->execute($metaclass->name, %params);
 198
 199 =head1 DESCRIPTION
 200
 201 This is a subclass of C<Class::MOP::Method> which deals with
 202 class constructors. This is used when making a class immutable
 203 to generate an optimized constructor.
 204
 205 =head1 METHODS
 206
 207 =over 4
 208
 209 =item B<new (metaclass => $meta, options => \%options)>
 210
 211 =item B<options>
 212
 213 This returns the options HASH which is passed into C<new>.
 214
 215 =item B<associated_metaclass>
 216
 217 This returns the metaclass which is passed into C<new>.
 218
 219 =item B<attributes>
 220
 221 This returns the list of attributes which are associated with the
 222 metaclass which is passed into C<new>.
 223
 224 =item B<meta_instance>
 225
 226 This returns the meta instance which is associated with the
 227 metaclass which is passed into C<new>.
 228
 229 =item B<is_inline>
 230
 231 This returns a boolean, but since constructors are very rarely
 232 not inlined, this always returns true for now.
 233
 234 =item B<can_be_inlined>
 235
 236 This method always returns true in this class. It exists so that
 237 subclasses (like in Moose) can override and do some sort of checking
 238 to determine whether or not inlining the constructor is safe.
 239
 240 =item B<initialize_body>
 241
 242 This creates the code reference for the constructor itself.
 243
 244 =back
 245
 246 =head2 Method Generators
 247
 248 =over 4
 249
 250 =item B<generate_constructor_method>
 251
 252 =item B<generate_constructor_method_inline>
 253
 254 =back
 255
 256 =head1 AUTHORS
 257
 258 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 259
 260 =head1 COPYRIGHT AND LICENSE
 261
 262 Copyright 2006-2008 by Infinity Interactive, Inc.
 263
 264 L<http://www.iinteractive.com>
 265
 266 This library is free software; you can redistribute it and/or modify
 267 it under the same terms as Perl itself.
 268
 269 =cut
 270