Learning Perl by Reading and Stealing Code from CPAN…

DadHacker has recently posted about interviewing people that simply can’t name the “most interesting code they’ve read.” At work I mostly look at mediocre accounting application code, but I tend to try to stick to cutting SQL and parsing report text files. That doesn’t lead to a lot of interesting code reading. Books give you the basics of syntax and concepts… but the pressures of the real world are very different. There’s definitely a hole in my education here, so it’s time to start surfing source code files instead of programming blogs. CPAN makes it easy. Let’s see what we can turn up today….

Starting with something simple that I’ve implemented many times myself, let’s look at the dice rolling code first….

Philip Newton’s Games::Dice is pretty nifty. His regex is broken down with the /x option to make it easy to understand. I like how he uses ‘||’ to default functions that don’t pull anything from the regex:

$sign = $2 || ”;

In the past I’ve used two or three lines to do the same thing. It might be cryptic to certain classes of non-Perl programmers, but it seems to be typical of more idiomatic Perl. Another thing you see him do with his function variables is declare them all at the top. (I tend to declare them willy nilly….) Finally, you see him explicitly returning undef if the argument criteria aren’t met. I’ll keep that one in my ditty bag….

David Cantrell’s Games::Dice::Advanced uses a pretty flexible object oriented style interface. He blithely tosses in a folding operation in there:

