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