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