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