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     warn 'The initialize_body method has been made private.'
  78         . " The public version is deprecated and will be removed in a future release.\n";
  79     goto &_initialize_body;
  80 }
  81
  82 sub _initialize_body {
  83     my $self        = shift;
  84     my $method_name = '_generate_constructor_method';
  85
  86     $method_name .= '_inline' if $self->is_inline;
  87
  88     $self->{'body'} = $self->$method_name;
  89 }
  90
  91 sub generate_constructor_method {
  92     warn 'The generate_constructor_method method has been made private.'
  93         . " The public version is deprecated and will be removed in a future release.\n";
  94     goto &_generate_constructor_method;
  95 }
  96
  97 sub _generate_constructor_method {
  98     return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
  99 }
 100
 101 sub generate_constructor_method_inline {
 102     warn 'The generate_constructor_method_inline method has been made private.'
 103         . " The public version is deprecated and will be removed in a future release.\n";
 104     goto &_generate_constructor_method_inline;
 105 }
 106
 107 sub _generate_constructor_method_inline {
 108     my $self = shift;
 109
 110     my $close_over = {};
 111
 112     my $source = 'sub {';
 113     $source .= "\n" . 'my $class = shift;';
 114
 115     $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
 116     $source .= "\n" . '    if $class ne \'' . $self->associated_metaclass->name . '\';';
 117
 118     $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
 119
 120     $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
 121     $source .= ";\n" . (join ";\n" => map {
 122         $self->_generate_slot_initializer($_, $close_over)
 123     } @{$self->attributes});
 124     $source .= ";\n" . 'return $instance';
 125     $source .= ";\n" . '}';
 126     warn $source if $self->options->{debug};
 127
 128     my $code = $self->_eval_closure(
 129         $close_over,
 130         $source
 131     );
 132     confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
 133
 134     return $code;
 135 }
 136
 137 sub _generate_slot_initializer {
 138     my $self  = shift;
 139     my $attr  = shift;
 140     my $close = shift;
 141
 142     my $default;
 143     if ($attr->has_default) {
 144         # NOTE:
 145         # default values can either be CODE refs
 146         # in which case we need to call them. Or
 147         # they can be scalars (strings/numbers)
 148         # in which case we can just deal with them
 149         # in the code we eval.
 150         if ($attr->is_default_a_coderef) {
 151             my $idx = @{$close->{'@defaults'}||=[]};
 152             push(@{$close->{'@defaults'}}, $attr->default);
 153             $default = '$defaults[' . $idx . ']->($instance)';
 154         }
 155         else {
 156             $default = $attr->default;
 157             # make sure to quote strings ...
 158             unless (looks_like_number($default)) {
 159                 $default = "'$default'";
 160             }
 161         }
 162     } elsif( $attr->has_builder ) {
 163         $default = '$instance->'.$attr->builder;
 164     }
 165
 166     if ( defined $attr->init_arg ) {
 167       return (
 168           'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
 169                 $self->meta_instance->inline_set_slot_value(
 170                     '$instance',
 171                     $attr->name,
 172                     '$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
 173            '} ' . (!defined $default ? '' : 'else {' . "\n" .
 174                 $self->meta_instance->inline_set_slot_value(
 175                     '$instance',
 176                     $attr->name,
 177                      $default ) . "\n" .
 178            '}')
 179         );
 180     } elsif ( defined $default ) {
 181         return (
 182             $self->meta_instance->inline_set_slot_value(
 183                 '$instance',
 184                 $attr->name,
 185                  $default ) . "\n"
 186         );
 187     } else { return '' }
 188 }
 189
 190 1;
 191
 192 __END__
 193
 194 =pod
 195
 196 =head1 NAME
 197
 198 Class::MOP::Method::Constructor - Method Meta Object for constructors
 199
 200 =head1 SYNOPSIS
 201
 202   use Class::MOP::Method::Constructor;
 203
 204   my $constructor = Class::MOP::Method::Constructor->new(
 205       metaclass => $metaclass,
 206       options   => {
 207           debug => 1, # this is all for now
 208       },
 209   );
 210
 211   # calling the constructor ...
 212   $constructor->body->execute($metaclass->name, %params);
 213
 214 =head1 DESCRIPTION
 215
 216 This is a subclass of C<Class::MOP::Method> which generates
 217 constructor methods.
 218
 219 =head1 METHODS
 220
 221 =over 4
 222
 223 =item B<< Class::MOP::Method::Constructor->new(%options) >>
 224
 225 This creates a new constructor object. It accepts a hash reference of
 226 options.
 227
 228 =over 8
 229
 230 =item * metaclass
 231
 232 This should be a L<Class::MOP::Class> object. It is required.
 233
 234 =item * name
 235
 236 The method name (without a package name). This is required.
 237
 238 =item * package_name
 239
 240 The package name for the method. This is required.
 241
 242 =item * is_inline
 243
 244 This indicates whether or not the constructor should be inlined. This
 245 defaults to false.
 246
 247 =back
 248
 249 =item B<< $metamethod->is_inline >>
 250
 251 Returns a boolean indicating whether or not the constructor is
 252 inlined.
 253
 254 =item B<< $metamethod->associated_metaclass >>
 255
 256 This returns the L<Class::MOP::Class> object for the method.
 257
 258 =item B<< $metamethod->is_inline >>
 259
 260 Returns a boolean indicating whether or not the constructor is
 261 inlined.
 262
 263 =item B<< $metamethod->can_be_inlined >>
 264
 265 This method always returns true in this class. It exists so that
 266 subclasses (as in Moose) can do some sort of checking to determine
 267 whether or not inlining the constructor is safe.
 268
 269 =back
 270
 271 =head1 AUTHORS
 272
 273 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 274
 275 =head1 COPYRIGHT AND LICENSE
 276
 277 Copyright 2006-2009 by Infinity Interactive, Inc.
 278
 279 L<http://www.iinteractive.com>
 280
 281 This library is free software; you can redistribute it and/or modify
 282 it under the same terms as Perl itself.
 283
 284 =cut
 285