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';
   9 use Try::Tiny;
  10
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Method::Inlined';
  14
  15 sub new {
  16     my $class   = shift;
  17     my %options = @_;
  18
  19     (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
  20         || confess "You must pass a metaclass instance if you want to inline"
  21             if $options{is_inline};
  22
  23     ($options{package_name} && $options{name})
  24         || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  25
  26     my $self = $class->_new(\%options);
  27
  28     # we don't want this creating
  29     # a cycle in the code, if not
  30     # needed
  31     weaken($self->{'associated_metaclass'});
  32
  33     $self->_initialize_body;
  34
  35     return $self;
  36 }
  37
  38 sub _new {
  39     my $class = shift;
  40
  41     return Class::MOP::Class->initialize($class)->new_object(@_)
  42         if $class ne __PACKAGE__;
  43
  44     my $params = @_ == 1 ? $_[0] : {@_};
  45
  46     return bless {
  47         # inherited from Class::MOP::Method
  48         body                 => $params->{body},
  49         # associated_metaclass => $params->{associated_metaclass}, # overriden
  50         package_name         => $params->{package_name},
  51         name                 => $params->{name},
  52         original_method      => $params->{original_method},
  53
  54         # inherited from Class::MOP::Generated
  55         is_inline            => $params->{is_inline} || 0,
  56         definition_context   => $params->{definition_context},
  57
  58         # inherited from Class::MOP::Inlined
  59         _expected_method_class => $params->{_expected_method_class},
  60
  61         # defined in this subclass
  62         options              => $params->{options} || {},
  63         associated_metaclass => $params->{metaclass},
  64     }, $class;
  65 }
  66
  67 ## accessors
  68
  69 sub options              { (shift)->{'options'}              }
  70 sub associated_metaclass { (shift)->{'associated_metaclass'} }
  71
  72 ## cached values ...
  73
  74 sub _attributes {
  75     my $self = shift;
  76     $self->{'attributes'} ||= [
  77         sort { $a->name cmp $b->name }
  78              $self->associated_metaclass->get_all_attributes
  79     ]
  80 }
  81
  82 ## method
  83
  84 sub _initialize_body {
  85     my $self        = shift;
  86     my $method_name = '_generate_constructor_method';
  87
  88     $method_name .= '_inline' if $self->is_inline;
  89
  90     $self->{'body'} = $self->$method_name;
  91 }
  92
  93 sub _eval_environment {
  94     my $self = shift;
  95     my $defaults = [map { $_->default } @{ $self->_attributes }];
  96     return {
  97         '$defaults' => \$defaults,
  98     };
  99 }
 100
 101 sub _generate_constructor_method {
 102     return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
 103 }
 104
 105 sub _generate_constructor_method_inline {
 106     my $self = shift;
 107
 108     my $meta = $self->associated_metaclass;
 109
 110     my @source = (
 111         'sub {',
 112             $meta->_inline_new_object,
 113         '}',
 114     );
 115
 116     warn join("\n", @source) if $self->options->{debug};
 117
 118     my $code = try {
 119         $self->_compile_code(\@source);
 120     }
 121     catch {
 122         my $source = join("\n", @source);
 123         confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_";
 124     };
 125
 126     return $code;
 127 }
 128
 129 1;
 130
 131 # ABSTRACT: Method Meta Object for constructors
 132
 133 __END__
 134
 135 =pod
 136
 137 =head1 SYNOPSIS
 138
 139   use Class::MOP::Method::Constructor;
 140
 141   my $constructor = Class::MOP::Method::Constructor->new(
 142       metaclass => $metaclass,
 143       options   => {
 144           debug => 1, # this is all for now
 145       },
 146   );
 147
 148   # calling the constructor ...
 149   $constructor->body->execute($metaclass->name, %params);
 150
 151 =head1 DESCRIPTION
 152
 153 This is a subclass of C<Class::MOP::Method> which generates
 154 constructor methods.
 155
 156 =head1 METHODS
 157
 158 =over 4
 159
 160 =item B<< Class::MOP::Method::Constructor->new(%options) >>
 161
 162 This creates a new constructor object. It accepts a hash reference of
 163 options.
 164
 165 =over 8
 166
 167 =item * metaclass
 168
 169 This should be a L<Class::MOP::Class> object. It is required.
 170
 171 =item * name
 172
 173 The method name (without a package name). This is required.
 174
 175 =item * package_name
 176
 177 The package name for the method. This is required.
 178
 179 =item * is_inline
 180
 181 This indicates whether or not the constructor should be inlined. This
 182 defaults to false.
 183
 184 =back
 185
 186 =item B<< $metamethod->is_inline >>
 187
 188 Returns a boolean indicating whether or not the constructor is
 189 inlined.
 190
 191 =item B<< $metamethod->associated_metaclass >>
 192
 193 This returns the L<Class::MOP::Class> object for the method.
 194
 195 =back
 196
 197 =cut
 198