もちろん!

cover
Advanced Perl Programming, 2nd Ed.
 Simon Cozens
[邦訳:実用Perlプログラミング第2版]
naoyaグループ - naoyaの日記 - Perl で Singleton Method
ということで Class::SingletonMethod みたいにクラス名を汚染しちゃうような方法以外で Singleton Method (特異メソッド) を実現する方法はないかなあ。

賢明で懸命なヒョウ本(持ってない人は上から買ってちょんまげ)の読者は、これを思いつくと思うのだけど。

package Object::SingletonMethod;

use 5.008001;
use strict;
use warnings;
use Carp;
use Data::Dumper;

our $VERSION = '0.01';
our $DEBUG   = 1;

my %Method;

sub singleton_method {
    my $self = shift;
    my ( $method, $subref ) = @_;
    ref $subref eq 'CODE'
      or croak '$obj->singleton_method(name => sub{...})';
    $Method{ $self + 0 }{$method} = $subref;

}

sub can {
    my ( $self, $method ) = @_;
    my $subref = $Method{ $self + 0 }{$method};
    return $subref if $subref;
    return $self->SUPER::can($method);
}

sub DESTROY {
    my $self = shift;
    $DEBUG and carp "Destroing $self";
    delete $Method{ $self + 0 };
}

sub AUTOLOAD {
    my $self   = shift;
    my $method = our $AUTOLOAD;
    $method =~ s/.*:://;
    $DEBUG and carp "($self)->$method";
    if ( my $subref = $Method{ $self + 0 }{$method} ) {
        $subref->( $self, @_ );
    }
    else {
        my $pkg = ref $self;
        croak qq(Can't locate object method "$method" via package "$pkg");
    }
}

1;
__END__

以下で実証。

#
use strict;
use warnings;
use Data::Dumper();

package Foo;
use base 'Object::SingletonMethod';

sub new {
    my $class = shift;
    bless {@_} => $class;
}
sub dump{
    my $self = shift;
    local ($Data::Dumper::Terse) = 1;
    return Data::Dumper::Dumper($self);
}

package main;

my $foo = Foo->new;
my $far = Foo->new;

$foo->singleton_method(
    inc => sub {
        my $self = shift;
        $self->{_inc}++;
        $self;
    }
);

$foo->inc;
$foo->inc;
print "foo can inc? ", ( $foo->can('inc') ? "Yes" : "No" ), "\n";
print "foo can new? ", ( $foo->can('new') ? "Yes" : "No" ), "\n";
print "foo can pee? ", ( $foo->can('pee') ? "Yes" : "No" ), "\n";
print "far can inc? ", ( $far->can('inc') ? "Yes" : "No" ), "\n";
print "far can new? ", ( $far->can('new') ? "Yes" : "No" ), "\n";
print "far can pee? ", ( $far->can('pee') ? "Yes" : "No" ), "\n";
print $foo->dump;
cover
Perl Best Practices
Damian Conway

実はこの特定のmy variableに$object + 0をキーにしてインスタンスをしまい込むという方法は、Inside-Out Objectと呼ばれる、比較的新しいPerlのObject実装法で、これをDamian流に徹底的に昇華させたのがClass::Std。これ、いつか詳細解説(つーか添削!)するつもりだけど、待てない人はロングテールなワンコ本→をじっくりお読みあれ。

Dan the Man with Too Many Ways to Do Too Many Things