Transparent singleton methods in Perl

eigen.pl

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

# Transparent singleton methods in Perl
# First a new anonymous class is created to hold the object's singleton 
# methods, this anonymous class assumes the role of the object's class 
# and the original class is designated as the super class of that anonymous
# class. This is completely transparent and the anonymous class can't be 
# referenced by name.

# This code was inspired by chocolateboy's Object::Extend [1], both 
# implementations have similar API but implementations differs.
# [1] https://github.com/chocolateboy/Object-Extend

use Carp           qw[croak];
use Package::Anon  qw[];
use Scalar::Util   qw[blessed refaddr];
use Sub::Name      qw[subname];

sub extend {
    @_ % 2 or croak(q/Usage: extend(OBJECT [, NAME => CODE])/);
    my ($object, %methods) = @_;
    my $class = blessed($object);
    my $stash = Package::Anon->blessed($object);
    my $eigen = sprintf '%s:0x%x', $class, refaddr($object);
    unless ($stash->{eigen} && $stash->{eigen} eq $eigen) {
        $stash = Package::Anon->new($class);
        $stash->{eigen} = $eigen;
        *{ $stash->install_glob('ISA') } = [ $class ];
        # Restore UNIVERSAL/SUPER ->isa method
        delete $stash->{isa};
        $object = $stash->bless($object);
    }

    while (my ($name, $code) = each(%methods)) {
        $stash->add_method($name, subname("${class}::${name}", $code));
    }

    return $object;
}

{
    package Animal;
    use Class::Tiny qw[name];

    sub speak {
        my ($self, $things) = @_;
        return sprintf 'My name is %s and I like %s', $self->name, $things;
    }
}

use mro;

use Test::More;

my $cow = Animal->new(name => 'Daisy');

is $cow->name, 'Daisy';
is $cow->speak('grass'), 'My name is Daisy and I like grass';

extend $cow =>
  speak => sub { return 'Mooo! ' . (shift)->next::method(@_) };

is $cow->speak('grass'), 'Mooo! My name is Daisy and I like grass';

extend $cow =>
  name => sub { 'Elsie' };

is $cow->speak('grass'), 'Mooo! My name is Elsie and I like grass';

extend $cow => 
  sleep => sub { 'Zzzzzz' };

is $cow->sleep, 'Zzzzzz';

can_ok $cow, 'name';
can_ok $cow, 'speak';
can_ok $cow, 'sleep';
is ref $cow, 'Animal';
ok !ref($cow)->can('sleep');
ok $cow->isa('Animal');
ok UNIVERSAL::isa($cow, 'Animal');

done_testing;