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