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