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