Permalink
Browse files

lots more flexibility -- needs lost more testing

  • Loading branch information...
1 parent 08d9f4c commit 01c98836a3a85f5bb7dc32d17e5336bf706ec618 @rjbs committed Mar 23, 2009
Showing with 93 additions and 21 deletions.
  1. +71 −13 lib/metamethod.pm
  2. +3 −2 t/first-class.t
  3. +9 −2 t/lib/Class.pm
  4. +10 −4 t/lib/Instance.pm
View
@@ -1,31 +1,89 @@
package metamethod; # make my methods meta!
use strict;
use warnings;
+
+use Scalar::Util qw(reftype);
use Variable::Magic qw/wizard cast/;
sub import {
- my ($self, $code) = @_;
- my $caller = caller;
+ my $self = shift;
+ my $arg;
+
+ if (@_ == 1 and reftype $_[0] eq 'CODE') {
+ $arg = { metamethod => $_[0] };
+ } else {
+ $arg = { @_ };
+ }
+
+ my $caller = caller;
+ my %to_install;
+
+ my $code = $arg->{metamethod};
+ my $metamethod = $arg->{metamethod_name} || '__metamethod__';
+
+ if (reftype $code eq 'SCALAR') {
+ $code = $caller->can($$code);
+ Carp::confess("can't find metamethod via name ${ $arg->{metamethod} }")
+ unless reftype $code eq 'CODE';
+ }
+
+ if (do { no strict 'refs'; defined *{"$caller\::$metamethod"}{CODE} }) {
+ Carp::confess("can't install metamethod as $metamethod; already defined");
+ }
+
+ my $handle_overloads;
+ if ($arg->{handle_overloads}) {
+ if (reftype $arg->{handle_overloads} eq 'CODE') {
+ $to_install{__overload_metamethod__} = $arg->{handle_overloads};
+ $handle_overloads = '__overload_metamethod__';
+ } elsif ($arg->{handle_overloads} eq 'metamethod') {
+ $handle_overloads = $metamethod;
+ } else {
+ Carp::confess("unknown value for handles_overloads");
+ }
+ }
my $method_name;
my $wiz = wizard
- copy_key => 1,
- data => sub { \$method_name },
- fetch => sub {
- return if (substr $_[2], 0, 1) eq '(';
- ${ $_[1] } = $_[2];
- $_[2] = 'invoke_method';
- return;
- };
+ copy_key => 1,
+ data => sub { \$method_name },
+ fetch => $self->_gen_fetch_magic({
+ metamethod => $metamethod,
+ passthru => $arg->{passthru},
+ handle_overloads => $handle_overloads,
+ });
- no strict 'refs';
-
- *{"$caller\::invoke_method"} = sub {
+ $to_install{ $metamethod } = sub {
my $invocant = shift;
$code->($invocant, $method_name, \@_);
};
+ no strict 'refs';
+ for my $key (keys %to_install) {
+ *{"$caller\::$key"} = $to_install{ $key };
+ }
+
cast %{"::$caller\::"}, $wiz;
}
+
+sub _gen_fetch_magic {
+ my ($self, $arg) = @_;
+
+ my $metamethod = $arg->{metamethod};
+ my $passthru = $arg->{passthru};
+ my $handle_overloads = $arg->{handle_overloads};
+
+ return sub {
+ return if $_[2] ~~ $passthru;
+
+ my $is_ol = (substr $_[2], 0, 1) eq '(';
+ return if $is_ol and ! $handle_overloads;
+
+ ${ $_[1] } = $_[2];
+ $_[2] = $is_ol ? $handle_overloads : '__metamethod__';
+ return;
+ };
+}
+
1;
View
@@ -3,8 +3,8 @@ use warnings;
use Test::More 'no_plan';
use lib 't/lib';
-require Class;
-require Instance;
+use Class;
+use Instance;
my $parent_class = Class->new({
name => 'ParentClass',
@@ -59,3 +59,4 @@ like($@, qr/no class method/, 'there is no class "plugh" on ParentClass');
ok($parent_instance->isa($parent_class), 'PI isa PC');
ok($child_instance->isa($parent_class), 'CI isa PC');
+
View
@@ -2,6 +2,8 @@ use strict;
use warnings;
package Class;
+our $VERSION = '1.234';
+
my %STATIC = (
new => sub {
my ($pkg, $arg) = @_;
@@ -37,7 +39,7 @@ my %UNIVERSAL = (
},
);
-use metamethod sub {
+sub invoke_method {
my ($invocant, $method_name, $args) = @_;
my $curr = $invocant;
my $code;
@@ -60,5 +62,10 @@ use metamethod sub {
unless $code ||= $UNIVERSAL{$method_name};
$code->($invocant, @$args);
-};
+}
+
+use metamethod
+ metamethod => \'invoke_method',
+ passthru => [ qw(VERSION import unimport) ];
+
1;
View
@@ -2,6 +2,8 @@ use strict;
use warnings;
package Instance;
+our $VERSION = '1.000';
+
my %STATIC = (
new => sub {
my ($class, $arg) = @_;
@@ -14,7 +16,7 @@ my %UNIVERSAL = (
isa => sub { return $_[0]->class->derives_from($_[1]); },
);
-use metamethod sub {
+sub invoke_method {
my ($invocant, $method_name, $args) = @_;
my $code;
@@ -26,10 +28,10 @@ use metamethod sub {
return $code->($invocant, @$args);
}
- my $curr = $invocant->{__class__};
+ my $class = $invocant->{__class__};
+ my $curr = $class;
while ($curr) {
- # Sadly, this has to be a hash deref until the tests pass once.
my $methods = $curr->instance_methods;
$code = $methods->{$method_name}, last
@@ -39,11 +41,15 @@ use metamethod sub {
unless ($code ||= $UNIVERSAL{$method_name}) {
my $msg = sprintf "no instance method %s on %s(%s)",
- $method_name, ref($invocant), $invocant->{__class__}->name;
+ $method_name, ref($invocant), $class->name;
die $msg;
}
$code->($invocant, @$args);
};
+use metamethod
+ metamethod => \'invoke_method',
+ passthru => [ qw(VERSION import unimport) ];
+
1;

0 comments on commit 01c9883

Please sign in to comment.