r25526 - in /branches/upstream/libclass-mop-perl/current: ./ lib/ lib/Class/ lib/Class/MOP/ t/ t/lib/MyMetaClass/
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Mon Sep 22 13:39:45 UTC 2008
Author: eloy
Date: Mon Sep 22 13:39:42 2008
New Revision: 25526
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25526
Log:
[svn-upgrade] Integrating new upstream version, libclass-mop-perl (0.66)
Added:
branches/upstream/libclass-mop-perl/current/t/041_metaclass_incompatibility.t
branches/upstream/libclass-mop-perl/current/t/lib/MyMetaClass/Random.pm
Removed:
branches/upstream/libclass-mop-perl/current/t/041_metaclass_incompatability.t
Modified:
branches/upstream/libclass-mop-perl/current/Changes
branches/upstream/libclass-mop-perl/current/MANIFEST
branches/upstream/libclass-mop-perl/current/MANIFEST.SKIP
branches/upstream/libclass-mop-perl/current/META.yml
branches/upstream/libclass-mop-perl/current/Makefile.PL
branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm
branches/upstream/libclass-mop-perl/current/lib/metaclass.pm
branches/upstream/libclass-mop-perl/current/t/000_load.t
branches/upstream/libclass-mop-perl/current/t/003_methods.t
branches/upstream/libclass-mop-perl/current/t/010_self_introspection.t
branches/upstream/libclass-mop-perl/current/t/030_method.t
branches/upstream/libclass-mop-perl/current/t/071_immutable_w_custom_metaclass.t
branches/upstream/libclass-mop-perl/current/t/073_make_mutable.t
branches/upstream/libclass-mop-perl/current/t/083_load_class.t
Modified: branches/upstream/libclass-mop-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/Changes?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/Changes (original)
+++ branches/upstream/libclass-mop-perl/current/Changes Mon Sep 22 13:39:42 2008
@@ -1,4 +1,28 @@
Revision history for Perl extension Class-MOP.
+
+0.66
+ !! This release has an incompatible change regarding !!
+ introspection of a class's method with Class::MOP::Class !!
+
+ * Tests and XS
+ - We (us maintainers) now run all tests with XS and then without
+ XS, which should help us catch skew between the XS/pure Perl
+ code. (Dave Rolsky)
+
+ * Class::MOP::Class
+ ! The alias_method method has been deprecated. It now simply
+ calls add_method instead. There is no distinction between
+ aliased methods and "real" methods.
+
+ This means that methods added via alias_method now show up as
+ part of the class's method list/map. This is backwards
+ incompatible change, but seems unlikely to break any
+ code. Famous last words. (Dave Rolsky)
+
+ * Class::MOP::Class
+ - Fixed the spelling of "compatibility", but we still have a
+ "check_metaclass_compatability" method for backwards
+ compatibility.
0.65 Mon September 1, 2008
For those not following the series of dev releases, the changes
Modified: branches/upstream/libclass-mop-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/MANIFEST?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/MANIFEST (original)
+++ branches/upstream/libclass-mop-perl/current/MANIFEST Mon Sep 22 13:39:42 2008
@@ -53,7 +53,7 @@
t/030_method.t
t/031_method_modifiers.t
t/040_metaclass.t
-t/041_metaclass_incompatability.t
+t/041_metaclass_incompatibility.t
t/042_metaclass_incompatibility_dyn.t
t/043_instance_metaclass_incompat.t
t/044_instance_metaclass_incompat_dyn.t
@@ -89,5 +89,6 @@
t/lib/MyMetaClass/Attribute.pm
t/lib/MyMetaClass/Instance.pm
t/lib/MyMetaClass/Method.pm
+t/lib/MyMetaClass/Random.pm
t/lib/SyntaxError.pm
META.yml Module meta-data (added by MakeMaker)
Modified: branches/upstream/libclass-mop-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/MANIFEST.SKIP?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/MANIFEST.SKIP (original)
+++ branches/upstream/libclass-mop-perl/current/MANIFEST.SKIP Mon Sep 22 13:39:42 2008
@@ -22,3 +22,4 @@
\.shipit
t/pod\.t$
t/pod_coverage\.t$
+t/pp_.+\.t$
Modified: branches/upstream/libclass-mop-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/META.yml?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/META.yml (original)
+++ branches/upstream/libclass-mop-perl/current/META.yml Mon Sep 22 13:39:42 2008
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Class-MOP
-version: 0.65
+version: 0.66
abstract: A Meta Object Protocol for Perl 5
license: perl
generated_by: ExtUtils::MakeMaker version 6.36
Modified: branches/upstream/libclass-mop-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/Makefile.PL?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/Makefile.PL (original)
+++ branches/upstream/libclass-mop-perl/current/Makefile.PL Mon Sep 22 13:39:42 2008
@@ -39,6 +39,10 @@
delete @prereqs{qw(Sub::Name Devel::GlobalDestruction)}
unless $has_compiler;
+if ($has_compiler && is_maintainer()) {
+ create_pp_tests();
+}
+
write_makefile();
sub write_makefile {
@@ -50,7 +54,7 @@
PREREQ_PM => \%prereqs,
CONFIGURE => \&init,
CCFLAGS => $ccflags,
- clean => { FILES => 'test.c test.o' },
+ clean => { FILES => 'test.c test.o t/pp*' },
ABSTRACT_FROM => 'lib/Class/MOP.pm',
AUTHOR => 'Stevan Little <stevan at iinteractive.com>',
LICENSE => 'perl',
@@ -116,6 +120,43 @@
return 1;
}
+# This sucks, but it's the best guess we can make. Since we just use
+# it to run two sets of tests, it's not big deal if it ends up true
+# for a non-maintainer.
+sub is_maintainer {
+ return 0 if $ENV{PERL5_CPAN_IS_RUNNING} || $ENV{PERL5_CPANPLUS_IS_RUNNING};
+
+ return 1;
+}
+
+sub create_pp_tests {
+ opendir my $dh, 't' or die "Cannot read t: $!";
+
+ foreach my $file ( grep {/^\d.+\.t$/} readdir $dh ) {
+ next if $file =~ /^99/;
+
+ my $real_file = File::Spec->catfile( 't', $file );
+
+ open my $fh, '<', $real_file
+ or die "Cannot read $real_file: $!";
+
+ my $shbang = <$fh>;
+ my $test = do { local $/; <$fh> };
+
+ close $fh;
+
+ $test = "$shbang\nBEGIN { \$ENV{CLASS_MOP_NO_XS} = 1 }\n\n$test";
+
+ my $new_file = File::Spec->catfile( 't', "pp_$file" );
+ open my $new_fh, '>', $new_file
+ or die "Cannot write to $new_file: $!";
+
+ print $new_fh $test;
+
+ close $new_fh;
+ }
+}
+
# This is EUMM voodoo
sub init {
my $hash = $_[1];
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm Mon Sep 22 13:39:42 2008
@@ -10,24 +10,6 @@
use Carp 'confess';
use Scalar::Util 'weaken';
-
-BEGIN {
- local $@;
- eval {
- require Sub::Name;
- Sub::Name->import(qw(subname));
- 1
- } or eval 'sub subname { $_[1] }';
-
- # this is either part of core or set up appropriately by MRO::Compat
- *check_package_cache_flag = \&mro::get_pkg_gen;
-
- eval {
- require Devel::GlobalDestruction;
- Devel::GlobalDestruction->import("in_global_destruction");
- 1;
- } or *in_global_destruction = sub () { !1 };
-}
use Class::MOP::Class;
@@ -44,9 +26,12 @@
*HAVE_ISAREV = defined(&mro::get_isarev)
? sub () { 1 }
: sub () { 1 };
+
+ # this is either part of core or set up appropriately by MRO::Compat
+ *check_package_cache_flag = \&mro::get_pkg_gen;
}
-our $VERSION = '0.65';
+our $VERSION = '0.66';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -66,6 +51,12 @@
# for some reason
local $^W = 0;
__PACKAGE__->XSLoader::load($XS_VERSION);
+
+ require Sub::Name;
+ Sub::Name->import(qw(subname));
+
+ require Devel::GlobalDestruction;
+ Devel::GlobalDestruction->import("in_global_destruction");
};
$@;
};
@@ -78,6 +69,9 @@
sub _load_pure_perl {
require Sub::Identify;
Sub::Identify->import('get_code_info');
+
+ *subname = sub { $_[1] };
+ *in_global_destruction = sub () { !1 }
}
@@ -121,13 +115,7 @@
confess "Could not load class ($class) because : $e" if $e;
}
- # initialize a metaclass if necessary
- unless (does_metaclass_exist($class)) {
- my $e = do { local $@; eval { Class::MOP::Class->initialize($class) }; $@ };
- confess "Could not initialize class ($class) because : $e" if $e;
- }
-
- return get_metaclass_by_name($class) if defined wantarray;
+ get_metaclass_by_name($class) || $class if defined wantarray;
}
sub _is_valid_class_name {
@@ -500,9 +488,18 @@
))
);
+Class::MOP::Method->meta->add_attribute(
+ Class::MOP::Attribute->new('original_method' => (
+ reader => { 'original_method' => \&Class::MOP::Method::original_method },
+ writer => { '_set_original_method' => \&Class::MOP::Method::_set_original_method },
+ ))
+);
+
Class::MOP::Method->meta->add_method('clone' => sub {
my $self = shift;
- $self->meta->clone_object($self, @_);
+ my $clone = $self->meta->clone_object($self, @_);
+ $clone->_set_original_method($self);
+ return $clone;
});
## --------------------------------------------------------
@@ -850,6 +847,8 @@
=head2 Utility functions
+Note that these are all called as B<functions, not methods>.
+
=over 4
=item B<load_class ($class_name)>
@@ -870,6 +869,8 @@
=item B<check_package_cache_flag ($pkg)>
+B<NOTE: DO NOT USE THIS FUNCTION, IT IS FOR INTERNAL USE ONLY!>
+
This will return an integer that is managed by C<Class::MOP::Class>
to determine if a module's symbol table has been altered.
@@ -879,6 +880,8 @@
=item B<get_code_info ($code)>
+B<NOTE: DO NOT USE THIS FUNCTION, IT IS FOR INTERNAL USE ONLY!>
+
This function returns two values, the name of the package the C<$code>
is from and the name of the C<$code> itself. This is used by several
elements of the MOP to detemine where a given C<$code> reference is from.
@@ -892,6 +895,8 @@
argument.
=item B<in_global_destruction>
+
+B<NOTE: DO NOT USE THIS FUNCTION, IT IS FOR INTERNAL USE ONLY!>
If L<Devel::GlobalDestruction> is available, this returns true under global
destruction.
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm Mon Sep 22 13:39:42 2008
@@ -85,7 +85,7 @@
}
# and check the metaclass compatibility
- $meta->check_metaclass_compatability();
+ $meta->check_metaclass_compatibility();
Class::MOP::store_metaclass_by_name($package_name, $meta);
@@ -140,7 +140,7 @@
$self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
}
-sub check_metaclass_compatability {
+sub check_metaclass_compatibility {
my $self = shift;
# this is always okay ...
@@ -167,12 +167,18 @@
$class_name . "->meta => (" . ($meta_type) . ")";
# NOTE:
# we also need to check that instance metaclasses
- # are compatabile in the same the class.
+ # are compatibile in the same the class.
($self->instance_metaclass->isa($meta->instance_metaclass))
|| confess $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
$class_name . "->meta->instance_metaclass => (" . ($meta->instance_metaclass) . ")";
}
+}
+
+# backwards compat for stevan's inability to spell ;)
+sub check_metaclass_compatability {
+ my $self = shift;
+ $self->check_metaclass_compatibility(@_);
}
## ANON classes
@@ -212,10 +218,18 @@
sub DESTROY {
my $self = shift;
- return if Class::MOP::in_global_destruction; # it'll happen soon anyway and this just makes things more complicated
+ return if Class::MOP::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
no warnings 'uninitialized';
return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
+ # Moose does a weird thing where it replaces the metaclass for
+ # class when fixing metaclass incompatibility. In that case,
+ # we don't want to clean out the namespace now. We can detect
+ # that because Moose will explicitly update the singleton
+ # cache in Class::MOP.
+ my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
+ return if $current_meta ne $self;
+
my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
no strict 'refs';
foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
@@ -492,7 +506,8 @@
# be sure that the superclass is
# not potentially creating an issues
# we don't know about
- $self->check_metaclass_compatability();
+
+ $self->check_metaclass_compatibility();
$self->update_meta_instance_dependencies();
}
@{$self->get_package_symbol($var_spec)};
@@ -591,15 +606,13 @@
sub wrap_method_body {
my ( $self, %args ) = @_;
- my $body = delete $args{body}; # delete is for compat
-
- ('CODE' eq ref($body))
+ ('CODE' eq ref $args{body})
|| confess "Your code block must be a CODE reference";
- $self->method_metaclass->wrap( $body => (
+ $self->method_metaclass->wrap(
package_name => $self->name,
%args,
- ));
+ );
}
sub add_method {
@@ -610,11 +623,7 @@
my $body;
if (blessed($method)) {
$body = $method->body;
- if ($method->package_name ne $self->name &&
- $method->name ne $method_name) {
- warn "Hello there, got something for you."
- . " Method says " . $method->package_name . " " . $method->name
- . " Class says " . $self->name . " " . $method_name;
+ if ($method->package_name ne $self->name) {
$method = $method->clone(
package_name => $self->name,
name => $method_name
@@ -710,19 +719,9 @@
}
sub alias_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $body = (blessed($method) ? $method->body : $method);
- ('CODE' eq ref($body))
- || confess "Your code block must be a CODE reference";
-
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name } => $body
- );
-
- $self->update_package_cache_flag; # the method map will not list aliased methods
+ my $self = shift;
+
+ $self->add_method(@_);
}
sub has_method {
@@ -1251,7 +1250,7 @@
method is used internally by C<initialize> and should never be called
from outside of that method really.
-=item B<check_metaclass_compatability>
+=item B<check_metaclass_compatibility>
This method is called as the very last thing in the
C<construct_class_instance> method. This will check that the
@@ -1463,24 +1462,24 @@
=item B<add_method ($method_name, $method, %attrs)>
-This will take a C<$method_name> and CODE reference to that
-C<$method> and install it into the class's package.
+This will take a C<$method_name> and CODE reference or meta method
+objectand install it into the class's package.
+
+You are strongly encouraged to pass a meta method object instead of a
+code reference. If you do so, that object gets stored as part of the
+class's method map, providing more useful information about the method
+for introspection.
+
+When you provide a method object, this method will clone that object
+if the object's package name does not match the class name. This lets
+us track the original source of any methods added from other classes
+(notably Moose roles).
B<NOTE>:
This does absolutely nothing special to C<$method>
other than use B<Sub::Name> to make sure it is tagged with the
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)>
@@ -1568,6 +1567,11 @@
This will return the first method to match a given C<$method_name> in
the superclasses, this is basically equivalent to calling
C<SUPER::$method_name>, but it can be dispatched at runtime.
+
+=item B<alias_method ($method_name, $method)>
+
+B<NOTE>: This method is now deprecated. Just use C<add_method>
+instead.
=back
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm Mon Sep 22 13:39:42 2008
@@ -84,8 +84,41 @@
sub name { (shift)->{'name'} }
sub fully_qualified_name {
- my $code = shift;
- $code->package_name . '::' . $code->name;
+ my $self = shift;
+ $self->package_name . '::' . $self->name;
+}
+
+sub original_method { (shift)->{'original_method'} }
+
+sub _set_original_method { $_[0]->{'original_method'} = $_[1] }
+
+# It's possible that this could cause a loop if there is a circular
+# reference in here. That shouldn't ever happen in normal
+# circumstances, since original method only gets set when clone is
+# called. We _could_ check for such a loop, but it'd involve some sort
+# of package-lexical variable, and wouldn't be terribly subclassable.
+sub original_package_name {
+ my $self = shift;
+
+ $self->original_method
+ ? $self->original_method->original_package_name
+ : $self->package_name;
+}
+
+sub original_name {
+ my $self = shift;
+
+ $self->original_method
+ ? $self->original_method->original_name
+ : $self->name;
+}
+
+sub original_fully_qualified_name {
+ my $self = shift;
+
+ $self->original_method
+ ? $self->original_method->original_fully_qualified_name
+ : $self->fully_qualified_name;
}
# NOTE:
@@ -166,6 +199,37 @@
This returns the fully qualified name of the CODE reference.
+=item B<original_method>
+
+If this method object was created as a clone of some other method
+object, this returns the object that was cloned.
+
+=item B<original_name>
+
+This returns the original name of the CODE reference, wherever it was
+first defined.
+
+If this method is a clone of a clone (of a clone, etc.), this method
+returns the name from the I<first> method in the chain of clones.
+
+=item B<original_package_name>
+
+This returns the original package name that the CODE reference is
+attached to, wherever it was first defined.
+
+If this method is a clone of a clone (of a clone, etc.), this method
+returns the package name from the I<first> method in the chain of
+clones.
+
+=item B<original_fully_qualified_name>
+
+This returns the original fully qualified name of the CODE reference,
+wherever it was first defined.
+
+If this method is a clone of a clone (of a clone, etc.), this method
+returns the fully qualified name from the I<first> method in the chain
+of clones.
+
=back
=head2 Metaclass
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm Mon Sep 22 13:39:42 2008
@@ -27,15 +27,15 @@
# we hand-construct the class
# until we can bootstrap it
if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
- return $meta;
+ return $meta;
} else {
- my $meta = ( ref $class || $class )->_new({
- 'package' => $package_name,
- });
-
- Class::MOP::store_metaclass_by_name($package_name, $meta);
-
- return $meta;
+ my $meta = ( ref $class || $class )->_new({
+ 'package' => $package_name,
+ });
+
+ Class::MOP::store_metaclass_by_name($package_name, $meta);
+
+ return $meta;
}
}
Modified: branches/upstream/libclass-mop-perl/current/lib/metaclass.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/metaclass.pm?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/metaclass.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/metaclass.pm Mon Sep 22 13:39:42 2008
@@ -31,10 +31,10 @@
|| confess "The metaclass ($metaclass) must be derived from Class::MOP::Class";
# make sure the custom metaclasses get loaded
- foreach my $class (grep {
- /^(attribute|method|instance)_metaclass/
- } keys %options) {
- Class::MOP::load_class($options{$class})
+ foreach my $key (grep { /_(?:meta)?class$/ } keys %options) {
+ unless ( ref( my $class = $options{$key} ) ) {
+ Class::MOP::load_class($class)
+ }
}
my $package = caller();
Modified: branches/upstream/libclass-mop-perl/current/t/000_load.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/000_load.t?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/000_load.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/000_load.t Mon Sep 22 13:39:42 2008
@@ -26,17 +26,18 @@
my $CLASS_MOP_CLASS_IMMUTABLE_CLASS = 'Class::MOP::Class::__ANON__::SERIAL::1';
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::Module' => Class::MOP::Module->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::Object' => Class::MOP::Object->meta,
+ '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::Module' => Class::MOP::Module->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::Object' => Class::MOP::Object->meta,
);
ok(Class::MOP::is_class_loaded($_), '... ' . $_ . ' is loaded') for keys %METAS;
Modified: branches/upstream/libclass-mop-perl/current/t/003_methods.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/003_methods.t?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/003_methods.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/003_methods.t Mon Sep 22 13:39:42 2008
@@ -17,10 +17,9 @@
}
}
-BEGIN {
- use_ok('Class::MOP');
- use_ok('Class::MOP::Class');
-}
+use Class::MOP;
+use Class::MOP::Class;
+use Class::MOP::Method;
{ # This package tries to test &has_method
# as exhaustively as possible. More corner
@@ -155,7 +154,7 @@
$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($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)');
@@ -166,7 +165,7 @@
is_deeply(
[ sort $Foo->get_method_list ],
- [ qw(FOO_CONSTANT baaz bang bar baz blah evaled_foo floob foo) ],
+ [ qw(FOO_CONSTANT alias_me baaz bang bar baz blah evaled_foo floob foo) ],
'... got the right method list for Foo');
is_deeply(
@@ -174,6 +173,7 @@
[
map { $Foo->get_method($_) } qw(
FOO_CONSTANT
+ alias_me
baaz
bang
bar
@@ -192,7 +192,7 @@
is_deeply(
[ sort $Foo->get_method_list ],
- [ qw(FOO_CONSTANT baaz bang bar baz blah evaled_foo floob) ],
+ [ qw(FOO_CONSTANT alias_me baaz bang bar baz blah evaled_foo floob) ],
'... got the right method list for Foo');
@@ -230,6 +230,7 @@
[ sort { $a->name cmp $b->name } $Bar->get_all_methods() ],
[
$Foo->get_method('FOO_CONSTANT'),
+ $Foo->get_method('alias_me'),
$Foo->get_method('baaz'),
$Foo->get_method('bang'),
$Bar->get_method('bar'),
@@ -244,4 +245,15 @@
],
'... got the right list of applicable methods for Bar');
-
+my $method = Class::MOP::Method->wrap(
+ name => 'objecty',
+ package_name => 'Whatever',
+ body => sub {q{I am an object, and I feel an object's pain}},
+);
+
+Bar->meta->add_method( $method->name, $method );
+
+my $new_method = Bar->meta->get_method('objecty');
+
+isnt( $method, $new_method, 'add_method clones method objects as they are added' );
+is( $new_method->original_method, $method, '... the cloned method has the correct original method' );
Modified: branches/upstream/libclass-mop-perl/current/t/010_self_introspection.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/010_self_introspection.t?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/010_self_introspection.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/010_self_introspection.t Mon Sep 22 13:39:42 2008
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 234;
+use Test::More tests => 236;
use Test::Exception;
BEGIN {
@@ -63,6 +63,7 @@
new_object clone_object
construct_instance construct_class_instance clone_instance
rebless_instance
+ check_metaclass_compatibility
check_metaclass_compatability
add_meta_instance_dependencies remove_meta_instance_depdendencies update_meta_instance_dependencies
Modified: branches/upstream/libclass-mop-perl/current/t/030_method.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/030_method.t?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/030_method.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/030_method.t Mon Sep 22 13:39:42 2008
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More tests => 46;
use Test::Exception;
use Class::MOP;
@@ -20,6 +20,10 @@
is($method->package_name, 'main', '... our package is main::');
is($method->name, '__ANON__', '... our sub name is __ANON__');
is($method->fully_qualified_name, 'main::__ANON__', '... our subs full name is main::__ANON__');
+is($method->original_method, undef, '... no original_method ');
+is($method->original_package_name, 'main', '... the original_package_name is the same as package_name');
+is($method->original_name, '__ANON__', '... the original_name is the same as name');
+is($method->original_fully_qualified_name, 'main::__ANON__', '... the original_fully_qualified_name is the same as fully_qualified_name');
dies_ok { Class::MOP::Method->wrap } q{... can't call wrap() without some code};
dies_ok { Class::MOP::Method->wrap([]) } q{... can't call wrap() without some code};
@@ -68,7 +72,29 @@
Class::MOP::Method->wrap(sub { 'FAIL' }, name => '__ANON__')
} '... bad args for &wrap';
+my $clone = $method->clone(
+ package_name => 'NewPackage',
+ name => 'new_name',
+);
+isa_ok($clone, 'Class::MOP::Method');
+is($clone->package_name, 'NewPackage', '... cloned method has new package name');
+is($clone->name, 'new_name', '... cloned method has new sub name');
+is($clone->fully_qualified_name, 'NewPackage::new_name', '... cloned method has new fq name');
+is($clone->original_method, $method, '... cloned method has correct original_method');
+is($clone->original_package_name, 'main', '... cloned method has correct original_package_name');
+is($clone->original_name, '__ANON__', '... cloned method has correct original_name');
+is($clone->original_fully_qualified_name, 'main::__ANON__', '... cloned method has correct original_fully_qualified_name');
+my $clone2 = $clone->clone(
+ package_name => 'NewerPackage',
+ name => 'newer_name',
+);
-
+is($clone2->package_name, 'NewerPackage', '... clone of clone has new package name');
+is($clone2->name, 'newer_name', '... clone of clone has new sub name');
+is($clone2->fully_qualified_name, 'NewerPackage::newer_name', '... clone of clone new fq name');
+is($clone2->original_method, $clone, '... cloned method has correct original_method');
+is($clone2->original_package_name, 'main', '... original_package_name follows clone chain');
+is($clone2->original_name, '__ANON__', '... original_name follows clone chain');
+is($clone2->original_fully_qualified_name, 'main::__ANON__', '... original_fully_qualified_name follows clone chain');
Added: branches/upstream/libclass-mop-perl/current/t/041_metaclass_incompatibility.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/041_metaclass_incompatibility.t?rev=25526&op=file
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/041_metaclass_incompatibility.t (added)
+++ branches/upstream/libclass-mop-perl/current/t/041_metaclass_incompatibility.t Mon Sep 22 13:39:42 2008
@@ -1,0 +1,70 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+BEGIN {
+ use_ok('metaclass');
+}
+
+# meta classes
+{
+ package Foo::Meta;
+ use base 'Class::MOP::Class';
+
+ package Bar::Meta;
+ use base 'Class::MOP::Class';
+
+ package FooBar::Meta;
+ use base 'Foo::Meta', 'Bar::Meta';
+}
+
+$@ = undef;
+eval {
+ package Foo;
+ metaclass->import('Foo::Meta');
+};
+ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar;
+ metaclass->import('Bar::Meta');
+};
+ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Foo::Foo;
+ use base 'Foo';
+ metaclass->import('Bar::Meta');
+};
+ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar::Bar;
+ use base 'Bar';
+ metaclass->import('Foo::Meta');
+};
+ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar;
+ use base 'Foo';
+ metaclass->import('FooBar::Meta');
+};
+ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar2;
+ use base 'Bar';
+ metaclass->import('FooBar::Meta');
+};
+ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
+
+
Modified: branches/upstream/libclass-mop-perl/current/t/071_immutable_w_custom_metaclass.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/071_immutable_w_custom_metaclass.t?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/071_immutable_w_custom_metaclass.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/071_immutable_w_custom_metaclass.t Mon Sep 22 13:39:42 2008
@@ -45,7 +45,7 @@
::lives_ok {
Baz->meta->superclasses('Bar');
- } '... we survive the metaclass incompatability test';
+ } '... we survive the metaclass incompatibility test';
}
{
Modified: branches/upstream/libclass-mop-perl/current/t/073_make_mutable.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/073_make_mutable.t?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/073_make_mutable.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/073_make_mutable.t Mon Sep 22 13:39:42 2008
@@ -71,10 +71,10 @@
ok(! $meta->has_method('zxy') ,'... we dont have the aliased method yet');
ok( $meta->alias_method('zxy',sub{'xxx'}),'... aliased method');
- ok(! $meta->has_method('zxy') ,'... the aliased method does not register (correctly)');
+ ok( $meta->has_method('zxy') ,'... the aliased method does register');
is( Baz->zxy, 'xxx', '... method zxy works');
ok( $meta->remove_method('xyz'), '... removed method');
- ok(! $meta->remove_method('zxy'), '... removed aliased method');
+ ok( $meta->remove_method('zxy'), '... removed aliased method');
ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute');
ok(Baz->can('fickle'), '... Baz can fickle');
@@ -169,7 +169,7 @@
ok( $meta->alias_method('zxy',sub{'xxx'}),'... aliased method');
is( $instance->zxy, 'xxx', '... method zxy works');
ok( $meta->remove_method('xyz'), '... removed method');
- ok( !$meta->remove_method('zxy'), '... removed aliased method');
+ ok( $meta->remove_method('zxy'), '... removed aliased method');
ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute');
ok($instance->can('fickle'), '... instance can fickle');
Modified: branches/upstream/libclass-mop-perl/current/t/083_load_class.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/083_load_class.t?rev=25526&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/083_load_class.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/083_load_class.t Mon Sep 22 13:39:42 2008
@@ -1,7 +1,7 @@
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More tests => 22;
use Test::Exception;
require Class::MOP;
@@ -30,7 +30,12 @@
sub method {}
};
-ok(Class::MOP::load_class('Class'), "this should not die!");
+
+my $ret = Class::MOP::load_class('Class');
+ok($ret, "this should not die!");
+is( $ret, "Class", "class name returned" );
+
+ok( !Class::MOP::does_metaclass_exist("Class"), "no metaclass for non MOP class" );
throws_ok {
Class::MOP::load_class('FakeClassOhNo');
@@ -49,3 +54,10 @@
ok(Class::MOP::is_class_loaded("Other"), 'is_class_loaded(Other)');
}
"a class with just constants is still a class";
+
+{
+ package Lala;
+ use metaclass;
+}
+
+isa_ok( Class::MOP::load_class("Lala"), "Class::MOP::Class", "when an object has a metaclass it is returned" );
Added: branches/upstream/libclass-mop-perl/current/t/lib/MyMetaClass/Random.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/lib/MyMetaClass/Random.pm?rev=25526&op=file
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/lib/MyMetaClass/Random.pm (added)
+++ branches/upstream/libclass-mop-perl/current/t/lib/MyMetaClass/Random.pm Mon Sep 22 13:39:42 2008
@@ -1,0 +1,7 @@
+
+package MyMetaClass::Random;
+
+use strict;
+use warnings;
+
+1;
More information about the Pkg-perl-cvs-commits
mailing list