Perl class closure

Question

I have been trying to create a closure inside an object as described on perltoot. I have copied it exactly, even copy & pasting it, but I am still able to access the object in the usual way, $obj->('NAME'). I am staring to lose my patience with it!

I am I misunderstanding something? I have been using perl for years for personal projects and have just started to get to grips with classes and OOP in general.

package Person;

sub new {
     my $that  = shift;
     my $class = ref($that) || $that;
     my $self = {
        NAME  => undef,
        AGE   => undef,
        PEERS => [],
     };
     my $closure = sub {
        my $field = shift;
        if (@_) { $self->{$field} = shift }
        return    $self->{$field};
     };
     bless($closure, $class);
     return $closure;
}

sub name   { &{ $_[0] }("NAME",  @_[ 1 .. $#_ ] ) }
sub age    { &{ $_[0] }("AGE",   @_[ 1 .. $#_ ] ) }
sub peers  { &{ $_[0] }("PEERS", @_[ 1 .. $#_ ] ) }

1;

Answer 1

For a piece of software that is intended for teaching purposes this is a litle ugly. A lot of the obscurity is the methods after new. Something like

sub name { &{ $_[0] }("NAME",  @_[ 1 .. $#_ ] ) }

is opaque and unnecessary. The modern equivalent is

sub name {
  my $self = shift;
  $self->('NAME',  @_);
}

It is also debatable whether the $self should be the hash reference, as it is, or the blessed subroutine reference, whcih I believe it should be.

If I rename the hash reference $data (it has no name anyway except within the closure code) and the subroutine $self then maybe you can see something more recognizable? I have also added the appropriate boiler plater and some additional white space.

person.pm

use strict;
use warnings;

package Person;

sub new {

  my $class = shift;
  $class = ref($class) || $class;

  my $data = {
    NAME  => undef,
    AGE   => undef,
    PEERS => [],
  };

  my $self = sub {
    my $fname = shift;
    my $field = $data->{$fname};
    $data->{$fname} = shift if @_;
    return $field;
  };

  return bless $self, $class;
}

sub name {
  my $self = shift;
  $self->('NAME', @_);
}

sub age {
  my $self = shift;
  $self->('AGE', @_);
}

sub peers {
  my $self = shift;
  $self->('PEERS', @_);
}

1;

program.pl

use strict;
use warnings;

use Person;

my $person = Person->new;
$person->name('Jason');
$person->age(23);
$person->peers([qw/ Norbert Rhys Phineas /]);

printf "%s is %d years old.\n", $person->name, $person->age;
my $peers = $person->peers;
print "His peers are: ", join(", ", @$peers), "\n";

I hope that it is clearer. You can bless only a scalar reference, but while that is most usually a reference to a hash, here it is a reference to a closure, which is a piece of code together with the data it had access to at the time the closure was created.

Every call to the class's new method creates and defines a new lexical variable $data. Ordinarily that variable (and the anonymous hash that it references) would go out of scope at the end of the subroutine and be deleted. But in this case new returns a subroutine reference to the calling code.

It is up to that calling code to keep the reference that is passed. A call to any class's new method is pretty pointless if the returned object isn't kept. In this case the closure is deleted because nothing can access it any longer, and the $data variable and the anonymous hash are also deleted for the same reason.

All Perl subroutine references are closures, whether or not the associated data is of any use. This one contains an implicit reference to $data that will be maintained as long as anything holds a reference to that closure. All that means here is that the line

return $data->{$field};

will refer to the same $data as existed at the time new was executed, so the hash is persistent, and it can be populated and inspected by calls to the closure subroutine.

All the other methods do is execute the subroutine from the closure with a specific first parameter. For instance, the call

$person->name('trolley')

executes the Person::name($person, 'trolley'), which in turn removes the $person from the parameter array @_ and calls it (because it is a subroutine reference) using a specific first parameter instead, and copying the rest of the parameter array. Like $person->('NAME', 'trolley').

I hope this helps to address the right interpretation of your question.

Answer 2

Being a closure in itself does not prohibit access from external callers, it merely makes the interface more obscure to make foreign callers have to do a few extra jumps to get the internal state.

However, the fact the internal state is only accessible by a closure means you can do certain things in the closure function that apply access controls.

For instance, you could look at the return value of caller within the closure callback, to make sure the person invoking the closure are on a permitted whitelist of classes.

Then to circumvent that, one has to dig harder to get their calling code whitelisted somehow.

For instance, you could make yourself appear to be in the same package simply by doing:

sub foo {
      package Person; #haha, hax.
      $object->('NAME');
}

And that will lie to [caller]->[0] about which calling package is doing the code.

When it gets down to it, there's not many ways you can reliably hide state in such a way that its impenetrable, and its also somewhat disadvantageous to do so.

For instance, by obscuring private access, you make writing tests substantially harder, and you make it harder for other people to use your code in tests, because a common thing people do in tests is tweak internal state in various ways to avoid putting dependence on more complex and uncontrollable things.

And there are more than one ways to restrict access control to private values

For instance, I've been known to use Tie::Hash::Method to provide basic access control, such as, but not limited to:

• Warning / Dying when hash keys other than a predefined list were created / written to / read
• Warning / Dying when untrusted packages accessed internal state

And these techniques can help iron out code bugs too, not simply provide access restrictions, because it can help you refactor things and diagnose where legacy code is still using the deprecated interfaces.

Maybe this rather simple code could give some inspiration:

use strict;
use warnings;
use utf8;

{

    package Foo;
    use Tie::Hash::Method;
    use Carp qw(croak);
    use Class::Tiny qw(name age), {
        peers => sub { [] }
    };

    sub _access_control {
        my $caller = [ caller(2) ]->[0];
        if ( $caller ne 'Foo' ) {
            local @Foo::CARP_NOT;
            @Foo::CARP_NOT = ( 'Foo', 'Tie::Hash::Method' );
            croak "Private access to hash field >$_[1]<";
        }
    }

    sub BUILD {
        my ( $self, $args ) = @_;
        # return # uncomment for production!
        tie %{$self}, 'Tie::Hash::Method', STORE => sub {
            $self->_access_control( $_[1] );
            return $_[0]->base_hash->{ $_[1] } = $_[2];
          },
          EXISTS => sub {
            $self->_access_control( $_[1] );
            return exists $_[0]->base_hash->{ $_[1] };
          },
          FETCH => sub {
            $self->_access_control( $_[1] );
            return $_[0]->base_hash->{ $_[1] };
          };
    }
}

my $foo = Foo->new();
print qq[has name\n]  if defined $foo->name();
print qq[has age\n]   if defined $foo->age();
print qq[has peers\n] if defined $foo->peers();
$foo->name("Bob");
$foo->age("100");
print $foo->{name};  # Dies here.