Extending a Perl non-Moose respecting encapsulation - perl

Question

I have a legacy project and I would like to extend a couple of classes in it with a few attributes and methods. I have access to the source code and know that the class uses a blessed hashref. I can of course go ahead and extend that hashref adding the keys that I want and re-bless into my class. But obviously this breaks encapsulation and I would like to avoid it as much as I can.
Is there a way to extend a (non-Moose) Perl class with attributes, not just methods, in a way that does not break encapsulation of the orginal class? The option to use Moose to do this is not available. Thank you.

Answer 1

First, one best practice for writing objects based on hashrefs is to prefix all fields with the package name, e.g.
package Parent;
sub new {
my ($class, $x, $y) = #_;
bless { "Parent::x" => $x, "Parent::y" => $y } => $class;
}
sub x { shift()->{"Parent::x"} }
sub y { shift()->{"Parent::y"} }
In that case, the issue doesn't arise, as every class has its own attribute namespace. But who writes his classes that way?
There are two ways I can think of to circumvent any problems: Proxying the original object via Autoload, or using inside-out object patterns. The third solution is to use prefixed attributes in your class, and hope that the parent never ever uses these names.
Inside-Out Objects
An inside-out object uses the blessed reference as an ID, and stores the attributes in lexical variables inside your class:
package Child;
use Scalar::Util qw/refaddr/;
use parent 'Parent';
my %foo;
sub new {
my ($class, $foo, #args) = #_;
my $self = $class->SUPER::new(#args);
$foo{refaddr $self} = $foo;
return $self;
}
sub foo {
my ($self) = #_;
$foo{refaddr $self};
}
sub set_foo {
my ($self, $val) = #_;
$foo{refaddr $self} = $val;
}
sub DESTROY {
my ($self) = #_;
# remove entries for this object
delete $foo{refaddr $self};
$self->SUPER::DESTROY if $self->SUPER::can('DESTROY');
}
This is a slightly dated pattern, but it works extremely well for your use case.
Proxy objects
We can contain a parent instance in a field of our class (i.e. both has-a and is-a relationship). Whenever we encounter unknown methods, we delegate to that object:
package Child;
use Parent ();
our $SUPER = 'Parent';
use Carp;
sub new {
my ($class, $foo, #args) = #_;
bless {
parent => $SUPER->new(#args),
foo => $foo,
} => $class;
}
sub foo {
my ($self) = #_;
$self->{foo};
}
sub set_foo {
my ($self, $val) = #_;
$self->{foo} = $val;
}
# manually establish pseudo-inheritance
# return true if our class inherits a given package
sub isa {
my ($self, $class) = #_;
return !!1 if $class eq __PACKAGE__;
return +(ref $self ? $self->{parent} : $SUPER)->isa($class);
}
# return a coderef to that method, or false
sub can {
my ($self, $meth) = #_;
my %methods = (new => \&new, foo => \&foo, set_foo => \&set_foo, DESTROY => \&DESTROY);
if (my $code = $methods{$meth}) {
return $code;
}
# check parent
my $code = ( ref $self ? $self->{parent} : $SUPER)->can($meth);
return undef unless $code;
return sub {
my $self = shift;
unshift #_, ref $self ? $self->{parent} : $self;
goto &$code;
};
}
# write explicit destroy to satisfy autoload
sub DESTROY {
my ($self) = #_;
$self->{parent}->DESTROY if ref $self and $SUPER->can('DESTROY');
}
sub AUTOLOAD {
# fetch appropriate method coderef
my $meth = our $AUTOLOAD;
$meth =~ s/.*:://; # clean package name from name
my $code = $_[0]->can($meth);
$code or croak qq(Can't locate object method "$meth" via package "#{[__PACKAGE__]}");
goto &$code;
}
The ugly part is to fake methods defined in superclasses in the can code: We have to wrap the actual method inside a anonymous sub that unpacks our object to call the method on the proxied object. The gotos make our extra levels invisible to the called code, which is neccessary when somebody uses caller.
Most of this boilerplate proxying code can be abstracted into another module (and probably is, somewhere on CPAN).