Now you see it, now you don't

I'd like to start out with a disclaimer. The ideas below are primarily a demonstration of the flexibility of Perl's object system. Using it in a real application is potentially dangerous. I suspect it will have little, if any, benifit for solving real-world problems. It's just a crazy, random idea that managed to escape the bowels of my brain and into the light. I have no idea if it is even truely orginal (really, it's a natural progression of a fairly well-known Perl construct). It won't hurt to learn about it, but then again, many programmers have perfectly happy careers not knowing about Duff's Device.

Many objects use accessors and mutators to provide restricted access to otherwise private data. In Perl, the accessors and mutators are often combined into a single method, like this:

sub foo 
{
    my $self = shift;
    $self->{foo} = shift if @_;
    return $self->{foo};
}
[download]

90% of the time, the code for each accessor/mutator is identical to all other accessors/mutators, except for the name of the field. In Perl, there is a shortcut we can use involving closures to generate the accessors/mutators (this snippet is a trimmed-down version of the one on pp. 338-339 of the Blue Camel):

for my $field (qw(name race aliases)) {
    my $slot = __PACKAGE__ . "::$field";
    no strict "refs";   # So symbolic ref to typeglob works
    *$field = sub {
        my $self = shift;
        $self->{$slot} = shift if @_;
        return $self->{$slot};
    };
}
[download]

That is cool enough, and cuts out a lot of redundant code. Once I finally understood what was going on here, I was awestruck.

Let's move into a working application of the above:

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



package Foo;

sub new 
{
    my $invocant = shift;
    my $class    = ref($invocant) || $invocant;
    my $self     = { };
    bless $self, $class;

    $self->{baz} = 1;
    $self->{bah} = 2;
    
    return $self;
}

sub baz 
{
    die "baz() not overriden\n";
}

sub bah 
{
    die "bah() not overriden\n";
}


package Bar;

our @ISA = qw(Foo);

