Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

use MRO::Define to avoid the ->$method failure

  • Loading branch information...
commit 271e730ca8d4bad552b3d86743b8b779e0eff4d8 1 parent 00def57
Ricardo Signes authored
7 lib/metamethod.pm
View
@@ -3,6 +3,8 @@ use 5.010; # uvar magic does not work prior to version 10
use strict;
use warnings;
+use mro;
+use MRO::Define;
use Scalar::Util qw(reftype);
use Variable::Magic qw/wizard cast/;
@@ -73,6 +75,10 @@ sub import {
};
}
+ MRO::Define::register_mro($caller, sub {
+ return [ undef, $caller ];
+ });
+
cast %{"::$caller\::"}, $wiz;
}
@@ -82,6 +88,7 @@ sub _gen_fetch_magic {
my $metamethod = $arg->{metamethod};
my $passthru = $arg->{passthru};
+ use Data::Dumper;
return sub {
return if $_[2] ~~ $passthru;
9 t/classless.t
View
@@ -23,6 +23,15 @@ is(
'grandchild object answers status method, too',
);
+{
+ my $method = 'status';
+ is(
+ $child_b->$method,
+ 'ok?',
+ 'grandchild object answers status method (as str), too',
+ );
+}
+
$child_a->set(generation => 2);
my $call;
27 t/first-class.t
View
@@ -24,6 +24,16 @@ is(ref $child_class, 'Class', 'check ref of ChildClass');
is($parent_class->name, 'ParentClass', 'name of ParentClass');
is($child_class->name, 'ChildClass', 'name of ChildClass');
+ok(
+ $child_class->derives_from($parent_class),
+ "class derivation reported correctly: child derives from parent",
+);
+
+ok(
+ ! $parent_class->derives_from($child_class),
+ "class derivation reported correctly: parent ! derives from child",
+);
+
is($parent_class->ping, 'pong', 'ping ParentClass');
is($child_class->ping, 'reply', 'ping ChildClass');
@@ -37,9 +47,22 @@ is($child_class->foo, 'bar', 'foo on ChildClass');
is($parent_class->instance_class, 'Instance', 'ParentClass i_c is Instance');
is($child_class->instance_class, 'Instance', 'ChildClass i_c is Instance');
+diag <<'END_WTF';
+So now we have two class objects. We've tested that they're blessed
+references, and we've tested that their class methods (ping/ping) work as
+expected. Next up, we want to create instances. This is where things fall
+apart. The thing returned by ->new is the instance class, rather than a
+reference blessed into it. What's going on?? -- rjbs, 2009-05-13
+END_WTF
+
+$::extra_debugging = 1;
+
my $parent_instance = $parent_class->new;
+diag ">> class: $parent_class // instance $parent_instance <<";
is(ref $parent_instance, 'Instance', 'check ref of ParentInstance');
+__END__
+
my $child_instance = $child_class->new;
is(ref $child_instance, 'Instance', 'check ref of ChildInstance');
@@ -54,6 +77,10 @@ like($@, qr/no instance method/, 'there is no "new" instance method');
is($parent_instance->plugh, 'fool', 'plugh on parent instance');
is($child_instance->plugh, 'xyzzy', 'plugh on child instance');
+my $method = 'plugh';
+is($parent_instance->$method, 'fool', 'symbolic plugh on parent instance');
+is($child_instance->$method, 'xyzzy', 'symbolic plugh on child instance');
+
eval { $parent_class->plugh };
like($@, qr/no class method/, 'there is no class "plugh" on ParentClass');
6 t/lib/CLR.pm
View
@@ -1,6 +1,6 @@
use strict;
use warnings;
-package CLR; # class-less root
+package CLR_X; # class-less root
# Our test example will be a very, very simple classless/prototype calling
# system. -- rjbs, 2008-05-16
@@ -34,7 +34,7 @@ sub new {
my %STATIC = (new => \&new);
use metamethod
- passthru => [ qw(import export) ],
+ passthru => [ qw(import export DESTROY AUTOLOAD) ],
metamethod => sub {
my ($invocant, $method, $args) = @_;
@@ -55,4 +55,6 @@ use metamethod
die "unknown method $method called on $class object";
};
+{ package CLR; use mro 'CLR_X'; }
+
1;
10 t/lib/Class.pm
View
@@ -1,6 +1,6 @@
use strict;
use warnings;
-package Class;
+package ClassX;
our $VERSION = '1.234';
@@ -12,7 +12,7 @@ my %STATIC = (
);
my %UNIVERSAL = (
- new => sub { bless { __class__ => $_[0] } => $_[0]->instance_class, },
+ new => sub { bless { __class__ => $_[0] } => $_[0]->instance_class },
name => sub { $_[0]->{name} },
base => sub { $_[0]->{base} },
new_subclass => sub {
@@ -44,6 +44,8 @@ sub invoke_method {
my $curr = $invocant;
my $code;
+ warn("> $invocant -> $method_name (@$args)") if $::extra_debugging;
+
unless (ref $invocant) {
die "no metaclass method $method_name on $invocant"
unless $code = $STATIC{$method_name};
@@ -51,6 +53,7 @@ sub invoke_method {
return $code->($invocant, @$args);
}
+ warn "> seeking concrete Class method $method_name" if $::extra_debugging;
while ($curr) {
my $methods = $curr->{class_methods};
$code = $methods->{$method_name}, last
@@ -58,6 +61,7 @@ sub invoke_method {
$curr = $curr->{base};
}
+ warn "> seeking universal Class method $method_name" if $::extra_debugging;
Carp::confess("no class method $method_name on $invocant->{name}")
unless $code ||= $UNIVERSAL{$method_name};
@@ -68,4 +72,6 @@ use metamethod
metamethod => \'invoke_method',
passthru => [ qw(VERSION import unimport) ];
+{ package Class; use mro 'ClassX'; }
+
1;
6 t/lib/Instance.pm
View
@@ -1,6 +1,8 @@
use strict;
use warnings;
-package Instance;
+package InstanceX;
+
+use Scalar::Util qw(blessed);
our $VERSION = '1.000';
@@ -52,4 +54,6 @@ use metamethod
metamethod => \'invoke_method',
passthru => [ qw(VERSION import unimport) ];
+{ package Instance; use mro 'InstanceX'; }
+
1;
12 t/overloads.t
View
@@ -3,7 +3,7 @@ use warnings;
use Test::More 'no_plan';
BEGIN {
- package OLP; # overloads pass through
+ package OLP_X; # overloads pass through
use metamethod
passthru => [ 'ISA' ],
@@ -13,9 +13,13 @@ BEGIN {
},
metamethod => sub {
my ($self, $method, $args) = @_;
- warn "called: " . join(q{, }, @_) . "\n";
return [ $method, $args ];
};
+
+ {
+ package OLP;
+ use mro 'OLP_X';
+ }
}
my $olp = bless {} => 'OLP';
@@ -41,5 +45,5 @@ my $olp = bless {} => 'OLP';
# my $str = "$olp";
# is($str, '(""', "we stringified to the stringification method name");
-use Data::Dumper;
-warn Dumper([ @{ $olp } ]);
+# use Data::Dumper;
+# warn Dumper([ @{ $olp } ]);
Please sign in to comment.
Something went wrong with that request. Please try again.