http://www.perlmonks.org?node_id=348189

OO Perl is almost always based on a hash for class data. Someone new to Perl object programming might not be exposed to any other way of doing it. However, it's possible to bless a lot more references than just hashes. This meditation demonstrates the use of a closure to provide an accessor/mutator to the internal class data. This technique provides enforced encapsulation to class data from any external source.

Below are the requirements for the object and some test code to go with each one. The tests assume 'ClosureObj' is the class implementing this, which defines internal data named 'foo', 'bar', and 'baz' and has two methods 'foo' and 'foop', which are both simple accessors/mutators. Note that 'foop' does not exist as valid class data (it's there to test the case where you've made a typo in accessing the data). 'SubClosureObj' is a subclass of 'ClosureObj' and defines the method 'bar', which is also a simple accessor/mutator.

  1. Constructor returns a 'ClosureObj' (start out with the basics)
    my $obj = ClosureObj->new(); isa_ok( $obj => 'ClosureObj' );
  2. Accessing the internal data directly from an external source is a fatal error.
    eval { $obj->('foo') }; ok( $@ =~ /^Attempt to access private class data/, "Stop from accessing class data" );
  3. Accessing non-existant class data is a fatal error.
    eval { $obj->foop() }; ok( $@ =~ /^No such field/, "Stop from accessing non-existant data" );
  4. Method 'foo' can get/set the internal value of 'foo'.
    $obj->foo(3); ok( $obj->foo == 3, "Foo is set" );
  5. Setting an attribute to 'undef' is OK (this can be broken in subtle ways, such as $field{foo} = $foo if defined $foo).
    { no warnings; # About unintitlized vars $obj->foo(undef); ok( $obj->foo == undef, "Foo can be set to undef" ); }
  6. Setting data in one object won't change another (i.e., we're not implementing a singleton--an early version of my implementation triped over this one).
    my $obj2 = ClosureObj->new(); isa_ok( $obj2 => 'ClosureObj' ); $obj->foo(2); $obj2->foo(3); ok( ($obj->foo == 2) && ($obj2->foo == 3), "Change in one object doesn't affect other" );
  7. Subclasses can get/set values.
    my $sub_obj = SubClosureObj->new(); isa_ok( $sub_obj => 'SubClosureObj' ); $sub_obj->bar(4); ok( $sub_obj->bar == 4, "Sub object can set values" );

Implementation

Most of the magic of this technique is in the constructor. Notice that the internal closure isn't called as a normal class method, so it doesn't have a way of figuring out what class it is part of. To provide this, we put the name of the class as another piece of class data. We also make sure that this data cannot be changed. (We could use __PACKAGE__, but that breaks subclasses).

sub new { my $class = shift; my %field = ( foo => 1, bar => 1, baz => 1, class => $class, ); bless sub { my $name = shift; my ($package, $filename, $line) = caller; die "Attempt to access private class data " . "for $field{class} at $filename line $line\n" unless UNIVERSAL::isa( $package => __PACKAGE__ ); die "No such field '$name' at $filename line $line\n" unless exists $field{$name}; die "You can't change the class name " . "at $filename line $line\n" if $name eq 'class'; $field{$name} = shift if @_; $field{$name}; } => $class; }

How the closure accesses the internal data is encapsulated even to the rest of the class. Depending on how much effort you're willing to put into the implementation, you should be able to switch from a hash to an array without changes to the rest of the class or subclasses.

If you want to make a singleton, you can move %fields to a code block outside the constructor:

{ my %fields = ( . . . ); sub new { my $class = shift; $fields{class} = $class; bless sub { # Same as before } => $class; } }

With the above, the same lexical is referenced to each time a new object is created. OTOH, the regular constructor will create a new lexical each time the constructor is called.

The foo and foop methods are nearly the same as you would see in a traditional hash-based object. Remember, foop is here for the purpose of testing the case where a field is accessed that doesn't exist.

sub foo { my $self = shift; $self->('foo', shift) if @_; $self->('foo'); } sub foop { my $self = shift; $self->('foop', shift) if @_; $self->('foop'); }

Note that I don't advocate spreading accessors/mutators all over your classes. That's usually an indication of sloppy design. However, this being an overview of the technique, it is useful in this case.

We also need a subclass with a bar method. This is also straightforward:

package SubClosureObj; use base qw( ClosureObj ); sub bar { my $self = shift; $self->('bar', shift) if @_; $self->('bar'); }

Putting everything together, including the tests, in a non-singleton implementation:


#!/usr/bin/perl package ClosureObj; use strict; use warnings; sub new { my $class = shift; my %field = ( foo => 1, bar => 1, baz => 1, class => $class, ); bless sub { my $name = shift; my ($package, $filename, $line) = caller; die "Attempt to access private class data " . "for $field{class} at $filename line $line\n" unless UNIVERSAL::isa( $package => __PACKAGE__ ); die "No such field '$name' at $filename line $line\n" unless exists $field{$name}; die "You can't change the class name " . "at $filename line $line\n" if $name eq 'class'; $field{$name} = shift if @_; $field{$name}; } => $class; } sub foo { my $self = shift; $self->('foo', shift) if @_; $self->('foo'); } sub foop { my $self = shift; $self->('foop', shift) if @_; $self->('foop'); } package SubClosureObj; use base qw( ClosureObj ); sub bar { my $self = shift; $self->('bar', shift) if @_; $self->('bar'); } package main; use Test::More tests => 9; my $obj = ClosureObj->new(); isa_ok( $obj => 'ClosureObj' ); eval { $obj->('foo') }; ok( $@ =~ /^Attempt to access private class data/, "Stop from accessing class data" ); eval { $obj->foop() }; ok( $@ =~ /^No such field/, "Stop from accessing non-existant data" ); $obj->foo(3); ok( $obj->foo == 3, "Foo is set" ); { no warnings; # About unintitlized vars $obj->foo(undef); ok( $obj->foo == undef, "Foo can be set to undef" ); } my $obj2 = ClosureObj->new(); isa_ok( $obj2 => 'ClosureObj' ); $obj->foo(2); $obj2->foo(3); ok( ($obj->foo == 2) && ($obj2->foo == 3), "Change in one object doesn't affect other" ); my $sub_obj = SubClosureObj->new(); isa_ok( $sub_obj => 'SubClosureObj' ); $sub_obj->bar(4); ok( $sub_obj->bar == 4, "Sub object can set values" );

Implications

You could argue that this enforced encapsulation goes against the orginal idea that you should stay out of the living room because you weren't invited, not because there is a guy with a shotgun. That may be the case, but I think this philosophy needs to be rethought. Apoc. 12 noted that Perl6 will definately have ways of keeping the uninvited out with a shotgun.

Keeping the internal representation away from even the class itself could be quite powerful. Classes that once conflicted because they were implemented using different datatypes could work together, assuming you're willing to do enough work in the closure to put them together (the technique may not necessarily be fast, but it should at least work). This failure to work together is one of the major problems with Perl OO, and the technique above could potentially fix it.

I suspect there are a lot of yet undiscovered uses for this technique that will only be revealed with time and community acceptance. If nothing else, it will shutup the Java people claiming that Perl OO has poor encapsulation.

Update: Small spelling fix.