'Scalar::Util' => '1.18',
'Sub::Name' => '0.02',
'Carp' => '0.01',
- 'B' => '0',
+ 'B' => '1.09',
+ 'B::Deparse' => '0.70',
'Clone' => '0.18',
+ 'SUPER' => '1.11',
},
optional => {
},
Revision history for Perl extension Class-MOP.
+0.07
+ - adding more tests
+ - added SUPER as a dependency (because we need runtime
+ dispatching of SUPER calls for traits)
+
0.06 Thurs Feb. 9, 2006
* metaclass
- adding new metaclass pragma to make setting up the
-Class::MOP version 0.06
+Class::MOP version 0.07
===========================
See the individual module documentation for more information
use Scalar::Util 'blessed';
use Carp 'confess';
+use SUPER ();
use Class::MOP::Class;
use Class::MOP::Attribute;
use Class::MOP::Method;
-our $VERSION = '0.06';
+our $VERSION = '0.07';
sub import {
shift;
*{$full_method_name} = subname $full_method_name => $method;
}
+sub alias_method {
+ my ($self, $method_name, $method) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+ # use reftype here to allow for blessed subs ...
+ (reftype($method) && reftype($method) eq 'CODE')
+ || confess "Your code block must be a CODE reference";
+ my $full_method_name = ($self->name . '::' . $method_name);
+
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$full_method_name} = $method;
+}
+
{
## private utility functions for has_method
delete ${$self->name . '::'}{$name};
}
+# class mixins
+
+sub mixin {
+ my ($self, $mixin) = @_;
+ $mixin = $self->initialize($mixin) unless blessed($mixin);
+
+ my @attributes = map { $mixin->get_attribute($_)->clone() }
+ $mixin->get_attribute_list;
+ my %methods = map {
+ my $method = $mixin->get_method($_);
+ if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')) {
+ ();
+ }
+ else {
+ ($_ => $method)
+ }
+ } $mixin->get_method_list;
+
+ # test the superclass thing detailed in the test
+
+ foreach my $attr (@attributes) {
+ $self->add_attribute($attr)
+ unless $self->has_attribute($attr->name);
+ }
+
+ foreach my $method_name (keys %methods) {
+ $self->alias_method($method_name => $methods{$method_name})
+ unless $self->has_method($method_name);
+ }
+}
+
1;
__END__
correct name, and therefore show up correctly in stack traces and
such.
+=item B<alias_method ($method_name, $method)>
+
+This will take a C<$method_name> and CODE reference to that
+C<$method> and alias the method into the class's package.
+
+B<NOTE>:
+Unlike C<add_method>, this will B<not> try to name the
+C<$method> using B<Sub::Name>, it only aliases the method in
+the class's package.
+
=item B<has_method ($method_name)>
This just provides a simple way to check if the class implements
use strict;
use warnings;
-use Test::More tests => 38;
+use Test::More tests => 40;
use Test::Exception;
BEGIN {
ok($Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)');
ok($Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)');
+{
+ package Foo::Aliasing;
+ use metaclass;
+ sub alias_me { '...' }
+}
+
+$Foo->alias_method('alias_me' => Foo::Aliasing->meta->get_method('alias_me'));
+
+ok(!$Foo->has_method('alias_me'), '... !Foo->has_method(alias_me) (aliased from Foo::Aliasing)');
+ok(defined &Foo::alias_me, '... Foo does have a symbol table slow for alias_me though');
+
ok(!$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)');
ok(!$Foo->has_method('boom'), '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 4;
+
+=pod
+
+Scala Style Class Mixin Composition
+
+L<http://scala.epfl.ch/intro/mixin.html>
+
+A class can only be used as a mixin in the definition of another
+class, if this other class extends a subclass of the superclass
+of the mixin. Since ColoredPoint3D extends Point3D and Point3D
+extends Point2D which is the superclass of ColoredPoint2D, the
+code above is well-formed.
+
+ class Point2D(xc: Int, yc: Int) {
+ val x = xc;
+ val y = yc;
+ override def toString() = "x = " + x + ", y = " + y;
+ }
+
+ class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) {
+ var color = c;
+ def setColor(newCol: String): Unit = color = newCol;
+ override def toString() = super.toString() + ", col = " + color;
+ }
+
+ class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) {
+ val z = zc;
+ override def toString() = super.toString() + ", z = " + z;
+ }
+
+ class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String)
+ extends Point3D(xc, yc, zc)
+ with ColoredPoint2D(xc, yc, col);
+
+
+ Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString())
+
+ "x = 1, y = 2, z = 3, col = blue"
+
+=cut
+
+{
+ package Point2D;
+ use metaclass;
+
+ Point2D->meta->add_attribute('$x' => (
+ accessor => 'x',
+ init_arg => 'x',
+ ));
+
+ Point2D->meta->add_attribute('$y' => (
+ accessor => 'y',
+ init_arg => 'y',
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ sub toString {
+ my $self = shift;
+ "x = " . $self->x . ", y = " . $self->y;
+ }
+
+ package ColoredPoint2D;
+ our @ISA = ('Point2D');
+
+ ColoredPoint2D->meta->add_attribute('$color' => (
+ accessor => 'color',
+ init_arg => 'color',
+ ));
+
+ sub toString {
+ my $self = shift;
+ $self->SUPER() . ', col = ' . $self->color;
+ }
+
+ package Point3D;
+ our @ISA = ('Point2D');
+
+ Point3D->meta->add_attribute('$z' => (
+ accessor => 'z',
+ init_arg => 'z',
+ ));
+
+ sub toString {
+ my $self = shift;
+ $self->SUPER() . ', z = ' . $self->z;
+ }
+
+ package ColoredPoint3D;
+ our @ISA = ('Point3D');
+
+ __PACKAGE__->meta->mixin('ColoredPoint2D');
+
+}
+
+my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue');
+isa_ok($colored_point_3d, 'ColoredPoint3D');
+isa_ok($colored_point_3d, 'Point3D');
+isa_ok($colored_point_3d, 'Point2D');
+
+is($colored_point_3d->toString(),
+ 'x = 1, y = 2, z = 3, col = blue',
+ '... got the right toString method');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests that Class::MOP works correctly
+with Class::C3 and it's somewhat insane
+approach to method resolution.
+
+=cut
+
+BEGIN {
+ eval "use Class::C3";
+ plan skip_all => "Class::C3 required for this test" if $@;
+ plan tests => 7;
+}
+
+{
+ package Diamond_A;
+ Class::C3->import;
+ use metaclass; # everyone will just inherit this now :)
+
+ sub hello { 'Diamond_A::hello' }
+}
+{
+ package Diamond_B;
+ use base 'Diamond_A';
+ Class::C3->import;
+}
+{
+ package Diamond_C;
+ Class::C3->import;
+ use base 'Diamond_A';
+
+ sub hello { 'Diamond_C::hello' }
+}
+{
+ package Diamond_D;
+ use base ('Diamond_B', 'Diamond_C');
+ Class::C3->import;
+}
+
+# we have to manually initialize
+# Class::C3 since we potentially
+# skip this test if it is not present
+Class::C3::initialize();
+
+is_deeply(
+ [ Class::C3::calculateMRO('Diamond_D') ],
+ [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+ok(Diamond_A->meta->has_method('hello'), '... A has a method hello');
+ok(!Diamond_B->meta->has_method('hello'), '... B does not have a method hello');
+ok(defined &Diamond_B::hello, '... B does have an alias to the method hello');
+
+ok(Diamond_C->meta->has_method('hello'), '... C has a method hello');
+ok(!Diamond_D->meta->has_method('hello'), '... D does not have a method hello');
+ok(defined &Diamond_D::hello, '... D does have an alias to the method hello');
projects / gitmo/Class-MOP.git / commitdiff