Using Dispatch Tables To Improve Application Security

Update: I have changed the title to "Using Dispatch Tables To Improve Application Security" for clarity.

At a previous job, I saw some code that asked the user which function they wanted to run and then executed a subroutine with that name. This code demonstrates why such a practice is bad:

 use strict;
 use warnings;

 sub greet            { print "Hello!\n"       }
 sub inquire          { print "How are you?\n" }
 sub bye              { print "Farewell!\n"    }
 sub delete_all_files { print "*KABOOM*\n"     }

 sub insecure_call {
     no strict 'refs';
     shift->();
 }

 insecure_call('greet');
 insecure_call('inquire');
 insecure_call('bye');
 insecure_call('delete_all_files');

Output:

Hello!
How are you?
Farewell!
*KABOOM*

One solution to this is the dispatch table. With a dispatch table, you define up front which calls are legal for an outsider to make:

 use strict;
 use warnings;

 my %dispatch = (
     greet   => \&greet,
     inquire => \&inquire,
     bye     => \&bye,
 );

 sub greet            { print "Hello!\n"       }
 sub inquire          { print "How are you?\n" }
 sub bye              { print "Farewell!\n"    }
 sub delete_all_files { print "*KABOOM*\n"     }

 sub secure_call {
     my $call = shift;
     if ( ref $dispatch{$call} eq 'CODE' ) {
         $dispatch{$call}->();
     }
     else {
         warn "Invalid call $call";
     }
 }

 secure_call('greet');
 secure_call('inquire');
 secure_call('bye');
 secure_call('delete_all_files');

Output:

Hello!
How are you?
Farewell!
Invalid call delete_all_files at example_2a line 22.

The thing that bugs me about this particular solution (and I'll admit it's minor) is the repetition:

 my %dispatch = (
     greet   => \&greet,
     inquire => \&inquire,
     bye     => \&bye,
 );

To me, this reads like:

To go to greet, type 'greet'.
To go to inquire, type 'inquire'.
To go to bye, type 'bye'.

When it could just be asking "Which function do you wish to use?"

So, we could build the dispatch table dynamically from a list of acceptable calls:

 use strict;
 use warnings;

 my %dispatch;
 my @valid_calls = qw( greet inquire bye );

 sub greet            { print "Hello!\n"       }
 sub inquire          { print "How are you?\n" }
 sub bye              { print "Farewell!\n"    }
 sub delete_all_files { print "*KABOOM*\n"     }

 sub build_dispatch_table {
     no strict 'refs';
     %dispatch = map { $_ => *{$_} } @valid_calls;
 }

 sub secure_call {
     my $call = shift;
     if ( $dispatch{$call} ) {
         $dispatch{$call}->();
     }
     else {
         warn "Invalid call $call\n";
     }
 }

 build_dispatch_table();
 secure_call('greet');
 secure_call('inquire');
 secure_call('bye');
 secure_call('delete_all_files');

 print "\nBut, now this works because of the typeglob *{}\n";

 our @greet = qw( This is an array );
 print "@{$dispatch{greet}}\n";

 print "which annoys me even though it's probably inconsequential\n";

Output:

Hello!
How are you?
Farewell!
Invalid call delete_all_files

But, now this works because of the typeglob *{}
This is an array
which annoys me even though it's probably inconsequential

In addition to the typeglob annoyance, there is still a little repetition there: greet, inquire and bye still appear more than once in the code. I don't actually find this to be a huge deal, but how might we solve those issues? One way is including the code itself in the dispatch table:

 use strict;
 use warnings;

 my %dispatch = (

 # Documentation for greet can go here
 greet =>
     sub {
         my $greeting = shift || 'Howdy!';
         print "$greeting\n";
     },

 # Documentation for inquire can go here
 inquire =>
     sub {
         print "How are you?\n";
     },

 # Documentation for farewell can go here
 farewell =>
     sub {
         print "Bye!\n";
     },


 );

 sub delete_all_files { print "*KABOOM*" }

 sub api {
     my $call = shift;
     if ( $dispatch{$call} ) {
         $dispatch{$call}->(@_);
     }
     else {
         warn "Not executing unknown API call $call\n";
     }
 }

 api('greet','Hello.');
 api('inquire');
 api('farewell');
 api('delete_all_files');

