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