UNIVERSAL::can なんてあるのね

A というすでにいろんなメソッドが定義されているクラスがあって、その中に foo っていうメソッドがすでにあったとします。で、その A というクラスを継承した B というクラスを作ったとして、でもあるプログラムで B のインスタンスを生成して $b->can('foo') ってやったときだけ真にならない(他のメソッドが呼ばれたときは真にする)方法ってないかということで先日 id:nipotanや id:ikebe と話をしていたところ、UNIVERSAL::can なるものをみつけた。これを使えばやりたいことはできるのではという話になりました。

UNIVERSAL::can はなにをするもんかというと、それを use したクラスに can というメソッドを定義すれば、そのクラスのインスタンスに対して $instance->can('hoge') ってやると、そのクラスに定義した can が使われるというものだそうで、これを上手く上記の問題に照らし合わせると。。。

B というクラスで、

sub can { $_[1] eq 'foo' ? undef : UNIVERSAL::can($_[0], $_[1]) }

という風に can を定義しておけば、やりたいことができるんじゃないかと。
テストコードの全容は下記のような感じです。これを実行すると $b->can('foo') は false なので sub foo { warn "foo" } は実行されず、$b->can('bar') はコードリファレンスが返されるので sub bar { warn "bar" } が実行されます。

#!/usr/local/bin/perl
use strict;

package a;

sub new { bless {}, shift }
sub foo { warn "foo" }
sub bar { warn "bar" }

package b;

use base qw(a);
use UNIVERSAL::can;

sub can { $_[1] eq 'foo' ? undef : UNIVERSAL::can($_[0], $_[1]) }

package main;

my $b = b->new;
$b->can('foo') && $b->can('foo')->();
$b->can('bar') && $b->can('bar')->();

これ他にやりかたあるんだろうか…。ちなみに、普通の can は perldoc UNIVERSAL とやると説明が書いてあるというのも初めて知りました。。。 コメントにありますが、当初やりたかったことは B のクラスに sub can {} を定義してやれば $b->can() って呼んでやるのであれば解決するという結論になりました。UNIVERSAL::can() を使う場合には UNIVERSAL::can モジュールを use してやる必要があるようです。