Output:

Hello.
How are you?
Bye!
Not executing unknown API call delete_all_files

One argument against this is it adds visual complexity to the code: it's one more layer that a new developer on the project would need to mentally parse before coming up-to-speed on the code. But, that may be minor, and I think these formatting choices are developer-friendly.

Accepting Input from Multiple Sources

One of the corners I often paint myself into when developing a tool is only accepting one type of input, usually STDIN, the standard input stream, like a pipeline (ex: cat fruit.txt | grep apple) or a redirect (ex: grep apple < fruit.txt)

What inevitably happens is I end up wanting the tool to work like any Unix tool and accept different kinds of input (filenames or arguments on the command line, for example.)

Finally I got fed up with it and added a function called multi_input() to my library. Here is how it works:

First, the setup:

$ cat >meats
chicken
beef
^D
$ cat >fruits
apple
orange
banana
^D
$ cat >vegetables
carrot
lettuce
broccoli
cauliflower
^D
$ cat >a.out
this is just my
default input file
^D

To illustrate use of the function, I just reverse the input to do something "interesting" with it. The operative code is:

 my $input = multi_input();
 my $reversed = reverse $input;
 print "$input\n";
 print "$reversed\n";

So now I can interact with the tool in a variety of ways, starting with my "usual" way, STDIN:

$ ./reverse.pl < vegetables
current_input_type is: STDIN
carrot
lettuce
broccoli
cauliflower

rewolfiluac
iloccorb
ecuttel
torrac

Or STDIN by way of a pipe (this is the same mechanism in the code, but just to give another example):

$ cat fruits | ./reverse.pl
current_input_type is: STDIN
apple
orange
banana

ananab
egnaro
elppa

Or filenames provided on the command line:

$ ./reverse.pl meats fruits
current_input_type is: FILEARGS
chicken
beef
apple
orange
banana

ananab
egnaro
elppa
feeb
nekcihc

Or input provided on the command line:

$ ./reverse.pl this is not a list of filenames
current_input_type is: ARGS
this is not a list of filenames
semanelif fo tsil a ton si siht

And finally, the ultimate lazy, my default input file a.out:

$ ./reverse.pl
current_input_type is: DEFAULT
this is just my
default input file

elif tupni tluafed
ym tsuj si siht

Here is the full code listing with comments:

 #!/usr/bin/perl

 use strict;
 use warnings;

 use Term::ReadKey; # for ReadMode() below

 sub multi_input {
     my $input = '';
     my $VERBOSE = 1;

     my %INPUT_TYPE = ( # names for self-documenting code
        NONE     => 0,
        ARGS     => 1,
        FILEARGS => 2,
        STDIN    => 3,
        DEFAULT  => 4,
     );
     my %INPUT_LABEL = reverse %INPUT_TYPE; # allow lookup by number

     my $current_input_type = $INPUT_TYPE{NONE};

     # I could have done this all in one "shot" but I wanted to keep the
     # detection of input type separate from the processing of input
     my $char;
     if ( @ARGV ) {
         # Note that a filename typo will result in processing of the command
         # line like it is normal input, but that won't matter in this example.
         if ( -f $ARGV[0] ) {
             $current_input_type = $INPUT_TYPE{FILEARGS};
         }
         else {
             $current_input_type = $INPUT_TYPE{ARGS};
         }
     }
     else {
         # Code from Perl Cookbook. We peek into STDIN stream to see if
         # anything's there. The read still counts, though, so we need to save
         # $char. perldoc Term::ReadKey for information on ReadMode() and
         # ReadKey()
         ReadMode('cbreak');
         if (defined ($char = ReadKey(-1)) ) {
             $current_input_type = $INPUT_TYPE{STDIN};
         }
         else {
             $current_input_type = $INPUT_TYPE{DEFAULT};
         }
         ReadMode('normal');
     }
     warn "current_input_type is: $INPUT_LABEL{$current_input_type}\n"
         if $VERBOSE;

     if ( $current_input_type == $INPUT_TYPE{FILEARGS} ) {
         local $/; # Slurp the whole file in at once, not line-by-line
         for my $file (@ARGV) {
             open(my $ifh, '<', $file) or die "Can't open $file: $!";
             $input .= <$ifh>;
             close($ifh) || warn "close failed: $!";
         }
     }
     elsif ( $current_input_type == $INPUT_TYPE{ARGS} ) {
         $input = join ' ', @ARGV;
     }
     elsif ( $current_input_type == $INPUT_TYPE{STDIN} ) {
             # Slurp all STDIN at once, not line-by-line
             $input = $char . do { local $/; <STDIN> };
     }
     else {
         my $file = "a.out";
         open(my $ifh, '<', $file) or die "Can't open $file: $!";
         $input = do { local $/; <$ifh> };
         close($ifh) || warn "close failed: $!";
     }
     return $input;
 }

 my $input = multi_input();
 my $reversed = reverse $input;
 print "$input\n";
 print "$reversed\n";