for my $field (qw(baz bah)) {
    my $slot = __PACKAGE__ . "::$field";
    no strict 'refs';  # Need symbolic refs to typeglob

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


package main;

my $obj = Bar->new();

print "Baz: ", $obj->baz, "\n";
print "Bah: ", $obj->bah, "\n";
[download]

Run that, and you'll see it print out:

Baz: 1
Bah: 2
[download]

Now remove the 'bah' on line 37 from the list. It will now die when it calls $obj->bah.

Now for the dangerous part. Using closures, we can create and destroy methods at runtime whenever we feel like it.

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



package Foo;

sub new 
{
    my $invocant = shift;
    my $class    = ref($invocant) || $invocant;
    my $self     = { };
    bless $self, $class;

    $self->{baz} = 1;
    $self->{bah} = 2;
    
    return $self;
}

sub baz 
{
    die "baz() not overriden\n";
}

sub bah 
{
    die "bah() not overriden\n";
}


package Bar;

our @ISA = qw(Foo);
my @DYNAMIC_METHODS = qw(faz);

sub make_methods 
{
    for my $field (@DYNAMIC_METHODS) {
        my $slot = __PACKAGE__ . "::$field";
        no strict 'refs';
    
        *$field = sub {
            print "Called faz\n";
        };
    }
}

sub destroy_methods 
{
    for my $field (@DYNAMIC_METHODS) {
        my $slot = __PACKAGE__ . "::$field";
        no strict 'refs';

        undef *$field;
    }
}

for my $field (qw(baz bah)) {
    my $slot = __PACKAGE__ . "::$field";
    no strict 'refs';  # Need symbolic refs to typeglob

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


package main;

my $obj = Bar->new();

print "Baz: ", $obj->baz, "\n";
print "Bah: ", $obj->bah, "\n";

$obj->make_methods();
$obj->faz();
$obj->destroy_methods();
$obj->faz();
[download]

The second call to $obj->faz() will fail. Crazy, no?

Update: Fixed bug in the example closure where $fields and $slot were in the wrong places (thanks to djantzen for pointing this out).

Comment on Now you see it, now you don't Select or Download Code

Replies are listed 'Best First'.
Re: Now you see it, now you don't by chromatic (Archbishop) on May 29, 2003 at 17:10 UTC
Using closures, we can create and destroy methods at runtime whenever we feel like it. Actually, that's thanks to run-time symbol table manipulation and subroutine references. They're related, but they're not the same.	[reply]
•Re: Now you see it, now you don't by merlyn (Sage) on May 29, 2003 at 16:34 UTC
`my $class = ref($invocant) \|\| $invocant;` [download] Please, no. -- Randal L. Schwartz, Perl hacker Be sure to read my standard disclaimer if this is a reply.	[reply] [d/l]
Re: •Re: Now you see it, now you don't by hardburn (Abbot) on May 29, 2003 at 16:39 UTC
Perhaps, but you see it everywhere, including the Blue Camel, perltoot, and perlobj. I don't think you can blame people for using it if it shows up without comment in the primary sources of Perl documentation. ---- I wanted to explore how Perl's closures can be manipulated, and ended up creating an object system by accident. -- Schemer Note: All code is untested, unless otherwise stated	[reply]
•Re: Re: •Re: Now you see it, now you don't by merlyn (Sage) on May 29, 2003 at 16:45 UTC
Right. All the sources you cite are from One Guy who was not doing OO programming in 1980 (as I was). That's why I am working hard to correct the meme, stamping on it a bit whenever I see it quoted again, and why I wrote perlboot to also go into the distro as a better example. -- Randal L. Schwartz, Perl hacker Be sure to read my standard disclaimer if this is a reply.	[reply]
Re: •Re: Now you see it, now you don't by Mr. Muskrat (Canon) on May 29, 2003 at 16:38 UTC
Mr. Muskrat corrects his copy of The Camel. ;-)	[reply]
Re: Now you see it, now you don't by diotalevi (Canon) on May 29, 2003 at 18:02 UTC
And now for the same idea except one an object-by-object basis: Class::Classless. JavaScript already does this, some OO models like this, I think its nifty. Its also something that's perfectly safe to use in production code as long as you're clear about where the methods come from. Also, keep in mind that for even classic perl OO you can have methods whack themselves while they are running. This isn't normally terribly interesting unless your method is process recursive (and you don't consider altering an object's methods on the fly interesting).	[reply]
Re: Now you see it, now you don't by blakem (Monsignor) on May 29, 2003 at 21:07 UTC
`undef *$field;` Gotta be careful with that because it will blow away more than just the $field method. Say bye-bye to the $field array the $field hash and everything else in the $field stash... `my $obj = Bar->new() $Bar::faz = 100; print '$Bar::faz = ' . $Bar::faz . "\n"; $obj->destroy_methods(); print '$Bar::faz = ' . $Bar::faz . "\n"; __END__ $Bar::faz = 100 $Bar::faz = Doh!` [download] As written, it might also mess up the method lookup cache that perl uses to determine which methods are overridden and which aren't. What you'd really like is a way to localize the subroutine portion of the stash, but Perl doesn't provide a clean way to do that. Before you go much further down this path, you really should read the highly enlightening discussion at: Undefining subroutines and inheritance -Blake	[reply] [d/l] [select]
Re: Now you see it, now you don't by crouchingpenguin (Priest) on May 30, 2003 at 01:48 UTC
Or you can use AUTOLOAD. I use it in my base classes, then setup the inherited object's attributes in the object initialization (which AUTOLOAD will check to see if they exist before granting access to them). `### our magic accessor generator sub AUTOLOAD { my $self = shift; my $auto = (split(/\:\:/,$AUTOLOAD))[-1]; $auto = $AUTOLOAD unless $auto; return if $auto eq 'DESTROY'; ### ignore die "No such method: $auto\n" unless (exists $self->{$auto}); if ( @_ ){ my @args = @_; if( scalar(@args) > 1){ $self->{$auto} = \@args; }else{ $self->{$auto} = $args[0]; } }else{ return $self->{$auto}; } }` [download] cp ---- "Never be afraid to try something new. Remember, amateurs built the ark. Professionals built the Titanic."	[reply] [d/l]


Keep It Simple, Stupid
	PerlMonks