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