);
## --------------------------------------------------------
+## Class::MOP::Method::Accessor
+
+Class::MOP::Method::Accessor->meta->add_attribute(
+ Class::MOP::Attribute->new('attribute' => (
+ reader => {
+ 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute
+ },
+ ))
+);
+
+Class::MOP::Method::Accessor->meta->add_attribute(
+ Class::MOP::Attribute->new('accessor_type' => (
+ reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type },
+ ))
+);
+
+Class::MOP::Method::Accessor->meta->add_attribute(
+ Class::MOP::Attribute->new('is_inline' => (
+ reader => { 'is_inline' => \&Class::MOP::Method::Accessor::is_inline },
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Method::Constructor
+
+Class::MOP::Method::Constructor->meta->add_attribute(
+ Class::MOP::Attribute->new('options' => (
+ reader => {
+ 'options' => \&Class::MOP::Method::Constructor::options
+ },
+ ))
+);
+
+Class::MOP::Method::Constructor->meta->add_attribute(
+ Class::MOP::Attribute->new('meta_instance' => (
+ reader => {
+ 'meta_instance' => \&Class::MOP::Method::Constructor::meta_instance
+ },
+ ))
+);
+
+Class::MOP::Method::Constructor->meta->add_attribute(
+ Class::MOP::Attribute->new('attributes' => (
+ reader => {
+ 'attributes' => \&Class::MOP::Method::Constructor::attributes
+ },
+ ))
+);
+
+## --------------------------------------------------------
## Class::MOP::Instance
# NOTE:
Class::MOP::Object
Class::MOP::Method::Accessor
- Class::MOP::Method::Wrapped
+ Class::MOP::Method::Constructor
+ Class::MOP::Method::Wrapped
/;
1;
eval {
$method = $self->accessor_metaclass->new(
attribute => $self,
- as_inline => $inline_me,
+ is_inline => $inline_me,
accessor_type => $type,
);
};
: blessed($class))
: $class);
- $class = blessed($class) || $class;
# now create the metaclass
my $meta;
if ($class =~ /^Class::MOP::Class$/) {
use strict;
use warnings;
+use Class::MOP::Method::Constructor;
+
use Carp 'confess';
-use Scalar::Util 'blessed', 'looks_like_number';
+use Scalar::Util 'blessed';
our $VERSION = '0.03';
our $AUTHORITY = 'cpan:STEVAN';
};
}
-sub get_package_symbol {
- my ($self, $variable) = @_;
- my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
- return *{$self->namespace->{$name}}{$type}
- if exists $self->namespace->{$name};
- # NOTE:
- # we have to do this here in order to preserve
- # perl's autovivification of variables. However
- # we do cut off direct access to add_package_symbol
- # as shown above.
- $self->Class::MOP::Package::add_package_symbol($variable);
-}
-
# NOTE:
# superclasses is an accessor, so
# it just cannot be changed
if ($options{inline_accessors}) {
foreach my $attr_name ($metaclass->get_attribute_list) {
- my $attr = $metaclass->get_attribute($attr_name);
- $attr->install_accessors(1); # inline the accessors
+ # inline the accessors
+ $metaclass->get_attribute($attr_name)
+ ->install_accessors(1);
}
}
if ($options{inline_constructor}) {
+ my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
$metaclass->add_method(
$options{constructor_name},
- $class->_generate_inline_constructor(
- \%options,
- $meta_instance,
- $metaclass->{'___compute_all_applicable_attributes'}
- )
+ $constructor_class->new(
+ options => \%options,
+ meta_instance => $meta_instance,
+ attributes => $metaclass->{'___compute_all_applicable_attributes'}
+ )
);
}
# now cache the method map ...
- $metaclass->{'___method_map'} = $metaclass->get_method_map;
+ $metaclass->{'___get_method_map'} = $metaclass->get_method_map;
bless $metaclass => $class;
}
-sub _generate_inline_constructor {
- my ($class, $options, $meta_instance, $attrs) = @_;
- # TODO:
- # the %options should also include a both
- # a call 'initializer' and call 'SUPER::'
- # options, which should cover approx 90%
- # of the possible use cases (even if it
- # requires some adaption on the part of
- # the author, after all, nothing is free)
- my $source = 'sub {';
- $source .= "\n" . 'my ($class, %params) = @_;';
- $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
- $source .= ";\n" . (join ";\n" => map {
- $class->_generate_slot_initializer($meta_instance, $attrs, $_)
- } 0 .. (@$attrs - 1));
- $source .= ";\n" . 'return $instance';
- $source .= ";\n" . '}';
- warn $source if $options->{debug};
- my $code = eval $source;
- confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
- return $code;
-}
-
-sub _generate_slot_initializer {
- my ($class, $meta_instance, $attrs, $index) = @_;
- my $attr = $attrs->[$index];
- my $default;
- if ($attr->has_default) {
- # NOTE:
- # default values can either be CODE refs
- # in which case we need to call them. Or
- # they can be scalars (strings/numbers)
- # in which case we can just deal with them
- # in the code we eval.
- if ($attr->is_default_a_coderef) {
- $default = '$attrs->[' . $index . ']->default($instance)';
- }
- else {
- $default = $attrs->[$index]->default;
- # make sure to quote strings ...
- unless (looks_like_number($default)) {
- $default = "'$default'";
- }
- }
- }
- $meta_instance->inline_set_slot_value(
- '$instance',
- ("'" . $attr->name . "'"),
- ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
- )
-}
-
# cached methods
sub get_meta_instance { (shift)->{'___get_meta_instance'} }
sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
sub get_mutable_metaclass_name { (shift)->{'___original_class'} }
-sub get_method_map { (shift)->{'___method_map'} }
+sub get_method_map { (shift)->{'___get_method_map'} }
1;
This method becomes read-only in an immutable class.
-=item B<get_package_symbol>
-
-This method must handle package variable autovivification
-correctly, while still disallowing C<add_package_symbol>.
-
=back
=head2 Cached methods
body => undef,
# specific to this subclass
attribute => $options{attribute},
- as_inline => ($options{as_inline} || 0),
+ is_inline => ($options{is_inline} || 0),
accessor_type => $options{accessor_type},
} => $class;
sub associated_attribute { (shift)->{attribute} }
sub accessor_type { (shift)->{accessor_type} }
-sub as_inline { (shift)->{as_inline} }
+sub is_inline { (shift)->{is_inline} }
## factory
'generate',
$self->accessor_type,
'method',
- ($self->as_inline ? 'inline' : ())
+ ($self->is_inline ? 'inline' : ())
);
eval { $self->{body} = $self->$method_name() };
=item B<accessor_type>
-=item B<as_inline>
+=item B<is_inline>
=item B<associated_attribute>
Stevan Little E<lt>stevan@iinteractive.comE<gt>
-Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
-
=head1 COPYRIGHT AND LICENSE
Copyright 2006 by Infinity Interactive, Inc.
--- /dev/null
+
+package Class::MOP::Method::Constructor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method';
+
+sub new {
+ my $class = shift;
+ my %options = @_;
+
+ (exists $options{options} && ref $options{options} eq 'HASH')
+ || confess "You must pass a hash of options";
+
+ (blessed $options{meta_instance} && $options{meta_instance}->isa('Class::MOP::Instance'))
+ || confess "You must supply a meta-instance";
+
+ (exists $options{attributes} && ref $options{attributes} eq 'ARRAY')
+ || confess "You must pass an array of options";
+
+ (blessed($_) && $_->isa('Class::MOP::Attribute'))
+ || confess "You must supply a list of attributes which is a 'Class::MOP::Attribute' instance"
+ for @{$options{attributes}};
+
+ my $self = bless {
+ # from our superclass
+ body => undef,
+ # specific to this subclass
+ options => $options{options},
+ meta_instance => $options{meta_instance},
+ attributes => $options{attributes},
+ } => $class;
+
+ # we don't want this creating
+ # a cycle in the code, if not
+ # needed
+ weaken($self->{meta_instance});
+
+ $self->intialize_body;
+
+ return $self;
+}
+
+## accessors
+
+sub options { (shift)->{options} }
+sub meta_instance { (shift)->{meta_instance} }
+sub attributes { (shift)->{attributes} }
+
+## method
+
+sub intialize_body {
+ my $self = shift;
+ # TODO:
+ # the %options should also include a both
+ # a call 'initializer' and call 'SUPER::'
+ # options, which should cover approx 90%
+ # of the possible use cases (even if it
+ # requires some adaption on the part of
+ # the author, after all, nothing is free)
+ my $source = 'sub {';
+ $source .= "\n" . 'my ($class, %params) = @_;';
+ $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
+ $source .= ";\n" . (join ";\n" => map {
+ $self->_generate_slot_initializer($_)
+ } 0 .. (@{$self->attributes} - 1));
+ $source .= ";\n" . 'return $instance';
+ $source .= ";\n" . '}';
+ warn $source if $self->options->{debug};
+
+ my $code;
+ {
+ # NOTE:
+ # create the nessecary lexicals
+ # to be picked up in the eval
+ my $attrs = $self->attributes;
+
+ $code = eval $source;
+ confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
+ }
+ $self->{body} = $code;
+}
+
+sub _generate_slot_initializer {
+ my $self = shift;
+ my $index = shift;
+
+ my $attr = $self->attributes->[$index];
+
+ my $default;
+ if ($attr->has_default) {
+ # NOTE:
+ # default values can either be CODE refs
+ # in which case we need to call them. Or
+ # they can be scalars (strings/numbers)
+ # in which case we can just deal with them
+ # in the code we eval.
+ if ($attr->is_default_a_coderef) {
+ $default = '$attrs->[' . $index . ']->default($instance)';
+ }
+ else {
+ $default = $attr->default;
+ # make sure to quote strings ...
+ unless (looks_like_number($default)) {
+ $default = "'$default'";
+ }
+ }
+ }
+ $self->meta_instance->inline_set_slot_value(
+ '$instance',
+ ("'" . $attr->name . "'"),
+ ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
+ );
+}
+
+1;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Method::Constructor - Method Meta Object for constructors
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<attributes>
+
+=item B<meta_instance>
+
+=item B<options>
+
+=item B<intialize_body>
+
+=back
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
use strict;
use warnings;
-use Test::More tests => 22;
+use Test::More tests => 29;
BEGIN {
use_ok('Class::MOP');
+ use_ok('Class::MOP::Package');
+ use_ok('Class::MOP::Module');
use_ok('Class::MOP::Class');
+ use_ok('Class::MOP::Class::Immutable');
use_ok('Class::MOP::Attribute');
- use_ok('Class::MOP::Method');
+ use_ok('Class::MOP::Method');
+ use_ok('Class::MOP::Method::Wrapped');
+ use_ok('Class::MOP::Method::Accessor');
+ use_ok('Class::MOP::Method::Constructor');
use_ok('Class::MOP::Instance');
use_ok('Class::MOP::Object');
}
my %METAS = (
'Class::MOP::Attribute' => Class::MOP::Attribute->meta,
- 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta,
+ 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta,
+ 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta,
'Class::MOP::Package' => Class::MOP::Package->meta,
'Class::MOP::Module' => Class::MOP::Module->meta,
- 'Class::MOP::Class' => Class::MOP::Class->meta,
+ 'Class::MOP::Class' => Class::MOP::Class->meta,
'Class::MOP::Method' => Class::MOP::Method->meta,
'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta,
'Class::MOP::Instance' => Class::MOP::Instance->meta,
Class::MOP::Class->meta,
Class::MOP::Instance->meta,
Class::MOP::Method->meta,
- Class::MOP::Method::Accessor->meta,
+ Class::MOP::Method::Accessor->meta,
+ Class::MOP::Method::Constructor->meta,
Class::MOP::Method::Wrapped->meta,
Class::MOP::Module->meta,
Class::MOP::Object->meta,
Class::MOP::Class
Class::MOP::Instance
Class::MOP::Method
- Class::MOP::Method::Accessor
+ Class::MOP::Method::Accessor
+ Class::MOP::Method::Constructor
Class::MOP::Method::Wrapped
Class::MOP::Module
Class::MOP::Object
"Class::MOP::Instance-" . $Class::MOP::Instance::VERSION . "-cpan:STEVAN",
"Class::MOP::Method-" . $Class::MOP::Method::VERSION . "-cpan:STEVAN",
"Class::MOP::Method::Accessor-" . $Class::MOP::Method::Accessor::VERSION . "-cpan:STEVAN",
+ "Class::MOP::Method::Constructor-" . $Class::MOP::Method::Constructor::VERSION . "-cpan:STEVAN",
"Class::MOP::Method::Wrapped-" . $Class::MOP::Method::Wrapped::VERSION . "-cpan:STEVAN",
"Class::MOP::Module-" . $Class::MOP::Module::VERSION . "-cpan:STEVAN",
"Class::MOP::Object-" . $Class::MOP::Object::VERSION . "-cpan:STEVAN",
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 76;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Class::Immutable');
+}
+
+{
+ package Foo;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->add_attribute('bar' => (
+ reader => 'bar',
+ default => 'BAR',
+ ));
+
+ package Bar;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->superclasses('Foo');
+
+ __PACKAGE__->meta->add_attribute('baz' => (
+ reader => 'baz',
+ default => sub { 'BAZ' },
+ ));
+
+ package Baz;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ __PACKAGE__->meta->superclasses('Bar');
+
+ __PACKAGE__->meta->add_attribute('bah' => (
+ reader => 'bah',
+ default => 'BAH',
+ ));
+}
+
+{
+ my $meta = Foo->meta;
+ is($meta->name, 'Foo', '... checking the Foo metaclass');
+
+ {
+ my $bar_accessor = $meta->get_method('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
+ }
+
+ ok(!$meta->is_immutable, '... our class is not immutable');
+
+ lives_ok {
+ $meta->make_immutable(
+ inline_constructor => 1,
+ inline_accessors => 0,
+ );
+ } '... changed Foo to be immutable';
+
+ ok($meta->is_immutable, '... our class is now immutable');
+ isa_ok($meta, 'Class::MOP::Class::Immutable');
+ isa_ok($meta, 'Class::MOP::Class');
+
+ # they made a constructor for us :)
+ can_ok('Foo', 'new');
+
+ {
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+ is($foo->bar, 'BAR', '... got the right default value');
+ }
+
+ {
+ my $foo = Foo->new(bar => 'BAZ');
+ isa_ok($foo, 'Foo');
+ is($foo->bar, 'BAZ', '... got the right parameter value');
+ }
+
+ # check out accessors too
+ {
+ my $bar_accessor = $meta->get_method('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
+ }
+}
+
+{
+ my $meta = Bar->meta;
+ is($meta->name, 'Bar', '... checking the Bar metaclass');
+
+ {
+ my $bar_accessor = $meta->find_method_by_name('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
+
+ my $baz_accessor = $meta->get_method('baz');
+ isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($baz_accessor, 'Class::MOP::Method');
+
+ ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined');
+ }
+
+ ok(!$meta->is_immutable, '... our class is not immutable');
+
+ lives_ok {
+ $meta->make_immutable(
+ inline_constructor => 1,
+ inline_accessors => 1,
+ );
+ } '... changed Bar to be immutable';
+
+ ok($meta->is_immutable, '... our class is now immutable');
+ isa_ok($meta, 'Class::MOP::Class::Immutable');
+ isa_ok($meta, 'Class::MOP::Class');
+
+ # they made a constructor for us :)
+ can_ok('Bar', 'new');
+
+ {
+ my $bar = Bar->new;
+ isa_ok($bar, 'Bar');
+ is($bar->bar, 'BAR', '... got the right default value');
+ is($bar->baz, 'BAZ', '... got the right default value');
+ }
+
+ {
+ my $bar = Bar->new(bar => 'BAZ!', baz => 'BAR!');
+ isa_ok($bar, 'Bar');
+ is($bar->bar, 'BAZ!', '... got the right parameter value');
+ is($bar->baz, 'BAR!', '... got the right parameter value');
+ }
+
+ # check out accessors too
+ {
+ my $bar_accessor = $meta->find_method_by_name('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
+
+ my $baz_accessor = $meta->get_method('baz');
+ isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($baz_accessor, 'Class::MOP::Method');
+
+ ok($baz_accessor->is_inline, '... the baz accessor is not inlined');
+ }
+}
+
+{
+ my $meta = Baz->meta;
+ is($meta->name, 'Baz', '... checking the Bar metaclass');
+
+ {
+ my $bar_accessor = $meta->find_method_by_name('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined');
+
+ my $baz_accessor = $meta->find_method_by_name('baz');
+ isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($baz_accessor, 'Class::MOP::Method');
+
+ ok($baz_accessor->is_inline, '... the baz accessor is inlined');
+
+ my $bah_accessor = $meta->get_method('bah');
+ isa_ok($bah_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bah_accessor, 'Class::MOP::Method');
+
+ ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined');
+ }
+
+ ok(!$meta->is_immutable, '... our class is not immutable');
+
+ lives_ok {
+ $meta->make_immutable(
+ inline_constructor => 0,
+ inline_accessors => 1,
+ );
+ } '... changed Bar to be immutable';
+
+ ok($meta->is_immutable, '... our class is now immutable');
+ isa_ok($meta, 'Class::MOP::Class::Immutable');
+ isa_ok($meta, 'Class::MOP::Class');
+
+ ok(!Baz->meta->has_method('new'), '... no constructor was made');
+
+ {
+ my $baz = Baz->meta->construct_instance;
+ isa_ok($baz, 'Bar');
+ is($baz->bar, 'BAR', '... got the right default value');
+ is($baz->baz, 'BAZ', '... got the right default value');
+ }
+
+ {
+ my $baz = Baz->meta->construct_instance(bar => 'BAZ!', baz => 'BAR!', bah => 'BAH!');
+ isa_ok($baz, 'Baz');
+ is($baz->bar, 'BAZ!', '... got the right parameter value');
+ is($baz->baz, 'BAR!', '... got the right parameter value');
+ is($baz->bah, 'BAH!', '... got the right parameter value');
+ }
+
+ # check out accessors too
+ {
+ my $bar_accessor = $meta->find_method_by_name('bar');
+ isa_ok($bar_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bar_accessor, 'Class::MOP::Method');
+
+ ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined');
+
+ my $baz_accessor = $meta->find_method_by_name('baz');
+ isa_ok($baz_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($baz_accessor, 'Class::MOP::Method');
+
+ ok($baz_accessor->is_inline, '... the baz accessor is not inlined');
+
+ my $bah_accessor = $meta->get_method('bah');
+ isa_ok($bah_accessor, 'Class::MOP::Method::Accessor');
+ isa_ok($bah_accessor, 'Class::MOP::Method');
+
+ ok($bah_accessor->is_inline, '... the baz accessor is not inlined');
+ }
+}
+
projects / gitmo/Class-MOP.git / commitdiff