Revision history for Perl extension Class-MOP.
+0.43
+ * Class::MOP::Method::Accessor
+ - made this a subclass of Class::MOP::Method::Generated
+ - removed the relevant attributes
+
+ * Class::MOP::Method::Constructor
+ - fixed the cached values we had to be more sane
+ - made this a subclass of Class::MOP::Method::Generated
+ - fixed generated constructor so it properly handles
+ subclasses now.
+ - added tests for this
+ - added the option to allow for both inlined and
+ non-inlined constructors.
+
+ * Class::MOP::Method::Generated
+ - added this class as an abstract base for the
+ Class::MOP::Method::{Constructor,Accessor} classes
+ - added tests for this
+
0.42 Mon. July 16, 2007
!!! Horray for mst, he fixed it !!!
use Class::MOP::Immutable;
-our $VERSION = '0.42';
+our $VERSION = '0.43';
our $AUTHORITY = 'cpan:STEVAN';
{
);
## --------------------------------------------------------
+## Class::MOP::Method::Generated
+
+Class::MOP::Method::Generated->meta->add_attribute(
+ Class::MOP::Attribute->new('$!is_inline' => (
+ init_arg => 'is_inline',
+ reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline },
+ ))
+);
+
+## --------------------------------------------------------
## Class::MOP::Method::Accessor
Class::MOP::Method::Accessor->meta->add_attribute(
))
);
-Class::MOP::Method::Accessor->meta->add_attribute(
- Class::MOP::Attribute->new('$!is_inline' => (
- init_arg => 'is_inline',
- reader => { 'is_inline' => \&Class::MOP::Method::Accessor::is_inline },
- ))
-);
## --------------------------------------------------------
## Class::MOP::Method::Constructor
Class::MOP::Object
+ Class::MOP::Method::Generated
+
Class::MOP::Method::Accessor
Class::MOP::Method::Constructor
Class::MOP::Method::Wrapped
$constructor_class->new(
options => \%options,
metaclass => $metaclass,
+ is_inline => 1,
)
) unless $metaclass->has_method($options{constructor_name});
}
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.01';
+our $VERSION = '0.02';
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Method';
+use base 'Class::MOP::Method::Generated';
sub new {
my $class = shift;
# needed
weaken($self->{'$!attribute'});
- $self->intialize_body;
+ $self->initialize_body;
return $self;
}
sub associated_attribute { (shift)->{'$!attribute'} }
sub accessor_type { (shift)->{'$!accessor_type'} }
-sub is_inline { (shift)->{'$!is_inline'} }
## factory
-sub intialize_body {
+sub initialize_body {
my $self = shift;
my $method_name = join "_" => (
This returns the attribute instance which was passed into C<new>.
-=item B<intialize_body>
+=item B<initialize_body>
This will actually generate the method based on the specified
criteria passed to the constructor.
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
-our $VERSION = '0.01';
+our $VERSION = '0.02';
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Method';
+use base 'Class::MOP::Method::Generated';
sub new {
my $class = shift;
# from our superclass
'&!body' => undef,
# specific to this subclass
- '%!options' => $options{options},
- '$!meta_instance' => $options{metaclass}->get_meta_instance,
- '@!attributes' => [ $options{metaclass}->compute_all_applicable_attributes ],
- # ...
+ '%!options' => $options{options},
'$!associated_metaclass' => $options{metaclass},
+ '$!is_inline' => ($options{is_inline} || 0),
} => $class;
# we don't want this creating
# needed
weaken($self->{'$!associated_metaclass'});
- $self->intialize_body;
+ $self->initialize_body;
return $self;
}
-## predicates
+## accessors
-# NOTE:
-# if it is blessed into this class,
-# then it is always inlined, that is
-# pretty much what this class is for.
-sub is_inline { 1 }
+sub options { (shift)->{'%!options'} }
+sub associated_metaclass { (shift)->{'$!associated_metaclass'} }
-## accessors
+## cached values ...
-sub options { (shift)->{'%!options'} }
-sub meta_instance { (shift)->{'$!meta_instance'} }
-sub attributes { (shift)->{'@!attributes'} }
+sub meta_instance {
+ my $self = shift;
+ $self->{'$!meta_instance'} ||= $self->associated_metaclass->get_meta_instance;
+}
-sub associated_metaclass { (shift)->{'$!associated_metaclass'} }
+sub attributes {
+ my $self = shift;
+ $self->{'@!attributes'} ||= [ $self->associated_metaclass->compute_all_applicable_attributes ]
+}
## method
-sub intialize_body {
+sub initialize_body {
+ my $self = shift;
+ my $method_name = 'generate_constructor_method';
+
+ $method_name .= '_inline' if $self->is_inline;
+
+ $self->{'&!body'} = $self->$method_name;
+}
+
+sub generate_constructor_method {
+ return sub { (shift)->meta->new_object(@_) }
+}
+
+sub generate_constructor_method_inline {
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" . 'return $class->meta->new_object(%params)';
+ $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
+
$source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
$source .= ";\n" . (join ";\n" => map {
$self->_generate_slot_initializer($_)
$code = eval $source;
confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
}
- $self->{'&!body'} = $code;
+ return $code;
}
sub _generate_slot_initializer {
This returns a boolean, but since constructors are very rarely
not inlined, this always returns true for now.
-=item B<intialize_body>
+=item B<initialize_body>
This creates the code reference for the constructor itself.
=back
+=head2 Method Generators
+
+=over 4
+
+=item B<generate_constructor_method>
+
+=item B<generate_constructor_method_inline>
+
+=back
+
=head1 AUTHORS
Stevan Little E<lt>stevan@iinteractive.comE<gt>
--- /dev/null
+
+package Class::MOP::Method::Generated;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method';
+
+sub new {
+ my $class = shift;
+ my %options = @_;
+
+ my $self = bless {
+ # from our superclass
+ '&!body' => undef,
+ # specific to this subclass
+ '$!is_inline' => ($options{is_inline} || 0),
+ } => $class;
+
+ $self->initialize_body;
+
+ return $self;
+}
+
+## accessors
+
+sub is_inline { (shift)->{'$!is_inline'} }
+
+sub initialize_body {
+ confess "No body to initialize, " . __PACKAGE__ . " is an abstract base class";
+}
+
+
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Method::Generated - Abstract base class for generated methods
+
+=head1 DESCRIPTION
+
+This is a C<Class::MOP::Method> subclass which is used interally
+by C<Class::MOP::Method::Accessor> and C<Class::MOP::Method::Constructor>.
+
+=head1 METHODS
+
+=over 4
+
+=item B<new (%options)>
+
+This creates the method based on the criteria in C<%options>,
+these options are:
+
+=over 4
+
+=item I<is_inline>
+
+This is a boolean to indicate if the method should be generated
+as a closure, or as a more optimized inline version.
+
+=back
+
+=item B<is_inline>
+
+This returns the boolean which was passed into C<new>.
+
+=item B<initialize_body>
+
+This is an abstract method and will throw an exception if called.
+
+=back
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006, 2007 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 => 39;
+use Test::More tests => 42;
BEGIN {
use_ok('Class::MOP');
use_ok('Class::MOP::Attribute');
use_ok('Class::MOP::Method');
use_ok('Class::MOP::Method::Wrapped');
+ use_ok('Class::MOP::Method::Generated');
use_ok('Class::MOP::Method::Accessor');
use_ok('Class::MOP::Method::Constructor');
use_ok('Class::MOP::Instance');
my %METAS = (
'Class::MOP::Attribute' => Class::MOP::Attribute->meta,
+ 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->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::Method->meta,
Class::MOP::Method::Accessor->meta,
Class::MOP::Method::Constructor->meta,
+ Class::MOP::Method::Generated->meta,
Class::MOP::Method::Wrapped->meta,
Class::MOP::Module->meta,
Class::MOP::Object->meta,
Class::MOP::Instance
Class::MOP::Method
Class::MOP::Method::Accessor
- Class::MOP::Method::Constructor
+ Class::MOP::Method::Constructor
+ Class::MOP::Method::Generated
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::Constructor-" . $Class::MOP::Method::Constructor::VERSION . "-cpan:STEVAN",
+ "Class::MOP::Method::Generated-" . $Class::MOP::Method::Generated::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",
use strict;
use warnings;
-use Test::More tests => 73;
+use Test::More tests => 77;
use Test::Exception;
BEGIN {
my $foo = Foo->new(bar => 'BAZ');
isa_ok($foo, 'Foo');
is($foo->bar, 'BAZ', '... got the right parameter value');
+ }
+
+ # NOTE:
+ # check that the constructor correctly handles inheritance
+ {
+ my $bar = Bar->new();
+ isa_ok($bar, 'Bar');
+ isa_ok($bar, 'Foo');
+ is($bar->bar, 'BAR', '... got the right inherited parameter value');
+ is($bar->baz, 'BAZ', '... got the right inherited parameter value');
}
-
+
# check out accessors too
{
my $bar_accessor = $meta->get_method('bar');
projects / gitmo/Class-MOP.git / commitdiff