From: Stevan Little Date: Fri, 10 Feb 2006 20:19:06 +0000 (+0000) Subject: adding in tests X-Git-Tag: 0_10~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=663f81981a56fded486ffdb71bed5c5ab2e5c3fd;p=gitmo%2FClass-MOP.git adding in tests --- diff --git a/Build.PL b/Build.PL index 77fb9e4..65d3e29 100644 --- a/Build.PL +++ b/Build.PL @@ -9,8 +9,10 @@ my $build = Module::Build->new( '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 => { }, diff --git a/Changes b/Changes index 9169ea1..7460150 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ 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 diff --git a/README b/README index efb427f..71f7704 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -Class::MOP version 0.06 +Class::MOP version 0.07 =========================== See the individual module documentation for more information diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index e508e59..932c623 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -6,12 +6,13 @@ use warnings; 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; diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index ff6516e..9995dec 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -251,6 +251,20 @@ sub add_method { *{$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 @@ -475,6 +489,37 @@ sub remove_package_variable { 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__ @@ -710,6 +755,16 @@ other than use B to make sure it is tagged with the correct name, and therefore show up correctly in stack traces and such. +=item B + +This will take a C<$method_name> and CODE reference to that +C<$method> and alias the method into the class's package. + +B: +Unlike C, this will B try to name the +C<$method> using B, it only aliases the method in +the class's package. + =item B This just provides a simple way to check if the class implements diff --git a/t/003_methods.t b/t/003_methods.t index 0353ba8..cc24f0c 100644 --- a/t/003_methods.t +++ b/t/003_methods.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 38; +use Test::More tests => 40; use Test::Exception; BEGIN { @@ -71,6 +71,17 @@ ok($Foo->has_method('bling'), '... Foo->has_method(bling) (defined in main:: usi 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)'); diff --git a/t/050_class_mixin_composition.t b/t/050_class_mixin_composition.t new file mode 100644 index 0000000..5b8234a --- /dev/null +++ b/t/050_class_mixin_composition.t @@ -0,0 +1,112 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 4; + +=pod + +Scala Style Class Mixin Composition + +L + +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'); diff --git a/t/200_Class_C3_compatibility.t b/t/200_Class_C3_compatibility.t new file mode 100644 index 0000000..7eba482 --- /dev/null +++ b/t/200_Class_C3_compatibility.t @@ -0,0 +1,63 @@ +#!/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');