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