);
## --------------------------------------------------------
-## 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::Constructor
- Class::MOP::Method::Wrapped
+ Class::MOP::Method::Wrapped
/;
1;
eval {
$method = $self->accessor_metaclass->new(
attribute => $self,
- is_inline => $inline_me,
+ as_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';
+use Scalar::Util 'blessed', 'looks_like_number';
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) {
- # inline the accessors
- $metaclass->get_attribute($attr_name)
- ->install_accessors(1);
+ my $attr = $metaclass->get_attribute($attr_name);
+ $attr->install_accessors(1); # inline the accessors
}
}
if ($options{inline_constructor}) {
- my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
$metaclass->add_method(
$options{constructor_name},
- $constructor_class->new(
- options => \%options,
- meta_instance => $meta_instance,
- attributes => $metaclass->{'___compute_all_applicable_attributes'}
- )
+ $class->_generate_inline_constructor(
+ \%options,
+ $meta_instance,
+ $metaclass->{'___compute_all_applicable_attributes'}
+ )
);
}
# now cache the method map ...
- $metaclass->{'___get_method_map'} = $metaclass->get_method_map;
+ $metaclass->{'___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)->{'___get_method_map'} }
+sub get_method_map { (shift)->{'___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},
- is_inline => ($options{is_inline} || 0),
+ as_inline => ($options{as_inline} || 0),
accessor_type => $options{accessor_type},
} => $class;
sub associated_attribute { (shift)->{attribute} }
sub accessor_type { (shift)->{accessor_type} }
-sub is_inline { (shift)->{is_inline} }
+sub as_inline { (shift)->{as_inline} }
## factory
'generate',
$self->accessor_type,
'method',
- ($self->is_inline ? 'inline' : ())
+ ($self->as_inline ? 'inline' : ())
);
eval { $self->{body} = $self->$method_name() };
=item B<accessor_type>
-=item B<is_inline>
+=item B<as_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 => 29;
+use Test::More tests => 22;
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::Wrapped');
- use_ok('Class::MOP::Method::Accessor');
- use_ok('Class::MOP::Method::Constructor');
+ use_ok('Class::MOP::Method');
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::Constructor' => Class::MOP::Method::Constructor->meta,
+ 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->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::Constructor->meta,
+ Class::MOP::Method::Accessor->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::Constructor
+ Class::MOP::Method::Accessor
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