Saving Vertical Space

I was reviewing some code I had written for a simple RPG dice algorithm (although there's already a good module for this, Game::Dice) and I realized again that I have a prefererence for functions that can fit on one screen. One strategy is breaking up the code into smaller routines but I sometimes like to compact it vertically as much as possible first.

This function roll, given a string of "dice language," should return the results of such a dice roll. An example of this would be "3d10+1" to roll three 10-sided dice and then add 1, or "4d6b3" which says to roll four 6-sided dice and take the best three.

Here's the function before the refactor:

sub roll {
    my $input = shift;
    die unless $input =~ /d/;
    if ( $input =~ /(\d*)d(\d+)\s*(\D?)\s*(\d*)/ ) {
        my $num   = $1 || 1;
        my $die   = $2;
        my $plus  = $3;
        my $end   = $4;
        my $total = 0;
        my @dice;
        for my $count ( 1 .. $num ) {
            my $single = int( rand($die) ) + 1;
            push @dice, $single;
            print "$single\n";
        }
        if ( $plus eq 'b' ) {
            if ( $end > $num ) {
                $end = $num;
            }
            @dice = sort { $b <=> $a } @dice;
            $#dice = $end - 1;
        }
        for my $die (@dice) {
            $total += $die;
        }
        if ( $plus eq '+' ) {
            $total += $end;
        }
        elsif ( $plus eq '-' ) {
            $total -= $end;
        }
        elsif ( $plus eq '*' ) {
            $total *= $end;
        }
        elsif ( $plus eq '/' ) {
            $total /= $end;
        }
        return $total;
    }
    return;
}

The first thing I did is to delete the first of this pair of lines, which was redundant, because the line that follows also checks the format of the input:

die unless $input =~ /d/;
if ( $input =~ /(\d*)d(\d+)\s*(\D?)\s*(\d*)/ ) {

But instead of having that big if block, I changed it to this:

return unless $input =~ /(\d*)d(\d+)\s*(\D?)\s*(\d*)/;

Then I combined these:

my $die   = $2;
my $plus  = $3;
my $end   = $4;

into this:

my ($die,$plus,$end) = ($2,$3,$4);

Once I decided I didn't need to print each individual die as it was rolled, I could reduce this:

for my $count ( 1 .. $num ) {
    my $single = int( rand($die) ) + 1;
    push @dice, $single;
    print "$single\n";
}

to this:

push @dice, int(rand($die))+1 for ( 1..$num );

Then, I changed this:

if ( $end > $num ) {
    $end = $num;
}

To use the postfix if:

$end =  $num if $end > $num;

and this:

for my $die (@dice) {
    $total += $die;
}

to use postfix for:

$total += $_ for @dice;

One thing I like to do with an if/else chain like this:

if ( $plus eq '+' ) {
    $total += $end;
}
elsif ( $plus eq '-' ) {
    $total -= $end;
}
elsif ( $plus eq '*' ) {
    $total *= $end;
}
elsif ( $plus eq '/' ) {
    $total /= $end;
}

is to compress it like this:

if    ( $plus eq '+' ) { $total += $end }
elsif ( $plus eq '-' ) { $total -= $end }
elsif ( $plus eq '*' ) { $total *= $end }
elsif ( $plus eq '/' ) { $total /= $end }

Since it's still short in width and the syntax can lined up to be quite readable.

So the final version of the refactored function is:

sub roll {
    my $input = shift;
    return unless $input =~ /(\d*)d(\d+)\s*(\D?)\s*(\d*)/;
    my $num = $1 || 1;
    my ($die,$plus,$end) = ($2,$3,$4);
    my $total = 0;
    my @dice;
    push @dice, int(rand($die))+1 for ( 1..$num );
    if ( $plus eq 'b' ) {
        $end =  $num if $end > $num;
        @dice = sort { $b <=> $a } @dice;
        $#dice = $end-1;
    }
    $total += $_ for @dice;
    if    ( $plus eq '+' ) { $total += $end }
    elsif ( $plus eq '-' ) { $total -= $end }
    elsif ( $plus eq '*' ) { $total *= $end }
    elsif ( $plus eq '/' ) { $total /= $end }
    return $total;
}

Now you can make things a lot smaller (see Perl Golf examples) but readability is important to me, and I think this is arguably as readable as the original. I was actually a little surprised that perltidy barely touched the if/elsif structure, just screwing up the alignment a little on the first line:

if ( $plus eq '+' ) { $total += $end }
elsif ( $plus eq '-' ) { $total -= $end }
elsif ( $plus eq '*' ) { $total *= $end }
elsif ( $plus eq '/' ) { $total /= $end }

The code doesn't strictly adhere to Perl Best Practices, which is something I like to use as a guide for the most part, but perlcritic (which is based on Perl Best Practices) doesn't start to complain until the cruel setting, then bringing up things like postfix if, postfix for, and unless.

How would you make it smaller while still maintaining readability?

How do you join the conversation?

blogs.perl.org is great in that it's a stream of blog posts around a specific technology. Since I, like many of you, blog about other technologies too, I'd like to learn from you about other conversation streams. For me personally, the list of topics include:

• Web development (JavaScript, CSS, etc)
• Lifehacks
• Unix, Linux, shell scripting
• General tech / tech business
• Database

I'll add what little knowledge I have on the topic:

There's reddit with corresponding subreddits on Unix and Perl. It looks like it's pretty routine to post blog entries on the Perl one at least, I'm not sure about the climate of other tech subreddits.

There are also subreddits for LifeProTips and Life Hacks. I've not yet participated in either, so again I'm not sure what the expectations are.

The Unix and Linux Forums, while not a "stream" of conversation, seems to be receptive to sharing ideas, and the people there are friendly and helpful.

And of course, Twitter with and without #perl and #unix hashtags. I say with or without as it seems like more popular bloggers, at least, don't bother with the hashtags. I'll also say that with or without the hashtags I haven't seen a lot of traffic coming from Twitter.

I'd appreciate anyone's advice, experience, or knowledge on this topic.

Thanks!

Fix Those Legacy Subroutines or Methods

Maybe you know the feeling… you go to add an option to that method or subroutine and… cue Jaws theme

sub update_shopping_cart {
    my $cart_id        = shift;
    my $item           = shift;
    my $quantity       = shift;

Argh. You don’t want your legacy code to break but you also don’t want to add a fourth unnamed parameter to the existing problem. And the solution is simple:

sub update_shopping_cart {
    my $cart_id        = shift;
    my $item           = shift;
    my $quantity       = shift;
    my $apply_discount = 0;        # Initialize the fourth parameter

    my $param1 = $cart_id;
    if ( ref $param1 eq 'HASH' ) {
        $cart_id        = $param1->{cart_id};
        $item           = $param1->{item};
        $quantity       = $param1->{quantity};
        $apply_discount = $param1->{apply_discount};
    }

Now either of these work. The legacy call:

update_shopping_cart( 314, 'apples', 3 );

…or the new style:

update_shopping_cart({
    cart_id        => 314,
    item           => 'apples',
    quantity       => 3,
    apply_discount => 1,
});

Bonus: there is no way to use the new option with the old-style call. If someone wants to use it, they’ll need to switch to the new style.

Pros:

• The new call is self-documenting. In the original form of the call, you see “314” in the code by itself, and it’s not immediately obvious what it is. Now it’s nicely labeled.
• Now that you have added the new format, you can painlessly add additional named parameters as needed.

Cons:

• It may be confusing to see two different styles of calls in your codebase. But, now you can transition the old code piecemeal.

Command Line Project Manager (clpm) v1.0.1 released

clpm is designed to make managing sets of files easier at the Unix command line. It's free and open source. Please view the demo here. Find more info at http://tinypig.com/clpm

Call for help with open source project "CLPM"

CLPM is my “Command Line Project Manager”. It’s a tool I wrote and have been using myself for several years now, and I am releasing it in the hope that others might find it useful.

Also, if you have been looking for an open source project to contribute to, here’s your chance! I don’t care what your level of experience is, if you think you have a useful comment or contribution, I’d like to hear from you!

There is a Todo section in the README, but I want to add a couple notes here:

1. It’s currently not packaged, nor does it have an installer. This probably makes it much less likely to be adopted.
2. I’m not sure how to promote it to make sure its audience (developers/sysadmins maybe) at least get a chance to see it, even if it ends up that it’s useful to nobody but me.

The project page has more details: https://github.com/tinypigdotcom/clpm

My First Day on the CPAN Pull Request Challenge

So yesterday, I started on the CPAN Pull Request Challenge. I was assigned the module Devel::StackTrace::WithLexicals, so, I read the doc and installed it.

The doc references two other modules’ influence: Devel::StackTrace and PadWalker

So I figured I’d have a look at those first. Combining two examples from the doc for Devel::StackTrace, I wrote this:

#!/usr/bin/perl

use strict;
use warnings;

use Devel::StackTrace;

sub foo {
    bar(@_,1234);
}

sub bar {
    my $trace = Devel::StackTrace->new();
    print $trace->as_string(); # like carp
}

foo('bing');

Which gave me this:

$ ./d.pl
Trace begun at d.pl line 13
main::bar('bing', 1234) called at d.pl line 9
main::foo('bing') called at d.pl line 17

Neat!

Next I looked at the doc for PadWalker. Based on the example provided, I wrote:

#!/usr/bin/perl

use strict;
use warnings;

use PadWalker qw(peek_my);

sub foo {
    my $abc = 123;

    bar();

    print "magic! $abc\n";
}

sub bar {
    my $h = peek_my(1);
    ${$h->{'$abc'}}++;
}

foo();

Which yields:

$ ./e.pl
magic! 124

So bar() increments foo()’s lexical variable $abc. What kind of witchcraft is this?!?

These are both very interesting modules. Changing lexicals from another scope defeats the purpose of a lexical, but as the doc points out, it can be useful for debugging purposes.

I reviewed the documentation for Devel::StackTrace::WithLexicals and the code, both of which can be viewed online at meta::cpan. In the left column are the links “Source (raw)” and “Browse (raw)” which are both handy to use when viewing the source.

Nothing immediately jumped out at me after reviewing the pull request ideas so I decided to contact the author to see if he had anything specific he’d like to see done. The author’s contact info is usually provided in the Author section of the documentation.

This is the email I sent:

Hello!

I have volunteered in the CPAN Pull Request Challenge
and have been assigned your module Devel::StackTrace::WithLexicals to
contribute to if possible.

Ideas include, but aren't limited to:
http://neilb.org/2014/12/31/pr-ideas.html

I'd like to know if you are receptive to contributions to this module and if
you had any particular needs or wishes.  I am willing to contribute with any
aspect (features, bugs, testing, documentation, etc.)  If you are ok with
contributions (pending your approval of course) but you don't have anything
specific in mind, I will review the PR Ideas list myself and see if I can find
a way to contribute.

Thank you,
David M. Bradford
http://tinypig.com

This morning I received a positive response from the author. Time to get to work!

Class Abuse

This situation arose recently and it got me curious...

What if you needed to access an algorithm in a very simple class method, but the functionality of the class is significant and would be a pain in the ass to set up and create an object in, not to mention resource-intensive, all to use one small function...

You could copy the algorithm, but what if it changes? Then you'll have to change it twice. That's no good. I don't like either option.

Remember when you call an object's method (or a class method) that the indirection syntax $self->method() or Whatever::Class->method() sends the thing before the -> as the first parameter.

So what if I just call that function directly? In some cases, I certainly could, for example: Whatever::Class::method($mydata)

In other cases, where the method looks in $self, I could just send the appropriate type of reference in with the value I needed, for example: Whatever::Class::method({data => $mydata})

In this case, it calls an accessor method -- in my example here, get_data() -- to get the value of one of its own properties. This is in line with some OOP philosophies, but it makes use of that method as an individual function that much more difficult.

However, I can just call the function with a first parameter which is an object that responds to the call to get_data

I wrote this naive decoder-ring algorithm to demonstrate.

#!/usr/bin/perl

use 5.14.0;
use autodie;

package Decoder_Ring;

sub new {
    my ( $class, $data ) = @_;
    return bless { data => $data }, $class;
}

sub decode {
    my ($self) = @_;
    return join( '',
        ( split( '', $self->get_data ) )
          [ 2, 7, 17, 24, 31, 37, 45, 54, 55, 65, 72, 77 ] );
}

sub get_data {
    my ($self) = @_;
    return $self->{data};
}

package main;

# Here's the normal object creation and method call to decode
my $normal_object =
  Decoder_Ring->new('?sSY y#ee Uiehor$cBc yL@rekLt AevLQYotUasjCGu!Z!a"');
print "normal result: ", $normal_object->decode, "\n";

# and here's the "fake" one:
# First, bless into unique class name to avoid polluting your namespace
my $pretender_object = bless {}, 'MyTemporaryClass';
my $input_data = 'l2a*lP lu*j!BfeCxssov@osol aupu Zwv+us P'
               . 'VSMvxekv vegA*crsY$L$2^ Sei!uVC$t!N?4.3';

# Next, push a method into the symbol table of the newly created class
*{MyTemporaryClass::get_data} = sub { return $input_data };

# Now our ad-hoc object will respond appropriately to the get_data call!
print "pretender result: ", Decoder_Ring::decode($pretender_object), "\n";

Output:

$ ./sandbox.pl
normal result: Secret!
pretender result: also secret.

But, I wouldn't put this in production code and I wouldn't recommend anyone else do it either, or at least comment heavily if you must.  However, it is an interesting exercise and illustrates Perl's highly flexible OO implementation.

When a Tradeoff is not a Tradeoff

Years ago, I wrote a post on clever code and advised against it, saying that instead we should strive to make our code maintainable. Since then, I gave a talk at DCBPW called Writing Maintainable Perl. During the talk, I broke a single line of code into multiple lines of code. A member of the audience pointed out that this could have performance ramifications because every time there is a semicolon, Perl does some cleanup and other maintenance tasks. I don’t know much about Perl internals. I have since looked around for more info on this, but Google was not my friend in this case, and perlguts didn’t seem to have what I was looking for in this department either.

In the real world this type of optimization is unlikely to make much of a difference. If you have code that’s dealing with I/O from users, databases, filesystems, etc, an internal language mechanism is just not going to be a factor.

Anyway… thinking back to Damian Conway’s book Perl Best Practices, I remembered a suggestion: “Don’t optimize; benchmark.” whose accompanying text proposed that instead of looking through the code for things you might improve, you should instead run Benchmark tests against your code and see how it performs.

I decided to put both versions of the code to the test and see how they perform. Here are the results:

10:54 dbradford@dbradford-PC presentation ] > ./both_listifys.pl
Benchmark: timing 5000000 iterations of good_listify, orig_listify...
good_listify: 20 wallclock secs (19.75 usr +  0.19 sys = 19.94 CPU) @
250789.99/s (n=5000000)
orig_listify: 23 wallclock secs (22.01 usr +  0.62 sys = 22.64 CPU) @
220887.08/s (n=5000000)

“good_listify” is the cleaned up version of the routine and “orig_listify” is the “bad” version. As you can see, the difference was negligible - when I ran the test five million times there was only a difference of three seconds. However, it was a surprise to me to see that the more maintainable version was faster.

Sometimes it seems like we might trade away speed to get maintainability, but if you go back and check, you might find it doesn’t have to be a tradeoff at all. Taken to a wider view: don’t theorize; demonstrate!

Here is the code that produced the output above:

#!/usr/bin/perl

use strict;
use warnings;

use Benchmark qw(:all) ;
use Data::Dumper;

sub orig_listify {
   my ($aref,$cc) = @_;
   if( ref $aref eq 'ARRAY' && $cc > 0 ) {
       my $j;
       for(my $i=0; $i<=$#$aref; $i+=$cc) {
           push @$j, [@$aref[$i..$i+$cc-1]];
       }

       # BAD!
       $#{$j->[$#{$j}]}=$#$aref%$cc;

       @$aref = @$j;
       return 1;
   }
   return;
}

sub good_listify {
   my ( $in_aref, $elements_per_array ) = @_;
   return if (
       ref $in_aref ne 'ARRAY' or
       $elements_per_array <= 0
   );
   my @result_array;
   for( my $i = 0; $i <= $#$in_aref; $i += $elements_per_array ) {
       push @result_array, [
           @$in_aref[ $i..$i + $elements_per_array - 1 ]
       ];
   }
   my $final_aref        = $result_array[ -1 ];
   my $elements_in_final = $#$in_aref % $elements_per_array;
   # Truncate final array
   $#$final_aref = $elements_in_final;
   @$in_aref = @result_array;
}

my @my_array = ( 'one', 'two', 'three', 'four', 'five', 'six', 'seven',
'eight', 'nine', 'ten' );

my $count=5_000_000;

timethese($count, {
    'orig_listify' => sub { orig_listify(\@my_array, 4) },
    'good_listify' => sub { good_listify(\@my_array, 4) },
});

Why Dollar-Underscore Should Be Avoided

This bit me recently, so I wrote it in a condensed script to share with you fine people:

#!/usr/bin/perl

use strict;
use Data::Dumper;

my @my_array = ( 'one', 'two', 'three' );

for (@my_array) {
    print "Processing: {$_}\n";
    unknown_author::his_proc();
    print "\$_ is now toast {$_}\n";
}

print Data::Dumper::Dumper( \@my_array );

package unknown_author; # Hypothetically, someone else's module

sub his_proc {
    open I, $0;
    while (<I>) { # But $_ has been aliased to $my_array[index]
        # Doesn't even matter what's inside - the damage has been done
    }
    close I;
}

Output:

Processing: {one}
$_ is now toast {}
Processing: {two}
$_ is now toast {}
Processing: {three}
$_ is now toast {}
$VAR1 = [
          undef,
          undef,
          undef
        ];

Solution:

1. You can control this by changing your own code:

for my $item (@my_array) {
    print "Processing: {$item}\n";
    unknown_author::his_proc();
    print "\$item is fine: {$item}\n";
}

But in your modules/routines:

2. Don't modify $_ unless you know for sure what's in it.

3. If you feel you must modify $_ in your routine, first say:

local $_;

As in:

sub his_proc {
    local $_;

    open I, $0;
    while (<I>) { # This version of $_ is mine now
        # Now I can do whatever I want with $_
    }
    close I;
}

Remember that $_ is global!

Incidentally, this is covered in Perl Best Practices on page 85, "Dollar-Underscore", as the rule: "Beware of any modification via $_." I like my example better because it is more concise and it happened to me. Also, instead of "be careful", I think we should just avoid $_ altogether.

$_ offers a lot of conciseness, but it has large disadvantages in production code, such as introducing subtle bugs, and reducing readability (adding to the Perl-looks-like-line-noise meme). In addition, clarity suffers when using it as the default and unspecified argument to Perl builtins, such as print.

Save it for the one-liners!