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