This isn't really a cool use for Perl, but more of a cool use of Perl.

I was making some updates to my Hook::Output::Tiny software, in which I have a couple of subs that do the exact same thing, but the names are different. One thing I like to do in cases such as this is auto generate the subs dynamically.

For example... you've got a module that has subs one(), two(), three() etc, and they all do the same thing... accept an optional value to stash into the object (setter), and return the value (getter). Each sub has the same (or perhaps different) default values. I always use the old-fashioned Perl way of writing OO code, so that would look like this:

sub one {
    my ($self, $value) = @_;
    
    $self->{one} = $value if defined $value;
    return $self->{one} // 1;
}
sub two {
    my ($self, $value) = @_;
    
    $self->{two} = $value if defined $value;
    return $self->{two} // 2;
}
# and so on...
[download]

That gets tedious and frustrating, and is prone to mistypes and other mistakes. What I often do in cases such as this, is auto generate these types of subs within a BEGIN block dynamically, using the magical no strict 'refs';, which allows us to muck with the symbol table directly and do very dangerous stuff in ways that one shouldn't normally do. Here's an example module:

package Dynamic;

use warnings;
use strict;

BEGIN {

    my %sub_info = (
        one     => 1,
        two     => 2,
        three   => 3,
        four    => 4,
        five    => 5,
    );

    no strict 'refs';

    for (keys %sub_info) {
        my $sub_name = $_; # Take a copy of the key, which is the sub 
+name

        *$_ = sub {
            my ($self, $value) = @_;
            $self->{$sub_name} = $value if defined $value;
            return $self->{$sub_name} // $sub_info{$sub_name};
        };
    }
}

sub new {
    return bless {}, $_[0];
}

1;
__END__
[download]

First, we set things up near the top of the file so it's easily visible within a BEGIN block to ensure the code is compiled first. Here's what's happening:

• %sub_info is a hash that contains each sub name as the key, and the default value we'll return if the user doesn't change it
• We disable strict's reference checking with no strict 'refs' so that we can perform super-dangerous stuff, like using a string as a symbol reference
• Iterate over the hash and copy the key name into a separate variable
• Set the current key name as the name of the new subroutine by prepending an asterisk to signify a symbol table entry, and assign it a new anonymous sub
• Just like any other method, we put the code in exactly as we would if we were manually writing it out. Note the use of $sub_name instead of using just $_. This is because we've clobbered $_ by assigning a sub to it. This is why we made a copy of it above
• Done! Looks just like any other setter/getter, but instead of typing out five subs that look near identical, we've only typed it out once, and let Perl write them for us in a loop

Here's a script that puts the new module into action. Note that both the module and script are in the same directory for this demonstration:

use warnings;
use strict;
use feature 'say';

use lib '.';

use Dynamic;

my $dyn = Dynamic->new;

say "Manual calls";

say $dyn->one;
say $dyn->two;

# Or even

say "Stringified calls";

for (qw(one two three four five)) {
    if ($_ eq 'three') {
        # Update the value of the 'three' method
        $dyn->three(99);
    }
    printf "sub $_: %d\n", $dyn->$_();
}
[download]

Output:

spek@scelia ~/repos/scripts/perl/dynamically_auto_generate_subs $ perl
+ dyn.pl

Manual calls
1
2
Stringified calls
sub one: 1
sub two: 2
sub three: 99
sub four: 4
sub five: 5
[download]

In closing, if you're only doing a couple of subs, it probably isn't worth the hassle, but when you are doing several, it makes things very simple, especially if you need to add new ones in the future. You simply have to enter a new record into the hash.

Here's the code section that I just wrote that inspired me to write this post. It's from my Hook::Output::Tiny distribution. I am dynamically creating four methods... stdout() and stderr() which effectively do the same thing but act on different things, and their helper counterparts _stdout() and _stderr():

BEGIN {
    # Auto generate the stdout() and stderr() methods, and their priva
+te
    # helper counterparts

    no strict 'refs';

    for ('stdout', 'stderr') {
        my $sub_name = $_;

        # Public

        *$_ = sub {
            my ($self) = @_;

            if (! wantarray) {
                warn "Calling $sub_name() in non-list context is depre
+cated!\n";
            }
            return defined $self->{$sub_name}{data}
                ? split /\n/, $self->{$sub_name}{data}
                : @{[ () ]}; # Empty list
        };

        # Private

        my $private_sub_name = "_$sub_name";

        *$private_sub_name = sub {
            my ($self) = @_;

            my $HANDLE = uc $sub_name;
            open $self->{$sub_name}{handle}, ">&$HANDLE"
              or die "can't hook " . uc $sub_name . ": $!";
            close $HANDLE;
            open $HANDLE, '>>', \$self->{$sub_name}{data} or die $!;
        };
    }
}
[download]