sub foldl {
  my($f, $z, @xs) = @_;
  $z = $f->($z, $_) foreach(@xs);
  return $z;

sub sum { foldl(sub { shift() + shift(); }, @_); }
print "This sum is ... " .  sum(1, 2, 3, 4) . "\n";

To make sure I understood what this one was doing I wrote a little function to illuminate what was happening:

sub visible_sum {
    foldl( sub { my $x = shift;
                 my $y = shift;
                 print "adding $x and $y\n";
                 return $x + $y; },

visible_sum(1, 2, 3, 4);

Here’s a gratuitous attempt to emulate the style of SICP in Perl:

sub myfold {
    my($function, $first, @rest) = @_;
    return $first unless @rest;
    return myfold($function,
                  $function->($first, shift(@rest)),

my $add = sub { $_[0] + $_[1]; };

print "myfold returns " . myfold( $add,
                                  1, 2, 3, 4)
                        . "\n";

Just messing around…. I like how you basically get first and rest functions for “free”. The anonymous function syntax of Perl is perfectly workable, but not very pretty. I checked through Higher Order Perl hoping to find something better than the shifting and the array references we used above, but was disappointed. Sigh. You can’t have it all.

I like David’s idea about making reusable dice objects. Without taking a lot of time to try to read it, I’m not going to get around to understanding his code, though. I’m not too fond of ‘bless’ or Perl’s object system in general…. On the other hand, Philip’s code is running the regex to parse the dice text every single time you call his functions. Hmm….

OOP is overkill here. If ever there’s a time to trot out closures, this is it. In my apps, I’d probably steal Philip’s well-documented regex’s and roll them out with something like this:

sub roll_maker ($) {
    my($line, $num, $type);

    $line = shift;

    return undef unless $line =~ m{
                 ^      # beginning of line
                 (\d+)? # optional count in $1
                 [dD]   # 'd' for dice
                 (      # type of dice in $2:
                    \d+ # either one or more digits
                  |     # or
                    %   # a percent sign for d% = d100
              }x;       # whitespace allowed

    $num    = $1 || 1;
    $type   = $2;

    $type  = 100 if $type eq '%';

    return sub {
        my $result;
        for( 1 .. $num ) {
            $result += int (rand $type) + 1;
        return $result;

my $roller = roll_maker("3d6");
print "Roll 3d6: " . $roller->() . "\n";

Philip Newton’s code allows for some customization by taking on an expression to modify it. It seems strange to have to write an impromptu parser just for this. I think we should use the regex to validate what comes into the function, here… but this may be an acceptable use of eval. Just like the closure above saving the function definition for later, we’ll use eval just a tiny tiny bit here and save it’s results for later use, too. (This needs a couple of tweeks– I’m only handling + and * properly just yet…. This is just to show the idea…. Don’t have time to fix this, now….)

sub define_sub {
  my $text = shift;
  return eval "sub { $text }";

sub roll_expression_maker ($) {
    my($line, $dice_string, $sign, $offset, $sum, $roller, $exp);

    $line = shift;

    return undef unless $line =~ m{
                 ^              # beginning of line
                 (              # dice string in $1
                   (?:\d+)?     # optional count
                   [dD]         # 'd' for dice
                   (?:          # type of dice:
                      \d+       # either one or more digits
                    |           # or
                      %         # a percent sign for d% = d100
                 (?:            # grouping-only parens
                   ([-+xX*/bB]) # a + - * / b(est) in $2
                   (\d+)        # an offset in $3
                 )?             # both of those last are optional
              }x;               # whitespace allowed

    $dice_string = $1;
    $sign        = $2 || '';
    $offset      = $3 || 0;

    $sign        = lc $sign;

    $roller = roll_maker( $dice_string );
    return undef unless $roller;

    $exp = define_sub('my $arg = shift; return $arg ' . $sign . ' ' . $offset . ';');
    return undef unless $roller;
    return sub { $exp->($roller->()); };

my $funny = roll_expression_maker("3d6+20");
print "funny " . $funny->() . "\n";

If we’re calling these functions a lot with the same types of requests, then it would make sense to memoize them. That would cut back on the times we parse these regex’s and run the evil eval….


4 Responses to “Learning Perl by Reading and Stealing Code from CPAN…”

  1. draegtun Says:

    How about fold { $a + $b } qw/1 2 3 4/; for a prettier anonymous sub? This can be done like so….

    sub fold (&@) {
        my $code   = shift;
        my $caller = caller;
        use vars qw($a $b);
        no strict 'refs';
        local *{ $caller . '::a' } = \my $a;
        local *{ $caller . '::b' } = \my $b;
        $a = shift;    # first
        return $a unless @_;
        $b = shift;
        return &fold( $code, $code->(), @_ );
    say "fold returns ", fold { $a + $b } qw/1 2 3 4/;
    say "visible sum.... ";
    fold { say "$a + $b"; $a + $b } qw/1 2 3 4/;

    The clever thing here is the lexical $a & $b in fold() are aliased back to $a & $b in the anon sub so making the magic work.

    NB. Like your I’ve stood on shoulders’ of giants of CPAN. This kinda of code can be found in List::Util & List::MoreUtils (I think “reduce” & “pairwise” are good examples of this).

    You can use other variables names to $a & $b however this will give errors/warnings unless your declare them beforehand because $a & $b are “special”. See http://perldoc.perl.org/perlvar.html (look for $a) & recent “discussion” on Stackoverflow


  2. draegtun Says:

    Additional to my comment above u might find this blog article very interesting Macros are probably not necessary by Jonathan Rockway.


  3. draegtun Says:

    re: “but this may be an acceptable use of eval”

    Well its certainly not a bad use of string eval.

    U could amend your “define_sub” slightly to something like…

    sub return_exp {
        my $text = shift;
        my $exp  = '$_[0]' . $text;
        return sub { eval $exp };
    # .....
    $exp = define_sub( "$sign $offset" );

    …. so reducing what the eval is playing with.

    And of course you could do it by dispatch table instead…

    sub return_exp {
        my ( $sign, $offset ) = @_;
        my %dispatch = (
            '-'     => sub { $_[0] - $offset },
            '+'     => sub { $_[0] + $offset },
            'xX*'   => sub { $_[0] * $offset },
            # and any other expressions
        die "Invalid sign" unless exists $dispatch{ $sign };
        return $dispatch{ $sign };
    # ...
    $exp = return_exp( $sign, $offset );


    PS. This is a great example of what a good blog should be. I finding all this very enjoyable, extremely interesting & very informative.

  4. draegtun Says:

    Opps… excuse my typos in above code! I really wish WordPress had a preview option on comments ;-(

    Anyway it allows me to provide a quick change to a bug in that in the above dispatch table code….

    sub return_exp {
        my ( $sign, $offset ) = @_;
        my %dispatch = (
            '-'      => sub { $_[0] - $offset },
            '+'      => sub { $_[0] + $offset },
            'x|X|\*' => sub { $_[0] * $offset },
            '/'      => sub { eval { int($_[0] / $offset) } || $_[0] },
        # return if its a key
        return $dispatch{ $sign }  if exists $dispatch{ $sign };
        # return if its matches a key
        for my $key ( keys %dispatch ) {
            return $dispatch{ $key }  if $sign =~ m/^$key$/mx;
        # otherwise die!
        die "Invalid sign";

    That’s better…. now the dispatch work on ‘xX\*’ for multiply.

    BTW…. Note the not evil eval block to catch any divide by zero errors.


Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: