Permalink
Browse files

more tests, overloading clearly hosed

  • Loading branch information...
rjbs committed Mar 23, 2009
1 parent 8fe4e0d commit e2a01e8ce3e8484e931a2a64e982961ca8279fe3
Showing with 77 additions and 14 deletions.
  1. +20 −14 lib/metamethod.pm
  2. +30 −0 t/misc-errors.t
  3. +27 −0 t/overloads.t
View
@@ -1,4 +1,5 @@
-package metamethod; # make my methods meta!
+package metamethod;
+use 5.010; # uvar magic does not work prior to version 10
use strict;
use warnings;
@@ -24,22 +25,27 @@ sub import {
if (reftype $code eq 'SCALAR') {
$code = $caller->can($$code);
Carp::confess("can't find metamethod via name ${ $arg->{metamethod} }")
- unless reftype $code eq 'CODE';
+ unless $code and 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;
+ my $overloads;
+ if ($arg->{overloads}) {
+ # XXX: detect name conflicts here -- rjbs, 2009-03-22
+ if ($arg->{overloads} eq 'metamethod') {
+ $overloads = $metamethod;
+ } elsif (! ref $arg->{overloads}) {
+ Carp::confess("unknown value for overloads");
+ } elsif (reftype $arg->{overloads} eq 'CODE') {
+ $to_install{__overload_metamethod__} = $arg->{overloads};
+ $overloads = '__overload_metamethod__';
+ } elsif (reftype $arg->{overloads} eq 'SCALAR') {
+ $overloads = ${ $arg->{overloads} };
} else {
- Carp::confess("unknown value for handles_overloads");
+ Carp::confess("unknown value for overloads");
}
}
@@ -50,8 +56,8 @@ sub import {
data => sub { \$method_name },
fetch => $self->_gen_fetch_magic({
metamethod => $metamethod,
+ overloads => $overloads,
passthru => $arg->{passthru},
- handle_overloads => $handle_overloads,
});
$to_install{ $metamethod } = sub {
@@ -71,17 +77,17 @@ sub _gen_fetch_magic {
my ($self, $arg) = @_;
my $metamethod = $arg->{metamethod};
+ my $overloads = $arg->{overloads};
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;
+ return if $is_ol and ! $overloads;
${ $_[1] } = $_[2];
- $_[2] = $is_ol ? $handle_overloads : '__metamethod__';
+ $_[2] = $is_ol ? $overloads : $metamethod;
return;
};
}
View
@@ -0,0 +1,30 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+use metamethod ();
+
+{
+ my $ok = eval {
+ package Foo;
+ sub __metamethod__ { "just here to cause problems" }
+ metamethod->import( sub { 1 } );
+ 1;
+ };
+
+ my $error = $@;
+ ok( ! $ok, "we can't use metamethod without custom name if conflict exists");
+ like($error, qr/already/, "... got the right error, more or less");
+}
+
+{
+ my $ok = eval {
+ package Bar;
+ metamethod->import(metamethod => \'doesnt_exist');
+ 1;
+ };
+
+ my $error = $@;
+ ok( ! $ok, "we can't provide metamethod by name if it doesn't exist");
+ like($error, qr/can't find/, "... got the right error, more or less");
+}
View
@@ -0,0 +1,27 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+use metamethod ();
+
+TODO: {
+ local $TODO = 'figure out how the crap overloading works';
+
+ my @calls;
+ {
+ package OLP; # overloads pass through
+ metamethod->import(
+ metamethod => sub {
+ my ($self, $method, $args) = @_;
+ push @calls, $method;
+ return $method;
+ },
+ overloads => 'metamethod',
+ passthru => [ 'ISA' ],
+ );
+ }
+
+ my $olp = bless {} => 'OLP';
+ my $str = "$olp";
+ is($str, '(""', "we stringified to the stringification method name");
+}

0 comments on commit e2a01e8

Please sign in to comment.