Perl Advent Calendar 2015

One More Thing

2015-12-25T00:00:00Z

Merry Christmas, Happy Holidays, and good tidings to you all. We've concluded the sixteenth annual Perl Advent Calendar in good cheer and good spirits.

Without You This Would Not Be Possible

The Perl Advent Calendar is a team effort, and it wouldn't be possible to produce it without the help from everyone involved. This year thanks are due for the contributions made by Alex Balhatchet, Arthur Axel "fREW" Schmidt, Dave Cross, Dave Rolsky, David Cantrell, David Precious, Graham Ollis, Ivan Kruglov, James Laver, Johann Rolschewski, Marcus Ramberg, Mark Fowler, Masayuki Matsuki, Neil Bowers, Olaf Alders, openstrike, Pete Houston, Paul "LeoNerd" Evans, Ricardo SIGNES, Sergey Romanov, Shoichi Kaji, and Yanick Champoux. Thanks everyone!

And of course, it wouldn't be possible without all the readers enjoying the articles each day, so thanks to you too.

In early February 2016 I'll be starting the whole process over again with a call for participation for the 2016 Perl Advent Calendar. If you're reading then then I'd strongly recommend you write an article, especially if you've not written one before!

The Gift of The CPAN

Advent may be once again over but the CPAN is the gift that keeps on giving, and each year it gets better and better!

Right now as I write this the CPAN has one hundred and fifty eight thousand five hundred and fifty nine modules published to it. That means that - in addition to updates to existing modules - since I wrote this Christmas Day entry last year for the 2014 Advent Calendar sixteen thousand eight hundred and ten new modules have been uploaded, or in other words a growth of nearly 12% in just one year!

To put this in some context, if you took just five minutes to install, examine and play with each of these new modules it'd be nearly the end of February before you were done (If you were to do the same for every module on the CPAN...you'd miss next year's advent calendar totally and you'd finally be done in June 2017!) That is, assuming of course, you didn't stop to sleep or eat or anything else.

This sounds like a lot of work! Where can you find out about all this the lazy way? As always:

You can search for Perl modules at metacpan where you can also see a list of recently published modules
CPAN Ratings offers a ratings and reviews of Perl modules. It's like a democratic advent calendar each day of the year!
The Perl Weekly provides one small succinct email a week with a summary of the interesting things happing in Perl that week, including new modules, interesting articles and upcoming events.
blogs.perl.org hosts a vast number of Perl blogs if you're looking for more articles to read throughout the year. The Perl Ironman Challenge links to a lot more blogs as part of the updating your Perl blog weekly challenge
Of course, if you want more Perl Advent articles, there's always the previous fifteen years of advent calendar to go through. Happy reading!

That One More Thing

This Christmas is the Christmas many in the Perl community have been waiting for: The one where we get a whole new programming language!

Perl 6 is a sister language to Perl 5: Rebuilt from scratch, with exciting refined syntax and capabilities, Perl 6 is designed to appeal to the discerning Perl programmer. It's been under development for many years, but finally this Christmas we're getting all our Christmases at once: The first major release!

You can find out more about Perl 6 over at perl6.org. Heck, they've even got their own advent calendar...

Until next year....Merry Christmas, one and all.

The Perl Powered Christmas Tree

2015-12-24T00:00:00Z

So, you want to run some Christmas tree lights. Not just any lights, but flashy blinky ones. And while you're at it, give them some nice pretty patterns using a few separate chains of lamps. Maybe Perl can help run those patterns?

The Software

It's simple enough of course to define some blinky patterns, perhaps by naming the light chains A to D, and using a sequence of strings to define the patterns of which ones should be on or off:

my @patterns = qw(
&nbsp;&nbsp;&nbsp;AB CD AB CD AB CD AC BD AC BD AC BD BC AD BC AD BC AD ...
);

We could then use this string of patterns to drive the lights in some manner. For example, we could do something simple:

use Time::HiRes 'sleep';

while(1) {
&nbsp;&nbsp;&nbsp;foreach my $pattern ( @patterns ) {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;set_lights( $pattern );
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;sleep 0.5;
&nbsp;&nbsp;&nbsp;}
}

Here we've got a nice simple repeating pattern that just runs all day long. But how might we implement this set_lights() function? We'll have to actually communicate with the outside world somehow; some actual piece of hardware.

Two specific pieces of hardware that could be useful here are the FTDI FT232H (most conveniently on a breakout board, such as the one made by Adafruit) and the Bus Pirate Made by Dangerous Prototypes, available from several places

These two devices are somewhat different in many respects, but both of them may be described as a USB-attached board which has several digital logic IO pins on board. They each support a mode of operation whereby several pins on the board (16 in the FTDI's case, 5 in the Bus Pirate) can be controlled directly by the computer, setting them directly high or low as required by the program. In our case we only need 4 for the light patterns described above so either would be sufficient for our purposes.

The Device::Chip module on CPAN describes an abstraction layer around various mechanisms that might be employed to talk to real hardware. It's still in its early phases yet so it doesn't have too many actual implementations, but it does support these two hardware boards. It exposes in each case an interface called a GPIO adapter (a "General Purpose Input/Output" - the most basic form of digital IO pin control), which allows us to directly control the high or low state of these pins.

Using this module we can obtain a object that represents the GPIO ability of the hardware and use the write_gpios() method on it to set the state of each GPIO pin. As a little technicality, because the Device::Chip distribution uses Future to make it possible to use asynchronously we'll just have to call the get() method on the Future returned by write_gpios() to actually force it to run. We'll also have to make sure to use names of the GPIO pins that the particular device will recognise.

# Convert names of our strings of lights to GPIO pin names on
# the adapter
my %CHAIN_TO_GPIO = (
   # If we're using the FT232H
   A =&gt; &quot;D0&quot;, B =&gt; &quot;D1&quot;, C =&gt; &quot;D2&quot;, D =&gt; &quot;D3&quot;,

   # If we're using the Bus Pirate
   A =&gt; &quot;MISO&quot;, B =&gt; &quot;CS&quot;, C =&gt; &quot;MOSI&quot;, D =&gt; &quot;CLK&quot;,
);

sub set_lights
{
&nbsp;&nbsp;&nbsp;my ( $pattern ) = @_;

   # $pattern says what light chains to turn on; we'll also
&nbsp;&nbsp;&nbsp;# have to turn the others off

&nbsp;&nbsp;&nbsp;my %want_chains = map { $_ =&gt; 0 } qw( A B C D );
&nbsp;&nbsp;&nbsp;$want_chains{$_} = 1 for split //, $pattern;

   # Now convert to the pin names required by Device::Chip
   my %gpios = map { $CHAIN_TO_GPIO{$_} =&gt; $want_chains{$_} }
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;keys %want_chains;

&nbsp;&nbsp;&nbsp;$gpio-&gt;write_gpios( \%gpios )-&gt;get;
}

All we need now to make our program complete is to initialise this $gpio object at the beginning by opening the actual hardware object. This too comes from Device::Chip using the handy utility constructor on the Device::Chip::Adapter class called new_from_description() to first obtain an object representing the hardware adapter itself, and then calling its make_protocol() method to switch it into GPIO mode and obtain an object specifically representing that.

use Device::Chip::Adapter;

my $adapter = Device::Chip::Adapter-&gt;new_from_description(
&nbsp;&nbsp;&nbsp;&quot;FTDI&quot;,  # Or BusPirate, or whatever...
);

my $gpio = $adapter-&gt;make_protocol( &quot;GPIO&quot; )-&gt;get;

The Hardware

Now we've got a method of controlling these digital IO lines from perl we can now consider how to actually attach to the actual light chains to it. These IO lines are only capable of controlling 3.3V or 5V up to about 20mA or so; nowhere near enough for some lights. "Low voltage" lights are likely 12 or 24V, and mains ones will run at either 230V or 110V, depending on local supply.

To do this we'll need some kind of adapting interface between the digital IO line and the light chain. For a low voltage chain of moderate current (such as a string of LEDs) we can probably use a single NPN transistor along with current-limiting resistor on the base:

When the digital IO line is high it drives a current through the transistor (Q1) to ground which allows the transistor to conduct a larger current through the lamp chain, making it light up. When the line is low the base current stops and so the lamp chain goes off.

There's a limit to how much current we can switch using this arrangement though - any transistor acts much like a current multiplier; allowing a collector-emitter current to flow that is some multiple of the base-emitter current (usually of the order of 50 times as much). Because the digital IO line on our controller is probably only capable of 20mA or so, that limits our ability to switch lamps up to about 1A.

To achieve a higher current (perhaps because we have low-voltage incandescent bulbes) we'd likely want to use a pair of transistors in a Darlington arrangement. This arrangement has the effect of multiplying the current up twice - once through each transistor - meaning we could switch a much larger current; maybe up to 10A or so. This should be adequate most low-voltage lamps.

These solutions will only work for low-voltage DC switching, not mains power. For mains-power switching you might consider using a relay, though they tend not to cope so well with faster switching such as required by these kinds of lights. The easiest and safest way to switch a mains-voltage but fairly low-current load is to use an opto-isolated triac. A full discussion of those is probably beyond the scope of this little article, but if you want to read more about that I'd suggest looking up "Arduino isolated triac", or other variants on that theme. Any sort of Arduino-related article is likely to be fairly relevant, being just digital IO switching at 3.3V or 5V; much as you'd get from these control boards presented above.

Escaping the Basement For Christmas

2015-12-23T00:00:00Z

The Christmas Party on the fourth floor of Reynholm Industries was in full swing. It was the party legends would be made of, something that would be talked about around the water cooler for years to come. Anyone who wasn't there was sorely missing out. And right now Roy was certainly missing out.

At his desk in the IT department in the basement, Roy stared at his computer screen in dismay at the endless support requests that kept coming in on Slack. Moss was out at some sort of Countdown related Christmas party, and no-one had seen Richmond since he left for that job as a zoo keeper, leaving his boss Jen the choice between going to the office party or making Roy stay behind and answer support queries...she'd obviously chosen the latter option. And now Roy was forced to endure things like this all evening long:

If only there was some way he could automate all of this so he could go upstairs and join the frivolity?

Slack's API

Slack has a fully featured customer accessible API that is able to do pretty much anything Roy could do in the web client. In addition to a collection of normal HTTP GET / PUT / POST API calls Slack supports a websocket API to allow the program to retrieve and answer messages in real time just like the web client does.

The normal way to use the rtm real time message service is:

Make a standard HTTP GET call to the rtm.start API method to get a unique websocket URL
Connect to that bi-directional websocket URL
Read JSON from / send JSON to that websocket to receive and send messages respectivly

Handling asynchronous programming where your code is both listening and sending messages at the same time used to be complex, but now Perl has a bunch of really good event loop modules that abstract all this away.

One such framework, Mojolicious, has excellent websocket handling right out of the box, supporting all the idiosyncrasies of connecting to the socket, handling the necessary HTTP socket upgrades specified in the protocols, and allows Roy to simply register callbacks that are triggered whenever the server has sent us a complete chunk of JSON down the socket.

Given all of this, it shouldn't be too hard for Roy to use it to write something with it to pretend to be him in Perl:

#!/usr/bin/perl

use 5.022;
use warnings;
use feature qw(signatures);
no warnings qw(experimental::signatures);

use Mojo::UserAgent;

# The per-user token is availble to logged-in users from the slack website
# to authenticate API users as them.  See https://api.slack.com/web
my $TOKEN = 'xoxp-3234159231-8529214522-1345812313-143531';

my $ua = Mojo::UserAgent-&gt;new;

# Use the standard synchronous HTTP API get a websocket URL to connect to
sub rtm_ws_url {
&nbsp;&nbsp;my $tx = $ua-&gt;get('https://slack.com/api/rtm.start' =&gt; form =&gt; { token =&gt; $TOKEN });
&nbsp;&nbsp;my $res = $tx-&gt;success or die &quot;Can't connect!&quot;;
&nbsp;&nbsp;return $res-&gt;json-&gt;{url};
}

# connect to the websocket
sub rtm_start($url) {
&nbsp;&nbsp;my $id = 1;

  # connect to the websocket URL asynchronously and then call callback
  my $tx = $ua-&gt;websocket($url =&gt; sub ($ua, $tx) {
&nbsp;&nbsp;&nbsp;&nbsp;say 'WebSocket handshake failed!' and return unless $tx-&gt;is_websocket;

    # handle JSON messages sent to us from the server
    $tx-&gt;on(json =&gt; sub ($tx,$msg) {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;...
&nbsp;&nbsp;&nbsp;&nbsp;});

    # keep pinging every five seconds to not get disconnected
    Mojo::IOLoop-&gt;recurring(5 =&gt; sub {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$tx-&gt;send({ json =&gt; { id =&gt; $id++, type =&gt; &quot;ping&quot; } });
&nbsp;&nbsp;&nbsp;&nbsp;});
&nbsp;&nbsp;});
}

my $url = rtm_ws_url();
rtm_start( $url );
Mojo::IOLoop-&gt;start unless Mojo::IOLoop-&gt;is_running;

With the basics of connecting to the server (and staying connected by sending a ping every five seconds no matter what) done Roy needed to work out how to handle messages sent from the server. Slack sends all kinds of messages: people leaving or joining channels, ping responses, even notifications that people are starting to type. But in reality there was only one message Roy was interested in...someone starting to chat to him in a private one-on-one chat, presumably seeking support. He decided to script his standard one-line response to the first time anyone ever asked him anything that seemed to solve almost every problem that came his way:

# handle JSON messages sent to us from the server
$tx-&gt;on(json =&gt; sub ($tx,$msg) {
  # ignore anything but actual messages
  return unless $msg-&gt;{type} eq &quot;message&quot;;

  # ignore anything but direct messages
  my $channel = $msg-&gt;{channel};
&nbsp;&nbsp;return unless $channel &amp;&amp; $channel =~ /\AD/;

  # don't speak twice
  state %already_replied;
&nbsp;&nbsp;return if $already_replied{ $channel };
&nbsp;&nbsp;$already_replied{ $channel } = 1;

&nbsp;&nbsp;$tx-&gt;send({ json =&gt; {
&nbsp;&nbsp;&nbsp;&nbsp;id =&gt; $id++,
&nbsp;&nbsp;&nbsp;&nbsp;type =&gt; 'message',
&nbsp;&nbsp;&nbsp;&nbsp;channel =&gt; $channel,
&nbsp;&nbsp;&nbsp;&nbsp;text =&gt; 'Have you tried turning it off and on again?'
&nbsp;&nbsp;}});
});

Roy didn't have to wait long before someone triggered his script:

It worked! Roy ran gleefully upstairs to see if there was any eggnog left.

Hey You $#%! Fix My Computer!

Jen didn't seem to appreciate his clever solution when he bumped into her next to the punch bowl. She thought it would make people very angry. Normally Roy didn't listen to Jen too much, but he had to admit that she might be right about that. Maybe he should have the script let him know if someone was truly upset?

Roy figured if they were swearing at him, he'd better pay attention!

# handle JSON messages sent to us from the server
$tx-&gt;on(json =&gt; sub ($tx,$msg) {
&nbsp;&nbsp;...

&nbsp;&nbsp;use Regexp::Common qw(RE_profanity);
&nbsp;&nbsp;if ($msg-&gt;{text} =~ RE_profanity) {
&nbsp;&nbsp;&nbsp;&nbsp;$tx-&gt;send({ json =&gt; {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;id =&gt; $id++,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;type =&gt; 'message',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;channel =&gt; $channel,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;text =&gt; &quot;Hold on, I'm looking into it&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;}});
&nbsp;&nbsp;&nbsp;&nbsp;notify('CODE RED ROY! YOU NEED TO DEAL WITH THIS!');
&nbsp;&nbsp;&nbsp;&nbsp;return;
&nbsp;&nbsp;}

&nbsp;&nbsp;...
});

Now when the boss man complained, he should be tempoarly soothed while his script could summon him.

All that was needed was some way to notify himself. Of course! The Slack app on his mobile phone could be configured to buzz whenever a particular user - like slackbot, the Slack bot - messaged him. Now all he had to do was lookup the secret slackbot URL for his account on the Slack web pages and make asynchronous posts to that whenever he wanted to notify himself.

my $SLACKBOT_URL =
&nbsp;&nbsp;'https://reynholm-industries.slack.com/services/hooks/slackbot'
&nbsp;&nbsp;&nbsp;. '?token=hWa13Ndj32Ajoz2jnaoqu42X'
&nbsp;&nbsp;&nbsp;. '&amp;channel=%23roytrenneman';

sub notify($message) {
  # send non-blocking post
  my $tx = $ua-&gt;build_tx(POST =&gt; $SLACKBOT_URL =&gt; $message);
&nbsp;&nbsp;$ua-&gt;start($tx =&gt; sub {});
}

If he could just avoid drinking enough to lose his phone all would be great!

Automate Christmas with Ansible and Perl

2015-12-22T00:00:00Z

Ansible is a pretty great way to version control your infrastructure. It has powerful orchestration features that let you execute plays across any number of servers, and it works through SSH, so in most cases no setup is needed on the client. It comes with a wide range of modules that lets you handle most cases out of the box, like template generation for files, comprehensive rsync support, and even more advanced modules like the most common load balancers and network devices.

Sometimes there's a piece in your infrastructure that you just can't handle with the built in modules like shell or get_url. Luckily it's easy to write your own modules, and bundle them with your playbooks. As Ansible is written in Python, it's a common choice, but you can write them in basically anything that can generate a JSON response.

I've written a helper module called AnsibleModule that brings the same convenience to Perl that Ansible provides to Python for writing modules, including input validation, automatic response handling, and fatpacking our module.

Santa Claus inc are heavy users of the Cisco ACE load balancers, which are not supported out of the box in Ansible. During operations they often need to temporarily take one node out of the load balancer to do upgrades, so that every child gets their packages. Let's look at how we can write a module to help us with that.

First, let's install AnsibleModule from CPAN:

  $ cpanm AnsibleModule

Next, let's start the source code of our project. I tend to keep them in the library/ folder of my playbooks repo. Ansible will automatically look there when you're running jobs. Let's make a ace_rserver.pl script now, with the basic code needed:

#!/usr/bin/env perl
use AnsibleModule;

my $module = AnsibleModule-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;argument_spec =&gt; {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;rserver =&gt; { required =&gt; 1 },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;enabled =&gt; { default  =&gt; 'yes' }
&nbsp;&nbsp;&nbsp;&nbsp;}
);
$module-&gt;exit_json( { msg =&gt; 'wheeee' } );

Make sure it's executable, and we can test it with the ansible-perl script shipped with AnsibleModule:

  $ ansible-perl -m library/ace_rserver.pl
  Output from library/ace_rserver.pl: {
    &quot;failed&quot; =&gt; 1,
    &quot;msg&quot; =&gt; &quot;missing required arguments: rserver&quot;
  }
  Response code: 1

Seems that argument validation is working, now let's try again with that argument included

  $ ansible-perl -m library/ace_rserver -a &#39;{&quot;rserver&quot;:&quot;test&quot;}&#39;
  Output from library/ace_rserver.pl: {
    &quot;changed&quot; =&gt; 0,
    &quot;msg&quot; =&gt; &quot;wheeee&quot;
  }
  Response code: 0

Pretty good, but ideally you would like to use this with Ansible as well. Of course modules are uploaded and run remotely on each host, so you need to have any perl module you use available on the remote host. Luckily there's a module called 'App::Fatpacker' that can package up your dependencies into one file. ansible-perl can use this to package up your script for you like this:

  $ ansible-perl -m library/ace_rserver -p
  Wrote library/ace_rserver.packed

And now you can easily run it on a any host with a recent Perl. Lets test it with the ad hoc ansible command:

  $ ansible -i&#39;localhost local_connection,&#39; -m ace_rserver.packed -a &#39;rserver=foo&#39; localhost
  localhost | success &gt;&gt; {
      &quot;changed&quot;: 0,
      &quot;msg&quot;: &quot;wheeee&quot;
  }

Pretty spiffy! Btw, note that you also need to pack it because it includes the WANT_JSON magic keyword in your module. If you want to use it unpacked, you have to include this yourself.

But our Ansible module isn't doing very much useful yet. I already created a quick script to test the https interface of the ACE:

#!/usr/bin/env perl

use Mojo::UserAgent;
use IO::Prompter;

my $passwd = prompt 'Enter your password: ', -echo =&gt; '';

my $ua       = Mojo::UserAgent-&gt;new;
my @commands = (
&nbsp;&nbsp;&nbsp;&nbsp;'conf t', 'rserver host test3', 'ip address 10.10.11.11', 'end',
&nbsp;&nbsp;&nbsp;&nbsp;'show run'
);
my $command = '&lt;request_raw&gt;' . join( &quot;\n&quot;, @commands ) . '&lt;/request_raw&gt;';

my $tx = $ua-&gt;post(
&nbsp;&nbsp;&nbsp;&nbsp;&quot;https://$ENV{USER}:$passwd\@mrom-ip/bin/xml_agent&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;form =&gt; { xml_cmd =&gt; $command }
);
if ( $res = $tx-&gt;success ) {
&nbsp;&nbsp;&nbsp;&nbsp;warn 'Got ' . $res-&gt;body;
}
else {
&nbsp;&nbsp;&nbsp;&nbsp;my $err = $tx-&gt;error;
&nbsp;&nbsp;&nbsp;&nbsp;die &quot;$err-&gt;{code} response: $err-&gt;{message}&quot; if $err-&gt;{code};
&nbsp;&nbsp;&nbsp;&nbsp;die &quot;Connection error: $err-&gt;{message}&quot;;
}

Integrating that into our Ansible module shouldn't be too hard. We need a little different arguments. Also let's turn on support for check mode (if it's not enabled, Docker will just skip this module in check mode.

my $module = AnsibleModule-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;argument_spec =&gt; {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;rserver  =&gt; { required =&gt; 1 },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;enabled  =&gt; { type     =&gt; 'bool', default =&gt; 'yes' },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;ace_host =&gt; { required =&gt; 0 },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;ace_user =&gt; { required =&gt; 1 },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;ace_pass =&gt; { required =&gt; 1 },
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;supports_check_mode =&gt; 1
);

First, let's do a quick sub to run a sequence of raw command and return the output:

sub _ace_command {
&nbsp;&nbsp;&nbsp;&nbsp;my @commands = @_;
&nbsp;&nbsp;&nbsp;&nbsp;my $tx       = $ua-&gt;post(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&quot;https://$ENV{ACE_USER}:$ENV{ACE_PASS}\@ENV{ACE_HOST}/bin/xml_agent&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;form =&gt; {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;xml_cmd =&gt; '&lt;request_raw&gt;'
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;. join( &quot;\n&quot;, @commands )
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;. '&lt;/request_raw&gt;'
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;&nbsp;);
&nbsp;&nbsp;&nbsp;&nbsp;my $res = $tx-&gt;success;
&nbsp;&nbsp;&nbsp;&nbsp;return $res-&gt;dom-&gt;at('xml_show_result')-&gt;text, undef if $res;
&nbsp;&nbsp;&nbsp;&nbsp;return undef, $tx-&gt;err;
}

Sorry about the golang-style error-handling scheme. :) Now we can easily use this to check that our rserver exists:

my ( $res, $err ) = _ace_command(&quot;show run rserver $rserver&quot;);
$module-&gt;fail_json(
&nbsp;&nbsp;&nbsp;&nbsp;msg =&gt; &quot;Could not talk to ACE: $err-&gt;{message} ($err-&gt;{code})&quot; )
&nbsp;&nbsp;&nbsp;&nbsp;if $err;
$module-&gt;fail_json( msg =&gt; &quot;rserver $rserver not found&quot; )
&nbsp;&nbsp;&nbsp;&nbsp;unless $res =~ /rserver host $rserver/;

And then continue to execute the changes specified in the arguments:

if ( $module-&gt;params-&gt;{enabled} ) {
&nbsp;&nbsp;&nbsp;&nbsp;$module-&gt;exit_json( changed =&gt; 0 ) if $res =~ /\binservice\b/;
&nbsp;&nbsp;&nbsp;&nbsp;my ( $res, $err ) = _ace_command(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'conf t', &quot;rserver host $rserver&quot;, 'no inservice',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;' end',   &quot;show run rserver $rserver&quot;
&nbsp;&nbsp;&nbsp;&nbsp;);
&nbsp;&nbsp;&nbsp;&nbsp;$module-&gt;fail_json(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;msg =&gt; &quot;Could not talk to ACE: $err-&gt;{message} ($err-&gt;{code})&quot; )
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;if $err;
&nbsp;&nbsp;&nbsp;&nbsp;$module-&gt;fail_json( msg =&gt; &quot;Could not take $rserver out of service&quot; )
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;if $res =~ /\binservice\b/;
&nbsp;&nbsp;&nbsp;&nbsp;$module-&gt;exit_json( changed =&gt; 1 );
}

Note that AnsibleModule automatically handles trueish/falseish values for your bools in the same fashion as the official Ansible modules. You can just treat them as normal Perlish values. fail_json will automatically stop processing, and return the relevant json struct to Ansible. note the changed value for exit_json; Of course, the else condition is just the reverse of this, I'll leave that as an exercise for you to figure out. We forgot something though. Earlier, we turned on support for check mode in the constructor. To support this, just wrap the ace_command line and error handling in a conditional.

unless ( $module-&gt;check_mode ) {...}

And everything should work as expected. And that should be everything we need. Have fun writing your own Ansible modules, and if you have any trouble or ideas for improvements issues, and especially pull-requests are appreciated at the github repo

The Perl of Christmas Future

2015-12-21T00:00:00Z

Rather being like the fabled Ebenezer Scrooge, staring into his own grave of Christmas Future, Perl 5 is an evolving language giving back to its loved ones every yearly release. Perl 5's Christmas Future is more like the reformed Ebenezer visiting the Cratchit household, giving out the gifts of new core language features to all and sundry.

The majority of these new features aren't available in Perl by default (to preserve backwards compatibility), but can be easily enabled for any section of code by using the feature keyword. Latest releases of perl even ship with many experimental features that give us a glance of Perl-yet-to-come!

Beyond Modern Perl

Here's some old-school code written to work on any Perl:

my $sled;
sub pack_naughty_coal {
&nbsp;&nbsp;&nbsp;my $self = shift;
&nbsp;&nbsp;&nbsp;my $packer = shift;
&nbsp;&nbsp;&nbsp;my $driver = shift || $SANTA;

&nbsp;&nbsp;&nbsp;$sled ||= Sled-&gt;new();

&nbsp;&nbsp;&nbsp;foreach my $person (@{ $self-&gt;naughty_list }) {
      # never load coal for the driver even if they're on the list!
      next if $person-&gt;name =~ /\A\Q$driver\E\z/i;

&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;print STDERR 'Loading coal for ' . $person-&gt;name . &quot;\n&quot;;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$packer-&gt;pack_coal_for($person, $sled);
&nbsp;&nbsp;&nbsp;}

&nbsp;&nbsp;&nbsp;return;
}

By enabling the right features in Perl we can turn the above code into the much more readable futuristic Perl:

sub pack_naughty_coal($self, $packer, $driver = $SANTA) {
&nbsp;&nbsp;&nbsp;state $sled = Sled-&gt;new();

&nbsp;&nbsp;&nbsp;foreach my $person ($self-&gt;naughty_list-&gt;@*) {
      # never load coal for the driver even if they're on the list!
      next if fc $person-&gt;name eq fc $driver;

&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;say STDERR 'Loading coal for ' . $person-&gt;name;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$packer-&gt;pack_coal_for($person,$sled);
&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;return;
}

This uses five of the thirteen optional features available in Perl 5.22

The state feature
The fc feature
The say feature
The signatures feature (still experimental in 5.22)
The postderef feature (still experimental in 5.22)

Enabling Features

New features in Perl can be enabled in your code one of three ways:

By explicitly turning them on

You can explicitly turn on the features you want for lexical scope with the feature pragma.

use feature 'say';
say 'Merry Christmas';

If you use an experimental feature you'll probably want to disable the warnings for that also:

use feature 'signatures';
no warnings 'experimental::signatures';
sub ask_santa_for($wish) {
&nbsp;&nbsp;&nbsp;...
}

Or, preferably, just use the experimental pragma:

use experimental 'signatures';
sub ask_santa_for($wish) {
&nbsp;&nbsp;&nbsp;...
}

However, you should be aware that experimental features are just that - they can change without notice, and if they do...you've got no-one to blame but yourself! The future isn't here yet, after all.

By requiring a version of Perl

Instead of explicitly stating the feature that you want to use, you can enable for the current lexical scope all the non experimental features supported by a particular version of Perl by requiring a particular version of Perl:

use 5.022;
say 'Merry Christmas';

(For 5.12 and later, this will also turn on strict!)

By using -E

Using -E at the command line will turn on all the non-experimental features for the version of Perl that's executing the script:

   perl -E &#39;say &quot;Merry Christmas&quot;;&#39;

Looking At The Experimental Features Used In The Example

These descriptions are accurate as of 5.22, but by the very nature of experimental features the functionality might have changed if you're reading this article in the distant future (Enjoy your flying cars and melted ice caps.)

The 'signature' feature

My favorite feature so far, subroutine signatures, is a feature that allow us to avoid having to write explicit code to extract arguments from @_. Instead, as is common in many other languages, you can simply write an argument list next to the subroutine declaration! This means this:

sub give {
&nbsp;&nbsp;&nbsp;my $person = shift;
&nbsp;&nbsp;&nbsp;my $gift   = shift;
&nbsp;&nbsp;&nbsp;...
}

Can be more compactly written as:

sub give($person,$gift) {
&nbsp;&nbsp;...
}

Under the hood Perl builds the necessary instructions as if we'd written the code to do the argument manipulation and checking ourselves manually. If we deparse the compiled source code we can actually see the equivalent code:

   shell$ perl -Mfeature=signatures -MO=Deparse -e &#39;sub give($person,$gift) { return 1 }&#39;
   The signatures feature is experimental at -e line 1.
   sub give {
       use feature &#39;signatures&#39;;
       die sprintf(&quot;Too many arguments for subroutine at %s line %d.\n&quot;, (caller)[1, 2]) unless @_ &lt;= 2;
       die sprintf(&quot;Too few arguments for subroutine at %s line %d.\n&quot;, (caller)[1, 2]) unless @_ &gt;= 2;
       my $person = $_[0];
       my $gift = $_[1];
       ();
       return 1;
   }

Perl signatures have a bunch of really clever tricks, including being able to use slurpy operators to put a variable number of arguments into an array:

sub prep_sleigh($sled, @reindeer) {
&nbsp;&nbsp;...
}

prep_sleigh(
&nbsp;&nbsp;&quot;BigRed2000&quot;,
&nbsp;&nbsp;&quot;Dasher&quot;,
&nbsp;&nbsp;&quot;Dancer&quot;,
&nbsp;&nbsp;&quot;Prancer&quot;,
&nbsp;&nbsp;&quot;Vixen&quot;,
&nbsp;&nbsp;&quot;Comet&quot;,
&nbsp;&nbsp;&quot;Cupid&quot;,
&nbsp;&nbsp;&quot;Dunder&quot;,
&nbsp;&nbsp;&quot;Blixem&quot;,
);

They also allow you to specify hashes in the argument list (which will error if a non even number of things are passed in):

sub bake_cookies(%args) {
&nbsp;&nbsp;...
}

bake_cookies(
&nbsp;&nbsp;&nbsp;number =&gt; 100,
&nbsp;&nbsp;&nbsp;type =&gt; &quot;chocolate&quot;,
&nbsp;&nbsp;&nbsp;icing =&gt; 1,
);

Subroutine signatures allow you to use placeholder unnamed arguments that you want to allow to be passed in without error but don't actually want to do anything with (I find this very handy when writing methods / callbacks being called from code you didn't write that may be updated to have extra arguments later)

my $delivery_callback = sub($address, $status, @) {
&nbsp;&nbsp;&nbsp;if ($status) {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;say $log &quot;Presents delivered to $address\n&quot;;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return;
&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;say $log &quot;WARNING: Presents could not be delivered to $address&quot;;
};

One of the most advanced features currently supported is default values; If the argument isn't passed then the default is used:

sub leave_food_for_santa($where, $what = $MINCE_PIES) {
&nbsp;&nbsp;&nbsp;...
}

You can even put arbitrary code in there to do whatever you want, for example picking a default at random:

sub leave_food_for_santa($where, $what = rand() &gt; 0.5 ? $MINCE_PIES : $XMAS_PUDDING) {
&nbsp;&nbsp;&nbsp;...
}

Postfix Dereferencing, the `postderef` feature

The standard @{ ... } array dereferencing syntax surrounds the array reference that it dereferences. This works pretty well for small values:

my $arrayref = [];
my @array = @{ $arrayref };

Or even for slightly more complex things:

foreach my $thingy (@{ $self-&gt;thingy_that_returns_an_arrayref }) {
&nbsp;&nbsp;...
}

But it can get pretty darn hairy where the thing you're surrounding gets very long.

my @shows = @{
&nbsp;&nbsp;TV::Schedule
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;new
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;filter( subscribed =&gt; 1 )
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;search( show =&gt; &quot;My Little Pony: Friendship is Magic&quot;)
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;type(&quot;Christmas Special&quot;)
};

By the time you get down to reading the closing } you've forgotten what it was for! This can be written a lot clearer with the @* array dereferencing syntax.

my @shows = TV::Schedule
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;new
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;filter( subscribed =&gt; 1 )
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;search( show =&gt; &quot;My Little Pony: Friendship is Magic&quot;)
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;type(&quot;Christmas Special&quot;)
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;@*;

You can also do something similar with hashrefs! Instead of writing:

sub drive_deer($self) {
&nbsp;&nbsp;say &quot;On $_!&quot; for sort keys %{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;sled
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;deer_team
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;details_hashrefs
&nbsp;&nbsp;};
}

You can simply write:

sub drive_deer($self) {
&nbsp;&nbsp;say &quot;On $_!&quot; for sort keys 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;sled
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;deer_team
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;details_hashrefs
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;%*;
}

If you want to use postfix dereferencing in a double-quoted string, you should also use the postderef_qq feature:

say &quot;All my present: $gifts_for{me}-&gt;@*&quot;;

Both of these get turned on by use experimental 'postderef', and they'll be out of experimental status in the upcoming v5.24.0 release!

Standard Features Used In The Example

I also took advantage of a bunch of non-experimental features in Perl. If you're writing Perl code for a known version of Perl, you pretty much should be using these as default now.

The `say` Feature

Available since Perl 5.10, the say keyword is equivalent to the print keyword with a newline automatically appended. Thus instead of writing:

print STDERR 'Loading coal for ' . $kid-&gt;name . &quot;\n&quot;;

We can just write:

say STDERR 'Loading coal for ' . $kid-&gt;name;

The `state` Feature

The state feature introduces a new keyword to declare, state, that works just like a my except the code on the right hand side of the expression is only evaluated the first time the line is executed and the variable maintains state every time you re-enter that lexical scope.

The upshot of this is that things like locally-scoped long-lived variables like counters just got a lot easier to write:

{
&nbsp;&nbsp;&nbsp;my $counter = 0;
&nbsp;&nbsp;&nbsp;sub id {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$counter++;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return $counter;
&nbsp;&nbsp;&nbsp;}
}

Can be simply rewritten without those annoying extra curly braces:

sub id {
&nbsp;&nbsp;state $counter = 0;
&nbsp;&nbsp;$counter++;
&nbsp;&nbsp;return $counter;
}

The `fc` Feature

Doing proper case insensitive comparison of strings is...hard. Sure, it's easy when you're only worrying about ASCII characters, but for more advanced character sets where round tripping doesn't work, you can't just always uc or lc the strings.

# for the kelvin / K characters only lc works
lc(&quot;\x{212A}&quot;) eq lc(&quot;K&quot;);  # true!
uc(&quot;\x{212A}&quot;) eq uc(&quot;K&quot;);  # false!

# for sigma / sigma characters only uc works
lc(&quot;\x{03C2}&quot;) eq lc(&quot;\x{03C3}&quot;);  # false!
uc(&quot;\x{03C2}&quot;) eq uc(&quot;\x{03C3}&quot;);  # true!

Rather than a lower case or upper case operator we need a folding case operator that gives us something we can use to compare to see if the strings really are the same case-insensitively. And that operator? It's fc:

fc(&quot;\x{212A}&quot;) eq fc(&quot;K&quot;);         # true!
fc(&quot;\x{03C2}&quot;) eq fc(&quot;\x{03C3}&quot;);  # true!

In Conclusion

Perl is an evolving language. With the feature keyword we're able to bring new standards to scripts while at the same time not requiring that old code be changed to work with the changes if we don't want it to. With experimental features we're all able to experiment with cool features in our code today before we make them part of the standard, to become familiar with all the benefits and work out (and hopefully address) the problems before it's set in stone.

Speaking from personal experience as someone who recklessly uses all the features I've described today while developing production code (including the experimental ones) I've found that these little changes add up to make a very big difference in the feel of your code, and greatly improve the development experience. It truly is the Perl of the future.

Perl and Redis

2015-12-20T00:00:00Z

Redis is high performance in memory key-value-store and data structure server. It runs as a simple daemon alongside your Perl code that you can talk to over the network sending data back and forward for it to persist between invocations and between processes.

We find that it has affinity with the way we write our application code: We can use Redis variables and data structures as super global variables that are not only accessible from everywhere in a Perl script but from every process on every server in our infrastructure every time they run. It is very useful and powerful (and dangerous :p).

These global variables have lots of use, from a simple shared cache, to things like global work queues, process synchronization, or shared leader boards.

    shell$ redis-cli ping
    PONG
    shell$ redis-cli set snowman frosty
    OK
    shell$ redis-cli get snowman
    &quot;frosty&quot;
    shell$ redis-cli lpush gifts gold
    (integer) 1
    shell$ redis-cli lpush gifts frankincense
    (integer) 2
    shell$ redis-cli lpush gifts myrrh
    (integer) 3
    shell$ redis-cli lpop gifts
    &quot;myrrh&quot;
    shell$ redis-cli lpop gifts
    &quot;frankincense&quot;
    shell$ redis-cli lpop gifts
    &quot;gold&quot;
    shell$ redis-cli lpop gifts
    (nil)
    shell$

Redis's documentation is very full and we can try the commands in interactive console in a web browser!

Let's introduce the CPAN modules around Redis.

Redis

The original Redis module is a Perl interface to talk to a Redis server:

my $redis = Redis-&gt;new;
$redis-&gt;incr('blah');

Redis.pm is pure Perl implementation so, stable and easy to understand, but a little bit slow, especially for caching where you don't want a lot of overhead.

Redis::Fast

Redis::Fast is an alternative faster client module for Redis. It has the same Redis.pm interfaces built using XS, so "Fast". You can use Redis::Fast instead of Redis.pm without making any code changes other than initially instantiating a different object.

my $redis = Redis::Fast-&gt;new;
$redis-&gt;incr('blah');

In my work (online games, SNS and so on), Redis::Fast is also stable and very fast.

Cache::Redis

Cache::Cache is a standard caching interface while allows you to easily swap out backend caching technologies - in memory stores, on disk files, memcache, etc - without making changes to your code.

I wanted to use Redis as caching storage so I wrote a Cache::Cache compatible interface client library for Redis called Cache::Redis:

my $redis = Redis::Fast-&gt;new; # you can use Redis.pm too.
my $cache = Cache::Redis-&gt;new(redis =&gt; $redis);
$cache-&gt;set(blah =&gt; 1);
say $cache-&gt;get('blah'); # 1

Redis also has an interface, CHI::Driver::Redis, to the CHI caching framework.

Redis::LeaderBoard

Redis not only allows you to store simple key/value pairs on the server, but has a rich API that allows you to manipulate more complex data structures that it can store.

Redis's "sorted set" is very useful for creating leaderboards but, which don't return "unique" rank (cf. https://github.com/antirez/redis/issues/943>). So I wrote the ranking module using Redis which takes care of "unique" rank.

use Redis::Fast;
use Redis::LeaderBoard;
my $redis = Redis::Fast-&gt;new;
my $lb = Redis::LeaderBoard-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;redis =&gt; $redis,
&nbsp;&nbsp;&nbsp;&nbsp;key   =&gt; 'leader_board:1',
&nbsp;&nbsp;&nbsp;&nbsp;order =&gt; 'asc', # asc/desc, desc as default
);
$lb-&gt;set_score(one =&gt; 100);
$lb-&gt;set_score(two =&gt;  50);
my ($rank, $score) = $lb-&gt;get_rank_with_score('one'); #=&gt; (1, 100)

I introduce a technique. That is "using epoch as score".

my $lb = Redis::LeaderBoard-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;redis =&gt; $redis,
&nbsp;&nbsp;&nbsp;&nbsp;key   =&gt; 'recent_post',
&nbsp;&nbsp;&nbsp;&nbsp;limit =&gt; 20,
);
$lb-&gt;set_score($url, $updated-&gt;epoch);
...
# you can get recent posts up to 20 entries
my $recent_posts = $lb-&gt;rankings;

Redis::Namespace

Generally, key management of a key-value-store is very difficult and confusing (easy to conflict with existing keys used elsewhere in code or other applications using the same Redis server, typo and so on). Key-value-store is very cool, but with this "super global variables store" we must appropriately manage the keys.

We can use Redis::Namespace for better key name management.

my $redis = Redis::Fast-&gt;new;
my $ns = Redis::Namespace-&gt;new(redis =&gt; $redis, namespace =&gt; 'ranking');
$ns-&gt;set(foo =&gt; 'bar');    # will call $redis-&gt;set('fugu:foo', 'bar');
my $foo = $ns-&gt;get('foo'); # will call $redis-&gt;get('fugu:foo');

The object of Redis::Namespace is to fill up the prefix namespace automatically. I recommend the all Redis objects are wrapped by Redis::Namespace.

Conclusion

CPAN's Redis modules allow you to quickly, easily, and safely leverage the power of Redis from Perl.

Santa Sorts By Example

2015-12-19T00:00:00Z

For years Santa has resisted the urge to purchase a self-driving sleigh, but the figures published by recent studies have finally convinced him that an autonomous sled might be safer than one being driven by a man who has been up for 24 hours straight. Plus, his also allows him to update this Facebook status without having to worry about colliding with other air traffic.

Most of the (literal) bells and whistles on the sleigh come pre-configured. The only thing Santa really has to worry about is the order in which his reindeer will line up before the sleigh takes off. (Keep in mind, this sleigh may be self driving, but it's not electric).

For years Santa has called out to his reindeer in a very specific order. Perhaps you're familiar with it? Let's just confirm the setup. Rudolph (a 20th century addition to the team) leads and lights the way. After that it's: Dasher, Dancer, Prancer, Vixen, Comet, Cupid, Donner and Blitzen. There's some argument over the spelling of the last two names. If in doubt, refer to Wikipedia.

If any of these reindeer were to take sick, the stand-in reindeer would have to move to the back of the line. After all, if you've been doing this for over a century, seniority certainly enters into the picture. In order to ensure that the reindeer are guided in the correct order by the self-driving sleigh, Santa reaches into his bag of tricks and scripts up a little something in Perl. It looks a little like this:

#!/usr/bin/env perl;

use strict;
use warnings;

use Data::Printer;
use Sort::ByExample qw( sbe );

my @example = (
&nbsp;&nbsp;&nbsp;&nbsp;'Rudolph', 'Dasher', 'Dancer',
&nbsp;&nbsp;&nbsp;&nbsp;'Prancer', 'Vixen', 'Comet',
&nbsp;&nbsp;&nbsp;&nbsp;'Cupid',   'Donner', 'Blitzen',
);
my $sorter = sbe( \@example );

my @current_lineup = (
&nbsp;&nbsp;&nbsp;&nbsp;'Dave',   'Shirley', 'Bubba',
&nbsp;&nbsp;&nbsp;&nbsp;'Rudolph', 'Vixen', 'Dasher',
&nbsp;&nbsp;&nbsp;&nbsp;'Donner', 'Zeke',    'Audrey',
);

my @sorted = $sorter-&gt;( @current_lineup );

print np( @sorted );

This yields the following output:

[
&nbsp;&nbsp;&nbsp;&nbsp;[0] &quot;Rudolph&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[1] &quot;Dasher&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[2] &quot;Vixen&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[3] &quot;Donner&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[4] &quot;Dave&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[5] &quot;Shirley&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[6] &quot;Bubba&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[7] &quot;Zeke&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[8] &quot;Audrey&quot;,
]

Looking at the output we can see that:

Santa's reindeer appear first in the list, sorted according to seniority
Our stand-in reindeer follow in the list, exactly in the order in which they were added to the original list

So far, so good. Now let's introduce some secondary sorting. Right now the stand-ins are appearing in the order in which they were originally provided. Let's sort them alphabetically.

#!/usr/bin/env perl;

use strict;
use warnings;

use Data::Printer;
use Sort::ByExample qw( sbe );

my @example = (
&nbsp;&nbsp;&nbsp;&nbsp;'Rudolph', 'Dasher', 'Dancer',
&nbsp;&nbsp;&nbsp;&nbsp;'Prancer', 'Vixen', 'Comet',
&nbsp;&nbsp;&nbsp;&nbsp;'Cupid',   'Donner', 'Blitzen',
);

my $fallback = sub {
&nbsp;&nbsp;&nbsp;&nbsp;my ( $name_a, $name_b ) = @_;
&nbsp;&nbsp;&nbsp;&nbsp;return $name_a cmp $name_b;
};

my $sorter = sbe( \@example, { fallback =&gt; $fallback } );

my @current_lineup = (
&nbsp;&nbsp;&nbsp;&nbsp;'Dave',   'Shirley', 'Bubba',
&nbsp;&nbsp;&nbsp;&nbsp;'Rudolph', 'Vixen', 'Dasher',
&nbsp;&nbsp;&nbsp;&nbsp;'Donner', 'Zeke',    'Audrey',
);

my @sorted = $sorter-&gt;( @current_lineup );

print np( @sorted );

This yields:

[
&nbsp;&nbsp;&nbsp;&nbsp;[0] &quot;Rudolph&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[1] &quot;Dasher&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[2] &quot;Vixen&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[3] &quot;Donner&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[4] &quot;Audrey&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[5] &quot;Bubba&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[6] &quot;Dave&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[7] &quot;Shirley&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;[8] &quot;Zeke&quot;,
]

All we've done here is add a very simple fallback subroutine, which dictates a sort order for any scalars which do not appear in the example list.

Notice that the order of the first four reindeer has not changed, but our stand- ins are now sorted, as we hoped they would be.

Alphabetical order is kind of arbitrary. What if we wanted to perform the secondary sort according to something more meaningful, like seniority?

#!/usr/bin/env perl;

use strict;
use warnings;

use Data::Printer;
use Sort::ByExample qw( sbe );

my @example = (
&nbsp;&nbsp;&nbsp;&nbsp;'Rudolph', 'Dasher', 'Dancer',
&nbsp;&nbsp;&nbsp;&nbsp;'Prancer', 'Vixen', 'Comet',
&nbsp;&nbsp;&nbsp;&nbsp;'Cupid',   'Donner', 'Blitzen',
);
my $fallback = sub {
&nbsp;&nbsp;&nbsp;&nbsp;my ( undef, undef, $ref_a, $ref_b ) = @_;
&nbsp;&nbsp;&nbsp;&nbsp;return $ref_b-&gt;{seniority} &lt;=&gt; $ref_a-&gt;{seniority};
};

my $sorter = sbe(
&nbsp;&nbsp;&nbsp;&nbsp;\@example,
&nbsp;&nbsp;&nbsp;&nbsp;{   fallback =&gt; $fallback,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;xform    =&gt; sub { $_[0]-&gt;{name} },
&nbsp;&nbsp;&nbsp;&nbsp;}
);

my @current_lineup = (
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Dave',    seniority =&gt; 1 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Shirley', seniority =&gt; 2 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Bubba',   seniority =&gt; 0 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Rudolph', seniority =&gt; 100 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Vixen',   seniority =&gt; 100 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Dasher',  seniority =&gt; 100 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Donner',  seniority =&gt; 150 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Zeke',    seniority =&gt; 44 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Audrey',  seniority =&gt; 44 },
);

my @sorted = $sorter-&gt;( @current_lineup );

print np( @sorted );

This yields:

[
&nbsp;&nbsp;&nbsp;&nbsp;[0] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Rudolph&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 100,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[1] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Dasher&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 100,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[2] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Vixen&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 100,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[3] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Donner&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 150,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[4] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Zeke&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 44,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[5] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Audrey&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 44,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[6] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Shirley&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 2,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[7] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Dave&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[8] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Bubba&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 0,
&nbsp;&nbsp;&nbsp;&nbsp;},
]

What we've done here is moved from an array of scalars to an array of hash references, which allows us to use more reindeer metadata. In addition to having a fallback subroutine, we now also have a xform subroutine. All that xform does is tell us how to extract the keys which might appear in the @example array.

In addition to this, we've now made our fallback enforce seniority, from highest to lowest.

Now, what should we do if there's a tie in seniority, as in the case of Zeke and Audrey? Let's fall back to alphabetical order in that case.

That leaves us with:

#!/usr/bin/env perl;

use strict;
use warnings;

use Data::Printer;
use Sort::ByExample qw( sbe );

my @example = (
&nbsp;&nbsp;&nbsp;&nbsp;'Rudolph', 'Dasher', 'Dancer',
&nbsp;&nbsp;&nbsp;&nbsp;'Prancer', 'Vixen', 'Comet',
&nbsp;&nbsp;&nbsp;&nbsp;'Cupid',   'Donner', 'Blitzen',
);
my $fallback = sub {
&nbsp;&nbsp;&nbsp;&nbsp;my ( $name_a, $name_b, $ref_a, $ref_b ) = @_;
&nbsp;&nbsp;&nbsp;&nbsp;return $ref_b-&gt;{seniority} &lt;=&gt; $ref_a-&gt;{seniority}
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;|| $name_a cmp $name_b;
};

my $sorter = sbe(
&nbsp;&nbsp;&nbsp;&nbsp;\@example,
&nbsp;&nbsp;&nbsp;&nbsp;{   fallback =&gt; $fallback,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;xform    =&gt; sub { $_[0]-&gt;{name} },
&nbsp;&nbsp;&nbsp;&nbsp;}
);

my @current_lineup = (
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Dave',    seniority =&gt; 1 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Shirley', seniority =&gt; 2 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Bubba',   seniority =&gt; 0 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Rudolph', seniority =&gt; 100 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Vixen',   seniority =&gt; 100 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Dasher',  seniority =&gt; 100 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Donner',  seniority =&gt; 150 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Zeke',    seniority =&gt; 44 },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Audrey',  seniority =&gt; 44 },
);

my @sorted = $sorter-&gt;( @current_lineup );

print np( @sorted );

Which yields:

[
&nbsp;&nbsp;&nbsp;&nbsp;[0] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Rudolph&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 100,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[1] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Dasher&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 100,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[2] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Vixen&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 100,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[3] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Donner&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 150,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[4] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Audrey&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 44,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[5] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Zeke&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 44,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[6] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Shirley&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 2,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[7] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Dave&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;[8] {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name      =&gt; &quot;Bubba&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;seniority =&gt; 0,
&nbsp;&nbsp;&nbsp;&nbsp;},
]

Now in the case of Zeke and Audrey, the tiebreaker kicks in and we've got a tertiary sort order.

That's it. Now Santa can relax. His reindeer will be queued up in the correct order and his self-driving sleigh will rest assured that it has the correct order in which to call out their names.

Now, as Santa sits back and enjoys the ride, he thinks of other ways in which he can impose arbitrarily complex sort orders. Perhaps the naughty and nice list is the next logical place?

Christmas Wishes

2015-12-18T00:00:00Z

One of the problems with Santa's delivering presents to all the girls and boys in the world was that when he arrived at midnight in New Zealand to deliver presents to all the good girls and boys, it was twenty three and three quarter hours earlier in Honolulu, barely even Christmas Eve and all the boys and girls there were still making their last minute requests!

The elves had compensated somewhat by putting extra gifts in Santa's magic sack of infinite holding, but updating the gift list in real time to tell Santa what everyone wanted was becoming a serious problem: The sat-phone could only transmit so much data, and Santa was getting tired of flying around aimlessly while he waited for the download to complete.

The Problem With JSON

Here's an example update to the gift list the elves needed to send to Santa:

my $updates = [
&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;id =&gt; '79ABF5D8-9A75-4263-8F8F-A2346EDA62F7',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;wants =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'iPad Pro',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'Modern Perl 4th Edition',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;id =&gt; '7593A066-3C83-4A9C-8A43-4F09D8693B15',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;wants =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'Pokemon Alpha-Sapphire',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'Modeling Clay',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;id =&gt; '2A94FFDB-9FAB-440D-8C2A-D7ED40F30557',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;wants =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'My Two Front Teeth',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;},
}

Traditionally the elves had been encoding this out with JSON to shoot over the wire.

use JSON::PP;
my $bytes = encode_json $updates;
say length($bytes) . ' bytes';

This prints 268 bytes. Not so bad, but can the elves do better?

Introducing Sereal

Sereal is an efficient, compact-output, binary and feature-rich serialization protocol. In other words it's a standard for bundling up a data structure really small to send over the wire, and is just what the Elves are looking for!

Compression

Sereal has built in compression. Snappy compression should be enough in most situations:

use Sereal::Encoder qw(encode_sereal SRL_SNAPPY);

my $bytes = encode_sereal(
&nbsp;&nbsp;&nbsp;$updates,
&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;compress =&gt; SRL_SNAPPY,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;compress_threshold =&gt; 0
&nbsp;&nbsp;&nbsp;}
);

say length($bytes) . ' bytes';

This prints out the much improved 233 bytes. For better compression we can use Zlib (which is more CPU intensive, but right now the elves need every byte they can get)

use Sereal::Encoder qw(encode_sereal SRL_ZLIB);

my $bytes = encode_sereal(
&nbsp;&nbsp;&nbsp;$updates,
&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;compress =&gt; SRL_ZLIB,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;compress_threshold =&gt; 0
&nbsp;&nbsp;&nbsp;}
);

say length($bytes) . ' bytes';

This code prints out the even more improved 205 bytes. Looking at this on a graph we can see we've saved just short of quarter of the byte count over using plain old JSON:

Scaling Up For More Impressive Results

The elves were concerned about how Sereal would behave when scaling up the size of the data that was being sent - there are a lot of children in the world after all. They decided to re-run the test with a bigger data set. Being thankful to all the CPAN authors in the world Santa decided to give each and every one either new copy of the Modern Perl 4th Edition book or a Round Tuit token:

my $updates = [
&nbsp;&nbsp;&nbsp;map {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;+{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;id =&gt; $_,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;wants =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;rand &gt; 0.5 ? 'Modern Perl 4th Edition' : 'A Round Tuit'
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;]
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;} (
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'E113BD23-E72A-4EC0-A57C-C4E868D9049C',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'7F1AAB0C-4B85-4B42-9C8D-A41C6CF9D93E',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;... # and 12483 other uuids
&nbsp;&nbsp;&nbsp;)
];

Rerunning the above tests produced an even more impressive savings:

The elves had reduced the byte count by almost 94%!

Even More Compression

One of the elves decided to investigate ways to make the data that had to be sent even smaller. Noticing that many of the last minute present requests were for this year's hot new toy, the elf suggested that the data structure have some short cut code to avoid having to repeat the same string name of the toy over and over again in the data that was sent over the wire.

Luckily for him, one of the other elves were paying close attention and before he got to work it was pointed out that Sereal can be configured to do this automatically for you!

The elves tried rerunning the CPAN authors data with the dedupe_strings option enabled:

my $bytes = encode_sereal(
&nbsp;&nbsp;&nbsp;$updates,
&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;compress =&gt; SRL_ZLIB,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;dedupe_strings =&gt; 1,
&nbsp;&nbsp;&nbsp;}
);

This resulted in even smaller bytesize

dedupe_strings	Bytes
disabled	60207
enabled	58537

Success

This year not only would the gift list update quicker, Santa's phone bill would also be considerably less!

No More Leaking Glue

2015-12-17T00:00:00Z

Perl is often used as a "glue language". You have a bunch of other programs that you want to automate from one place, so you use Perl. You put the programs carefully in position, grab the bottle of Krazy Glue, drizzle it everywhere, and bask in the glow of what you've accomplished.

Only then, inevitably, you can't put down the glue bottle. It's not that you've gone mad with a need to automate all the things - although that's a possibility, too. This time, though, you've glued the glue bottle to your hand, and no matter what those people on the GlueGaffes subreddit tell you, the only way to get that bottle off your hands is to become some sort of snake monster and shed your skin. This, presumably, is how Python programmers come to be.

Well, the abstraction leak in our Perl glue layer might not be so bad, but it's still a big annoyance. It's all those places where Perl reminds you, "Hey! Hey! Lots of me is just a little wrapper around C library stuff!" Isn't that great? This is why you end up with stat returning a thirteen element list, for example. (Wait, the Perl Advent Calendar has never featured an article on File::stat? Well, check it out later, because that's not the problem we're talking about right now.)

Right now the problem we're talking about is running subprocesses. There are a number of ways to do this; You might use system. You might use open. You might use fork. They all have one thing in common: when the process you started via those means exits, you get its exit status in the same place: $?

$? (known by devotees of the Way of the Dog as $CHILD_STATUS) is a global variable that gets populated with the numeric status of the ex-process. It's supposed to be easy to remember $? because it's the same name as in shell programming...but in the shell, $? is the exit value of the program. If a program exits 75, then $? is 75. In Perl, that would be 19200...and now you just glued your finger to the keyboard.

Perl is leaking the way that status code is packed into the status integer in C: eight bits of exit value, seven bits of signal identifier, and one bit to flag whether the process dumped core. Instead of giving you three variables, you get one number between 0 and 65535. Great!

In C, there are macros for getting the data you wanted.

exit_status = WEXITSTATUS(status);
signal      = WTERMSIG(status);
exit_status = WCOREDUMP(status);

In Perl, you typically find people using bit-shift operators to extract the part of the return code they care about:

return unless system($some_command);
die sprintf &quot;program exited %i&quot;, $? &lt;&lt; 8;

...which the hardened Perl programmer tends to recognize at a glance (and doesn't even notice how ridiculous it is to type this all the time).

Speaking of things even we Perl veterans fail to notice: When the code accidentally uses << instead of >>. Ooops. Did you notice I should have actually written the above code as:

return unless system($some_command);
die sprintf &quot;program exited %i&quot;, $? &gt;&gt; 8;

But that's the problem when you're using non-obvious syntax. It's non-obvious! And even when someone does a proper code review they don't catch that kind of thing.

We also also probably don't catch the situations where we might care about the signal but then we totally forget to check or print it in our code. Why did we fail to do that? Maybe because it was more work, and maybe because we have a quota of one bitwise operation allowed per Perl program per day and we hit it with the first one.

Of course, we can eliminate these stupid errors with everyone's favorite core module... POSIX!

# ARGH MY EYES
use POSIX qw(WEXITSTATUS);

return unless system($some_command);
die sprintf &quot;program exited %i&quot;, WEXITSTATUS($?);

Ha ha just kidding. I mean, you could do that, but then you'd be using POSIX.pm, and you'd have to hold down the shift keys a whole lot when typing, and you'd have to remember to add that code for signals! Also, seriously, POSIX.pm.

This is why Process::Status exists. It's such a useful module that Ruby stole it from us, then travelled back in time 15 years to make it look like they wrote it first.

use Process::Status;

system($some_command);
Process::Status-&gt;assert_ok;

If your program exited 0, nothing happens. If it exited non-zero, you get an exception like:

  program exited 13, caught SIGWOOP; dumped core at line...

There are a bunch of other useful methods for finer-grained handling, but for the most part the only three you need to know are self-explanatory:

as_string
assert_ok
is_success

If you ever run subprocesses from Perl, use Process::Status.

If you don't ever run subprocesses from Perl, I don't even understand your life.

Building Santa's Naughty and Nice List with Stepford

2015-12-16T00:00:00Z

It's a little known fact that Santa's elves are the ones responsible for producing his yearly naughty and nice list. But working on the list has been taking up time that they'd rather use for drinking pine juice and playing Dark Souls. They have a crufty Makefile but it doesn't do a great job of rebuilding things when dependencies change, so they're constantly finding output errors and having to delete old files. It also doesn't play all that nicely with the Perl code they wrote to do the real work.

So the elves pooled their money and hired me to automate building the list. Looking at how they'd built the list before, I realized that Stepford was the perfect tool for the job!

What is Stepford?

Stepford is a tool that takes a set of steps (tasks), figures out their dependencies, and then runs them in the right order to get the result that you ask for. The result itself is just another step that you specify when creating the Stepford::Runner object. Steps are Perl classes built using Moose.

Dependencies and Productions

The "big thing" that Stepford does for you is to figure out the dependencies needed to get to the final step. It does this by looking at the dependencies and productions of all your steps and then running those steps in the necessary order.

Both dependencies and productions are declared as Moose attributes with a special trait. Here's an example:

has geolite2_database_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits   =&gt; ['StepDependency'],
&nbsp;&nbsp;&nbsp;&nbsp;is       =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa      =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;required =&gt; 1,
);

has ip_scores_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits  =&gt; ['StepProduction'],
&nbsp;&nbsp;&nbsp;&nbsp;is      =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa     =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;lazy    =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;builder =&gt; '_build_ip_scores_file',
);

You'll see how to actually populate the ip_scores_file later.

Stepford matches a production to a dependency solely by name, which means that attribute names for productions and dependencies must be unique to a given set of steps.

Step Classes

A "Step class" is any Moose class which consumes the Stepford::Role::Step role (or another role which in turn consumes that role). This role in turn requires that a step class implement a few specific methods named run and last_run_time. You'll see examples of both of these methods as we go further.

What Goes Into the Naughty and Nice List?

The elves gave me a long list of requirements, but honestly it all seemed like too much trouble. And since these elves are not very technically savvy, I'm going to take the easy route instead and just make some stuff up.

Here's what I'm going to do:

Get the names and IP addresses for all the children in the world, or at least a few of them.
Assign each child a UUID so I can track them easily.
Download the free GeoLite2 database from MaxMind.
Use the GeoLite2 database to look at each child's geographical location and use that to give their IP a naughty/nice score. This will be very scientific.
Look at each child's name and use that to give their name a naughty/nice score. Again, this will be very scientific.
Combine the IP and name scores into a single score per child and generate a text file with the naughty/nice list.

Here's a graph of each step showing each steps' dependencies:

Looking at this graph, you can see a couple interesting things. First, there are two steps, "Get list of children" and "Download GeoLite2 databases", with no dependencies. Next, there are steps that are dependencies for more than one other steps, "Assign UUIDs" and "Get list of children". Finally, the "Combine scores" step has three dependencies but is not a dependency of any other step.

Figuring all this stuff out is what Stepford is for. In fact, it calculates a graph just like this internally.

Building our First Step

Let's start by building the step to "Get list of children". All the step classes for a single set of steps should live under the same namespace. I'm going to use NN::Step as our namespace prefix.

package NN::Step::Children;

use strict;
use warnings;
use autodie;
use experimental 'signatures';

use Data::GUID;
use MooseX::Types::Path::Class qw( Dir File );
use Text::CSV_XS;

use Moose;

with 'Stepford::Role::Step::FileGenerator';

no warnings 'experimental::signatures';

has root_dir =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;is      =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa     =&gt; Dir,
&nbsp;&nbsp;&nbsp;&nbsp;coerce  =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;default =&gt; '.',
);

has children_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits  =&gt; ['StepProduction'],
&nbsp;&nbsp;&nbsp;&nbsp;is      =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa     =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;lazy    =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;builder =&gt; '_build_children_file',
);

sub run ($self) {
&nbsp;&nbsp;&nbsp;&nbsp;my $file = $self-&gt;children_file;

&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;logger-&gt;info(&quot;Writing names and IPs to $file&quot;);

&nbsp;&nbsp;&nbsp;&nbsp;my $data = do {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;local $/;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;DATA&gt;;
&nbsp;&nbsp;&nbsp;&nbsp;};

    # CSV line ending per http://tools.ietf.org/html/rfc4180
    $data =~ s/\n/\r\n/g;
&nbsp;&nbsp;&nbsp;&nbsp;$file-&gt;spew($data);
}

sub _build_children_file ($self) {
&nbsp;&nbsp;&nbsp;&nbsp;return $self-&gt;root_dir-&gt;file('children.csv');
}

__PACKAGE__-&gt;meta-&gt;make_immutable;

1;

__DATA__
&quot;Alexander Marer&quot;,42.235.92.147
&quot;Andrew Bernard Cray&quot;,205.145.143.62
...

Let's look at the interesting bits more closely.

with 'Stepford::Role::Step::FileGenerator';

All Stepford classes must consume one of the Step roles provided by Stepford. This particular role tells Stepford that all of this step's outputs are in the form of files. This lets Stepford calculate the step's last run time by looking at the file's modification time. For non-file steps, you have to provide a last_run_time method of your own.

has root_dir =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;is      =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa     =&gt; Dir,
&nbsp;&nbsp;&nbsp;&nbsp;coerce  =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;default =&gt; '.',
);

has children_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits  =&gt; ['StepProduction'],
&nbsp;&nbsp;&nbsp;&nbsp;is      =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa     =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;lazy    =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;builder =&gt; '_build_children_file',
);

This class has two attributes. The root_dir attribute is neither a dependency nor a production. You'll see how to set this attribute later on. The children_file attribute is a production. Some other steps will depend on this production.

sub run ($self) {
&nbsp;&nbsp;&nbsp;&nbsp;my $file = $self-&gt;children_file;

&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;logger-&gt;info(&quot;Writing names and IPs to $file&quot;);

&nbsp;&nbsp;&nbsp;&nbsp;my $data = do {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;local $/;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;DATA&gt;;
&nbsp;&nbsp;&nbsp;&nbsp;};

    # CSV line ending per http://tools.ietf.org/html/rfc4180
    $data =~ s/\n/\r\n/g;
&nbsp;&nbsp;&nbsp;&nbsp;$file-&gt;spew($data);
}

Every Step class must provide a run method. This method is expected to do whatever work the step does. In this case I take the list of children in DATA and turn it into a CSV file.

The logger attribute is provided to each step by the Stepford::Runner class. You'll learn more about that class later.

Atomic File Steps

I could have used Stepford::Role::Step::FileGenerator::Atomic instead. If your step is writing a file, using this role will prevent you from leaving behind a half-finished file if the step dies. I didn't use it in my example code just to keep the code simpler, but I highly recommend it for production code.

More Steps

The other steps are pretty similar. They take some data and spit something new out. Let's take a look at some of the code from the step that adds the UUIDs:

package NN::Step::AssignUUIDs;

...

has children_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits   =&gt; ['StepDependency'],
&nbsp;&nbsp;&nbsp;&nbsp;is       =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa      =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;required =&gt; 1,
);

has children_with_uuids_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits  =&gt; ['StepProduction'],
&nbsp;&nbsp;&nbsp;&nbsp;is      =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa     =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;lazy    =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;builder =&gt; '_build_children_with_uuids_file',
);

This step depends on the children_file created by the Children step. Stepford will figure this out and make sure that the steps are run in the correct order.

The AssignUUIDs step in turn has its own StepProduction which future steps will depend on.

The remaining steps follow a similar pattern. They take an input file and produce an output file. The last step, WriteList, is a little different, so let's see how:

package NN::Step::WriteList;

use Moose;

with 'Stepford::Role::Step';

The first difference is that I'm consuming the Stepford::Role::Step role instead of Stepford::Role::Step::FileGenerator.

This is mostly so I can demonstrate how to write a last_run_time method.

has children_with_uuids_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits   =&gt; ['StepDependency'],
&nbsp;&nbsp;&nbsp;&nbsp;is       =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa      =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;required =&gt; 1,
);

has ip_scores_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits   =&gt; ['StepDependency'],
&nbsp;&nbsp;&nbsp;&nbsp;is       =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa      =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;required =&gt; 1,
);

has name_scores_file =&gt; (
&nbsp;&nbsp;&nbsp;&nbsp;traits   =&gt; ['StepDependency'],
&nbsp;&nbsp;&nbsp;&nbsp;is       =&gt; 'ro',
&nbsp;&nbsp;&nbsp;&nbsp;isa      =&gt; File,
&nbsp;&nbsp;&nbsp;&nbsp;required =&gt; 1,
);

This step has three dependencies, unlike the previous steps you've seen. Each of these dependencies comes from a separate step. Stepford will figure all that out for us and run those steps before this one.

And here's the last_run_time method:

sub last_run_time ($self) {
&nbsp;&nbsp;&nbsp;&nbsp;my $file = $self-&gt;_naughty_nice_list;
&nbsp;&nbsp;&nbsp;&nbsp;return undef unless -e $file;

&nbsp;&nbsp;&nbsp;&nbsp;return $file-&gt;stat-&gt;mtime;
}

This is pretty straightforward. If the file exists, I return its last modification time. If not, I return undef.

Stepford uses the value of each step's last_run_time to determine whether or not a given step needs to be run at all. If the data in a dependency is newer than the data in the step that depends on that data, there's no point in regenerating the dependency's data.

(By the way, the last_run_time method above is essentially the same as the one in Stepford::Role::Step::FileGenerator.)

Running Your Steps

Now that I've written my steps, how do I run them? Here's the script I wrote:

#!/usr/bin/env perl

use strict;
use warnings;

use FindBin qw( $Bin );
use lib &quot;$Bin/../lib&quot;;

use Getopt::Long;
use Log::Dispatch;
use Stepford::Runner;

sub main {
&nbsp;&nbsp;&nbsp;&nbsp;my $debug;
&nbsp;&nbsp;&nbsp;&nbsp;my $jobs;
&nbsp;&nbsp;&nbsp;&nbsp;my $root;

&nbsp;&nbsp;&nbsp;&nbsp;GetOptions(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'debug'  =&gt; \$debug,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'jobs:i' =&gt; \$jobs,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'root:s' =&gt; \$root,
&nbsp;&nbsp;&nbsp;&nbsp;);

&nbsp;&nbsp;&nbsp;&nbsp;my $logger = Log::Dispatch-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;outputs =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;[
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'Screen',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;newline =&gt; 1,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;min_level =&gt; $debug ? 'debug' : 'warning',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;]
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;]
&nbsp;&nbsp;&nbsp;&nbsp;);

&nbsp;&nbsp;&nbsp;&nbsp;Stepford::Runner-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;step_namespaces =&gt; 'NN::Step',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;logger          =&gt; $logger,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;)-&gt;run(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;config =&gt; { $root ? ( root_dir =&gt; $root ) : () },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;final_steps =&gt; 'NN::Step::WriteList',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;);

&nbsp;&nbsp;&nbsp;&nbsp;exit 0;
}

main();

The only interesting piece is my use of Stepford::Runner.

Stepford::Runner-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;step_namespaces =&gt; 'NN::Step',
&nbsp;&nbsp;&nbsp;&nbsp;logger          =&gt; $logger,
&nbsp;&nbsp;&nbsp;&nbsp;jobs            =&gt; $jobs // 1,
&nbsp;&nbsp;&nbsp;&nbsp;)-&gt;run(
&nbsp;&nbsp;&nbsp;&nbsp;config =&gt; { $root ? ( root_dir =&gt; $root ) : () },
&nbsp;&nbsp;&nbsp;&nbsp;final_steps =&gt; 'NN::Step::WriteList',
&nbsp;&nbsp;&nbsp;&nbsp;);

The Stepford::Runner constructor takes several named arguments. The step_namespaces argument tells Stepford under what namespace it should look for steps. It will load all the classes that it finds under this namespace.

You can pass multiple namespaces as an array reference. When two steps have a production of the same name, then the step that comes first in the list of namespaces wins. This is useful for testing, as it lets you mock as many steps as you need to.

The logger can be any object that provides a certain set of methods (debug, info, etc.).

Finally, if you set jobs to a value greater than one, Stepford will run steps in parallel, running up to $jobs steps at once whenever possible.

The call to the run method also accepts named arguments. Keys in the config argument which match constructor arguments for a step will be passed to that step class as the step is constructed. Remember way back up above when I mentioned that I'd show you how to set the root_dir attribute of the NN::Step::Children class. This is how you do that.

The final_steps argument can be a single step class name or an array reference of names. This is how you specify the result you're asking Stepford for.

Why Stepford?

Stepford is lot like make, rake, and many other tools. Stepford was originally created to help improve our automation around building GeoIP databases at MaxMind.

I investigated make and rake, which are both great tools. However, what makes them shine is how they integrate with certain environments. The make tool is great if you're interacting with a lot of existing command line tools like compilers, linkers, etc. And of course rake is great if you're dealing with existing Ruby code.

But our database building code was is written in Perl, so it made sense to write a tool in Perl.

If you're in a similar situation, with a Perl code base that executes a series of steps towards one or more final products, then Stepford might be a good choice for you as well.

It certainly worked well for those elves. Sure, the naughty and nice list they get is complete and utter nonsense, but it's a lot quicker to generate, giving them more time for their pine juice-fueled Dark Souls speedruns.

The Code

If you want to see all the step code for this article, check out this article's GitHub repo.

Garlands of YAML and JSON

2015-12-15T00:00:00Z

Gluggagægir the Elf had to admit that the myriad of IT systems that worked together at the North Pole was amazing. All built different, in different languages, and with different technologies. Luckily, the Elves had decided that everyone should use a universal serialization format so that all the different systems could talk to each other. Unfortunately, however, none of the elves could agree what that should be, and they'd all ended up using a different universal serialization format.

While some elves are working at Santa's Gift Factories for a Holidays season or two before they move to greener pastures (usually quite literally greener, as the Easter Bunny is notoriously known to be the biggest elf poacher around) Gluggagægir is one of your long-term commitment type of elf. He's been around and worked in most departments, and expects to be around longer still, slowly moving up the yuletide ladder until — who knows? — he makes it as Cheers Chief Officer.

So Glugg has made the decision not to argue with the trend du jour, whatever that might be. Why can't we just accept input in any of the contested serialization formats and have the computer, which is pretty smart at processing data, figure it all out?

The current hot debate was should the elves be serializing data in either YAML or JSON, both of which are readable and fairly easy to manipulate. Either was perfectly fine with Glugg, as he's an old-hand to the serialization/deserialization dance. And happens to have one more handy tool on his belt for those tasks: File::Serialize.

Keep it short, keep it sweet

The main raison d'être of File::Serialize is to encapsulate and take care of all the boring, repetitive details that come with serialization. Before using File::Serialize, Glugg used to have two scripts that looked like

use NorthPole::DB;
use YAML;

my $nice_children = YAML::LoadFile( 'nice.yaml' );

update_db( nice =&gt; $nice_children );

and

use NorthPole::DB;
use JSON;
use Path::Tiny;

my $naughty_children = from_json path('naughty')-&gt;slurp;

update_db( naughty =&gt; $naughty_children );

In other words, almost the same, except for the serialization engine. But with File::Serialize, he now can just hide that difference under the blanket:

use NorthPole::DB;
use File::Serialize;

my %list = (
&nbsp;&nbsp;&nbsp;&nbsp;nice    =&gt; 'nice.yaml',
&nbsp;&nbsp;&nbsp;&nbsp;naughty =&gt; 'naughty.json',
);

while ( my( $status, $file ) = each %list ) {
&nbsp;&nbsp;&nbsp;&nbsp;update_db( $status =&gt; deserialize_file $file );
}

And it goes the other way around as well. The module can also figure out the right output format and deal with common options (pretty-printing, utf8 output, canonical representation) based on the filename the script is writing to:

use NorthPole::DB;
use File::Serialize { pretty =&gt; 1, canonical =&gt; 1, utf8 =&gt; 1 };

my $children = query_db();

my %report = (
&nbsp;&nbsp;&nbsp;&nbsp;nice    =&gt; 'nice_out.yaml',
&nbsp;&nbsp;&nbsp;&nbsp;naughty =&gt; 'naughty_out.json',
);

while ( my( $status, $file ) = each %list ) {
&nbsp;&nbsp;&nbsp;&nbsp;serialize_file $file =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;map { $_-&gt;behavior eq $status } @$children
&nbsp;&nbsp;&nbsp;&nbsp;];
}

With, of course, always the possibility to explicitly choose a specific format, for those special cases.

# TODO: have a chat with the Teddy Bear division 
# about cutesy extensions...

&nbsp;&nbsp;&nbsp;serialize_file 'teddy.hohoho' =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;grep { $_-&gt;want eq 'teddy bear' } @$nice_children
&nbsp;&nbsp;&nbsp;], { format =&gt; 'json' };

Keep it magic, when you need to be l33t

And then there is the module's carefully guarded little hidden bonus: it also has a function called transerialize_file, which allows to implement a small pipeline (or, in develfoper lingo, a garland) of transformations. For example, Glugg's real script is even shorter than the snippets given above, and looks something like this:

transerialize_file query_db()
&nbsp;&nbsp;&nbsp;&nbsp;=&gt; { 'all_children.yml' =&gt; undef }
&nbsp;&nbsp;&nbsp;&nbsp;=&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;[ 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;sub { [ grep { $_-&gt;behavior eq 'naughty' } @$_ ] } 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;=&gt; 'naughty.json' 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;[
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;sub { [ grep { $_-&gt;behavior eq 'nice' } @$_ ] } 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;=&gt; { 'nice.json' =&gt; undef },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;=&gt; sub { [ grep { $_-&gt;want eq 'teddy bear' } ] @$_ }
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;=&gt;  { 'teddy.hohoho' =&gt; { format =&gt; 'json' } }
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;]
&nbsp;&nbsp;&nbsp;&nbsp;];

Short and efficient. That's how elves are, and that's how they like their code to be.

crash kayo zamm splatt

2015-12-14T00:00:00Z

Would it shock you to know that despite having created one hundred and fifteen (and counting) Perl Advent Calendar entries over the years, I've never written an article on one of the smallest, silliest, modules that I rely on every day? A module that I can't debug my code without?

And the name of that module? Acme::MetaSyntactic. Yes, that's right. An Acme module, from the namespace on the CPAN that's traditionally reserved for joke modules. I'd better explain why I rely so heavily on one of these, shouldn't I?

There was a time when, like a chump, I'd write statements like this throughout my code:

print STDERR &quot;Here!\n&quot;;

And

print STDERR &quot;Got Here Also!\n&quot;;

This poor man's debugger technique is surprisingly effective. Unlike a real debugger it works well with web applications, it doesn't require an external module support (so in a pinch you can even use it on one of the production servers you've temporarily stopped the load balancer sending live traffic to) and can be left unattended to generate output on minutes long scripts while you go and fetch a hot beverage.

So if this is so effective, why was I a chump for using it? All that typing. Having to come up with unique new strings to print out all the time...I can't tell you the number of times I'd copy and pasted a print STDERR "Here!" from one place to another and then scratched my head wondering which Here was printing.

Laziness is one of the virtues of a Perl programmer. Surely we can automate this? You bet we can.

Acme::MetaSyntactic is a module that can create random memorable strings for us and the Acme-MetaSyntactic-Themes distribution on the CPAN contains a vast range of themes for it. For example, using the gems theme:

use Acme::MetaSyntactic qw(gems);
say join ' ', metagems(3) for 1..5;

Produces output like so:

    ruby amethyst girasol
    moonstone ivory sugilite
    jadeite tiger_s_eye jasper
    beryl lapis_lazuli diamond

We can easily use this technique to write a tiny little Perl script that outputs a print statement that contains unique-ish strings

use Acme::MetaSyntactic qw(batman);
say 'print STDERR &quot;'. join(q{ }, metabatman(2)) . '&quot;;\\n';

Executing this we can see our print statement with awesome 60s Batman type sound effects.

    print STDERR &quot;wham_eth klonk\n&quot;;

But how do we automate inserting this in our Perl code?

Configuring Your Editor

Modern editors are amazing things, Turing complete little bundles of wonder that can be configured to do almost anything, including executing a shell script and inserting the output of the script into your source code.

I won't tell you what editor to use (and you emacs and vim users probably know how to do this already) but I'll let you in on the secret of how I do this with Sublime Text 3, my editor of choice.

Sublime Text 3 has a complex plug-in system written in Python in which I've written many a tool. But, fear not, I need not concern myself with a non-Perl language in this Advent Calendar entry, for many existing plug-ins that can shell out exist that can be installed with Package Control without having to write a line of code. Using the External Command plug-in we can get our script to insert at the cursor every time we hit alt-shift-b.

{
&nbsp;&nbsp;&nbsp;&nbsp;&quot;keys&quot;: [&quot;alt+shift+b&quot;],
&nbsp;&nbsp;&nbsp;&nbsp;&quot;caption&quot;: &quot;print STDERR meta batman&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&quot;command&quot;: &quot;insert_command_output&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&quot;args&quot;: { &quot;cmdline&quot;: &quot;/Users/mark/bin/printmetabatman&quot; }
}

Configuring Your Terminal Emulator

So, why isn't running this in an editor sufficient? If you only ever edit code on your own box then everything is good...but what if you're logged into a remote server via ssh that either doesn't run your editor or choice or isn't configured to have Acme::MetaSyntactic or your editor configuration?

Rather than using the Terminal application bundled with OS X, these days I use an open source replacement called iTerm 2. As well as having cool features like being able to open files you ls with a click, configurable highlighting of terminal output (to show where all the errors are when you tail a log), and allowing programs you run in it to pop up notifications outside the window, it also allows co-processes. In iTerm parlance, co-processes are scripts that once launched get sent everything that the terminal is outputting. Anything they output is typed back into the terminal.

In our case, we want to simply want to execute our same two line Perl script as a co-process so its output is typed at the terminal. That can be done from within the Keys tab of the application's preferences:

Making an OS X Service

What if we want to take it even further? Have a keyboard shortcut that doesn't insert the text in a particular application but inserts the text anywhere on OS X that OS X thinks it can take text input?

OS X Services are global menu items that can be triggered by clicking on the title of the current running application next to the apple logo in the top left corner of the screen and selecting them from the Services menu underneath. More importantly, they can also be assigned global keyboard shortcuts.

The Automator application that is provided by Apple can be used to create Services that run Perl scripts: Launch Automator and select "Service" to create a new service. Search for the Run Shell Script action then configure it to run the Perl script (you can write Perl code directly in this box and configure it to be executed with /usr/bin/perl, but we're re-using the same script as in the previous examples.) Finally set it so the Service takes no input and tick the box so that Output replaces selected text.

The service is installed as soon as you save it.

Once you have created the service you can then assign a keyboard shortcut to it in System Preferences. Select the Keyboard icon, click on the Shortcuts tab and then pick Services on the left. Scroll down till you find your service under Text and click on the space to the right of the name to assign the shortcut.

Keyboard Maestro

If you were paying close attention you'll notice that previously I said that a service can be used "anywhere on OS X that OS X thinks it can take text input". What does that mean? It means that they can be used anywhere that the application is using the standard libraries to create a text input area. But not all applications use that (for example the previously mentioned iTerm2 and Sublime Text don't use those, and the service cannot be used within them.)

Keyboard Maestro is a commercial utility that can be used to control your Mac. One of the many things it can do is trigger a workflow whenever a key combination is pressed. That workflow can execute an external script and Keyboard Maestro can then simulate the keys on your keyboard being pressed. This means that the output from that script can be typed anywhere in any application running on your Mac, whether or not it's explicitly expecting it.

Typing Autocompletion

Another option to insert the text is to use a text expansion utility. For example, using the TextExpander program I can configure my computer so that every time I type metaqq it deletes that text and quickly types the output of my Perl script:

Setting this kind of script up with TextExpander is trivial; You just create a new macro and click on the content header and select Shell Script then enter the path to our existing script in the shebang line (or, you could write the Perl shell script here, directly in the text box.)

Keyboard Maestro is a little more complex to use than Text Expander but can also be configured to do text expansion with a shell script. It can even be configured to match what typed text triggers the macro with regular expressions, which allows you to have a very crude way to type in variables. For example, to produce a macro where we can type meta<theme>qq to select any of the installed Acme::MetaSyntactic themes:

In order to work out what was typed in the script we need to set a variable to the %TypedText% temporary variable, and then access it via an environment variable in our Perl script:

The True Perl Laziness

So today we have truly embraced the Perl concept of laziness. Rather than have to spend five seconds typing in a print statement, we've developed a Perl script that generates suitable output for us and investigated at least six different ways to trigger it on a Mac. I'm sure you'll all agree that that's time well spent.

swish bloop ker_sploosh thwape aiieee!

(JSON::)Paths in the snow

2015-12-13T00:00:00Z

One thing IT elves do a lot, is to munge data structures. In some departments, sources tell us, they use JSON::Path for it. It's not an extensive tool, but it can come in handy.

Despite its name, JSON::Path does not have much to do with JSON itself. It is rather an XPath-like query mini-language for querying structured data.

For example, taking a data structure all elves are rather familiar with:

my $master_list = { children =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name =&gt; 'Xavier',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;status =&gt; 'nice',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;wants =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{ label =&gt; 'T.S. Moe',      price =&gt; 9.99 },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{ label =&gt; 'coloring book', price =&gt; 5.45 },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name =&gt; 'Alex',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;status =&gt; 'naughty',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;wants =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{ label =&gt; 'rubber duck', price =&gt; 6.57 },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;name =&gt; 'Elo',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;status =&gt; 'nice',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;wants =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{ label =&gt; 'battle tiara',   price =&gt; 22.12},
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{ label =&gt; 'climbing gears', price =&gt; 12.33},
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;},
] };

We could extract the name of all naughty children via:

use JSON::Path qw/ jpath /;
$JSON::Path::Safe = 0;

my @naughty = jpath $master_list =&gt; '$.children[?($_-&gt;{status} eq &quot;naughty&quot; )].name';

Which means @naughty is now:

    [ &quot;Alex&quot; ]

Or get the first gift request of all nice children:

my @gifts = jpath $master_list =&gt; '$.children[?($_-&gt;{status} eq &quot;nice&quot; )].wants[0]';

Which means @gifts is now:

    [ &quot;T.S. Moe&quot;, &quot;battle tiara&quot; ]

There is also the possibility to alter the structure directly via jpath_map. For example, if we wanted to remove the naughty children and limit the wishlist of all nice children to their least expensive item (hey, it's a tough economy for everybody), one could do:

use JSON::Path qw/ jpath_map /;

# buh-bye naughty boys and naughty girls

jpath_map { 
&nbsp;&nbsp;&nbsp;&nbsp;[ grep { $_-&gt;{status} eq 'nice' } @$_ ] 
} $master_list =&gt; '$.children';

# remove the status, as they are all nice, now

jpath_map {
&nbsp;&nbsp;&nbsp;&nbsp;delete $_-&gt;{status}; $_        
} $master_list =&gt; '$.children[*]';

#  let's be reasonable...

use List::MoreUtils qw/ sort_by /;

jpath_map {
&nbsp;&nbsp;&nbsp;&nbsp;( sort_by { $_-&gt;{price} } @$_ )[0]
} $master_list =&gt; '$.children[*].wants';

Which means $master_list finally contains:

    {
        children   [
            {
                name    &quot;Xavier&quot;,
                wants   {
                    label   &quot;coloring book&quot;,
                    price   5.45
                }
            },
            {
                name    &quot;Elo&quot;,
                wants   {
                    label   &quot;climbing gears&quot;,
                    price   12.33
                }
            }
        ]
    }

Configuration Station

2015-12-12T00:00:00Z

The best option for configuration.

I wrote Config::Station after implementing a pattern I wrote about a while ago another time or two.

The overall gist of Config::Station is that you define a simple configuration class that knows nothing about the file the config is loaded from:

package MyApp::Config;

use Moo;
use Types::Standard 'Int';

has port =&gt; (
&nbsp;&nbsp;is =&gt; 'ro',
&nbsp;&nbsp;default =&gt; 0,
&nbsp;&nbsp;isa =&gt; Int,
);

has root_dir =&gt; (
&nbsp;&nbsp;is =&gt; 'ro',
&nbsp;&nbsp;default =&gt; '/var/myapp',
);

And then you inflate it with Config::Station:

my $station = Config::Station-&gt;new(
&nbsp;&nbsp;config_class =&gt; 'MyApp::Config',
&nbsp;&nbsp;env_key      =&gt; 'MYAPP',
&nbsp;&nbsp;location     =&gt; '.config.json',
);

my $config = $station-&gt;load;

So already we have a few nice details over most other config options out there:

We know exactly what config values are supported

I often get frustrated at trying to discover exactly what all config keys are used. Sometimes this isn't even possible when it's a mere hash.
We have defaults defined in a central location
We have all of the validation that we've become used to

Config::Station, like any good gift, gets progressively better as you learn more about it. Simply blessing a JSON file into an object is not the most impressive idea ever (though it is still pretty convenient, if I may say so myself.) One of the most important features of Config::Station is that it overlays the loaded config with environment variables. So if you wanted to start two separate web servers running your application running on two servers it should be as easy as:

 $ MYAPP_SERVER=Gazelle MYAPP_PORT=8080 myapp_server.pl &amp;
 $ MYAPP_SERVER=Starman MYAPP_PORT=8081 myapp_server.pl &amp;

That's really great, and really works well for my personal development flow, but it's still just a taste of what you can do with it.

See, the real beauty of Config::Station is the delegation of the hard work to the configuration class. Here's another example of cool things you can do, again using Moo as the object system backing the configuration class:

package MyApp::Config;

use Moo;
use JSONY;

has dsn =&gt; (
&nbsp;&nbsp;is =&gt; 'ro',
&nbsp;&nbsp;required =&gt; 1,
&nbsp;&nbsp;coerce =&gt; sub {
&nbsp;&nbsp;&nbsp;&nbsp;ref $_[0] ? $_[0] : JSONY-&gt;new-&gt;load($_[0])
&nbsp;&nbsp;},
)

We're adding smarts here: If the value passed to us isn't exactly in the format we want, we're coercing it into the right format.

You may not have heard of JSONY; it's a weird thing but it's great in cases like this. Here is how you could use it:

 $ MYAPP_DSN=&#39;dbi:ODBC:server=10.6.6.17 frew Password1!&#39; myapp_server.pl

In this example, the attribute's coercion uses JSONY to parse our string into an arrayref with three values, suitable for passing to DBI or DBIx::Class.

Of course, nothing requires you to use Moo or Moose. The only requirement is that your class take a flat hashref as it's sole argument. So if you wanted to do something really crazy you could go with raw OO:

package MyApp::Config;

use strict;
use warnings;

sub new {
&nbsp;&nbsp;my ($class, $hash) = @_;

&nbsp;&nbsp;bless [
&nbsp;&nbsp;&nbsp;&nbsp;$hash-&gt;{dsn},
&nbsp;&nbsp;&nbsp;&nbsp;$hash-&gt;{username},
&nbsp;&nbsp;&nbsp;&nbsp;$hash-&gt;{password},
&nbsp;&nbsp;], $class;

}

sub dsn { $_[0][0] }

sub username { $_[0][1] }

sub password { $_[0][2] }

Honestly I struggle to come up with an example that would warrant non-Moo OO, but it is explicitly supported nonetheless. Maybe if you wanted to do some crazy OO like IO::All does where you do bless Symbol::gensym(), $class?

Extracting more value out of your script's comments

2015-12-11T00:00:00Z

'Twas the day before Christmas Eve and Blink the elf had just had a call telling him that he'd been reassigned to the NOC (North-Pole Operations Centre). "It's an emergency, get over there pronto!"

He quickly learned about the realities of the systems running Santa's operation. Many of them created by different teams who rarely talked to each other, and who used whatever language and frameworks were hot at the time their project started. A mixture of command-line tools, SOAP-based web services, RESTful APIS, and so on.

"It's all glued together by Perl scripts that Jack wrote; when things go wrong he always knows how to get things running again. But Jack's sick, so we need a Perl hacker to help us through tomorrow! Someone told me that you're the elf who wrote the Prancer web framework, so I asked the Boss for you personally".

It turned out there was a collection of scripts, but the biggest complaint in the NOC was that no-one knew what they were doing as they were running ("when something goes wrong it's always been Jack who works out what needs restarting, and at what step"). When Blink started looking at the scripts, his heart initially sank: they were enormous, and he only had a few hours before they had to be in use! But at least there were some comments, describing what was going on:

# get list of children
... pile of code

# look them up in the Good Register
... pile of code

# get scanned images of letters to the Boss
... even more code

Blink remembered Smart::Comments, one of Damian Conway's modules, and realised it might help him out. Blink added use Smart::Comments and modified the highest level comments:

use Smart::Comments;

### get list of children
... code
### looking children up in the Good Register
...

Any comments that started with three or more hash characters ("#") were printed out as the script ran.

The NOC elves thought this was great, but there were some parts of the scripts that took quite a while to run, so the next thing for Blink to do was to give a bit more detail. There were a lot of places where code looped over countries, so first he wanted to print out the country being processed:

foreach my $country (@countries) {
    #### Processing country: $country
}

Any perl expession can be put after the colon, so Blink was quickly able to display a country name, which Santa was assigned, as so on. On this next level of comments Blink used four hashes. When using Smart::Comments he could specify what level of comments should be handled:

use Smart::Comments '###', '####';

This let the NOC decide how verbose the various scripts were when running. Blink then added the -ENV option:

use Smart::Comments -ENV, '###', '####';

This let the NOC specify the what level of diagnostics they wanted, just by setting the Smart_Comments environment variable:

    export Smart_Comments=&#39;###:####&#39;

The NOC can also set this environment variable to 0 to turn off the diagnostics completely.

There were still a lot of places where the scripts would iterate over large numbers of things, like children. Here it wasn't feasible to display each child's name, but they wanted some indication of progress. Blink used Smart::Comments's progress meters for these situations:

for my $child (@children) {   ### OCR [===|     ] % done
&nbsp;&nbsp;&nbsp;&nbsp;ocr_letter($child);
}

This displays a progress bar and a completion percentage. It will also track how long each step takes and estimate the time remaining, telling the NOC when a loop was close to finishing:

    OCR [=================|  ] 91% done  (about 20 seconds remaining)

After adding these three types of smart comments to all of the scripts, the NOC elves were very happy. Together they were able to get through Christmas Eve with no major mishaps.

The chief NOC elf asked Blink if he'd like to join the NOC full time, to work on a new microservices architecture. "Don't do it", whispered one of the junior NOC elves; "he says something like that every year. Why do you think Jack pulled a sickie?"

Just What Are You Installing Now?

2015-12-10T00:00:00Z

Have you ever been installing a Perl module and wondered why the heck a module was being installed? How the heck is that module a dependency of this module? So have I. So I decided to work it out, and when it all got too much to understand easily, I decided to make some pretty graphs:

cpanfile

The quest to understand why my distribution is requiring all these other modules to be installed starts with my cpanfile file.

The cpanfile format is natural language way of specifying the dependencies that your module needs. Here's an example one from Stepford:

requires &quot;Carp&quot; =&gt; &quot;0&quot;;
requires &quot;File::Temp&quot; =&gt; &quot;0&quot;;
requires &quot;Forest::Tree&quot; =&gt; &quot;0&quot;;
requires &quot;List::AllUtils&quot; =&gt; &quot;0&quot;;
requires &quot;Log::Dispatch&quot; =&gt; &quot;0&quot;;
requires &quot;Log::Dispatch::Null&quot; =&gt; &quot;0&quot;;
requires &quot;Module::Pluggable::Object&quot; =&gt; &quot;0&quot;;
requires &quot;Moose&quot; =&gt; &quot;0&quot;;
requires &quot;Moose::Role&quot; =&gt; &quot;0&quot;;
requires &quot;MooseX::Params::Validate&quot; =&gt; &quot;0&quot;;
requires &quot;MooseX::StrictConstructor&quot; =&gt; &quot;0&quot;;
requires &quot;MooseX::Types&quot; =&gt; &quot;0&quot;;
requires &quot;MooseX::Types::Combine&quot; =&gt; &quot;0&quot;;
requires &quot;MooseX::Types::Common::Numeric&quot; =&gt; &quot;0&quot;;
requires &quot;MooseX::Types::Common::String&quot; =&gt; &quot;0&quot;;
requires &quot;MooseX::Types::Moose&quot; =&gt; &quot;0&quot;;
requires &quot;MooseX::Types::Path::Class&quot; =&gt; &quot;0&quot;;
requires &quot;Parallel::ForkManager&quot; =&gt; &quot;0&quot;;
requires &quot;Path::Class&quot; =&gt; &quot;0&quot;;
requires &quot;Scalar::Util&quot; =&gt; &quot;0&quot;;
requires &quot;Scope::Guard&quot; =&gt; &quot;0&quot;;
requires &quot;Throwable::Error&quot; =&gt; &quot;0&quot;;
requires &quot;Time::HiRes&quot; =&gt; &quot;1.9726&quot;;
requires &quot;Try::Tiny&quot; =&gt; &quot;0&quot;;
requires &quot;namespace::autoclean&quot; =&gt; &quot;0&quot;;
requires &quot;parent&quot; =&gt; &quot;0&quot;;
requires &quot;perl&quot; =&gt; &quot;5.010&quot;;
requires &quot;strict&quot; =&gt; &quot;0&quot;;
requires &quot;warnings&quot; =&gt; &quot;0&quot;;
&nbsp;
on 'test' =&gt; sub {
&nbsp;&nbsp;requires &quot;ExtUtils::MakeMaker&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;File::Copy&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;File::Spec&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;IPC::Signal&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Log::Dispatch::Array&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Test::Differences&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Test::Fatal&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Test::More&quot; =&gt; &quot;0.96&quot;;
&nbsp;&nbsp;requires &quot;Test::Requires&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Test::Warnings&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;autodie&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;lib&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;perl&quot; =&gt; &quot;5.010&quot;;
};
&nbsp;
on 'test' =&gt; sub {
&nbsp;&nbsp;recommends &quot;CPAN::Meta&quot; =&gt; &quot;2.120900&quot;;
};
&nbsp;
on 'configure' =&gt; sub {
&nbsp;&nbsp;requires &quot;ExtUtils::MakeMaker&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;perl&quot; =&gt; &quot;5.006&quot;;
};
&nbsp;
on 'develop' =&gt; sub {
&nbsp;&nbsp;requires &quot;Code::TidyAll&quot; =&gt; &quot;0.24&quot;;
&nbsp;&nbsp;requires &quot;File::Spec&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;IO::Handle&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;IPC::Open3&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;IPC::Signal&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Perl::Critic&quot; =&gt; &quot;1.123&quot;;
&nbsp;&nbsp;requires &quot;Perl::Tidy&quot; =&gt; &quot;20140711&quot;;
&nbsp;&nbsp;requires &quot;Pod::Coverage::TrustPod&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Test::CPAN::Changes&quot; =&gt; &quot;0.19&quot;;
&nbsp;&nbsp;requires &quot;Test::Code::TidyAll&quot; =&gt; &quot;0.24&quot;;
&nbsp;&nbsp;requires &quot;Test::EOL&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Test::More&quot; =&gt; &quot;0.88&quot;;
&nbsp;&nbsp;requires &quot;Test::NoTabs&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Test::Pod&quot; =&gt; &quot;1.41&quot;;
&nbsp;&nbsp;requires &quot;Test::Pod::Coverage&quot; =&gt; &quot;1.08&quot;;
&nbsp;&nbsp;requires &quot;Test::Spelling&quot; =&gt; &quot;0.12&quot;;
&nbsp;&nbsp;requires &quot;Test::Synopsis&quot; =&gt; &quot;0&quot;;
&nbsp;&nbsp;requires &quot;Test::Version&quot; =&gt; &quot;1&quot;;
};

As you can see this is essentially a list of modules, along with their minimum version requirements, that this distribution either requires or recommends. You'll also note that are multiple sections for the dependencies, allowing you to specify what dependencies you need to run this module on a production server and which modules you just need when you're testing or developing the code.

The cpanfile file, which is typically distributed in the top level directory of a distribution, can either be created manually or automatically through inspection of your code by tools like the Dist::Zilla::Plugin::CPANFile plugin for Dist::Zilla. As well as being directly consumed by various tools, it's often used to produce things like the Makefile.PL and META.yaml and META.json files.

In our case we want to parse it so we can start to build our dependency tree.

Parsing the cpanfile format

The cpanfile format can easily be parsed with the Module::CPANfile module to give us the list of direct dependencies we need:

my @module_names = sort Module::CPANfile
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;load('cpanfile')
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;prereqs
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;merged_requirements([
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'runtime',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'build',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'test',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'configure',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'develop',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],[
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'requires',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;])
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;required_modules;

Whoa! That was a little dense. Let's break this down a little by adding more variables and comments:

# parse the on disk cpanfile
my $cpanfile = Module::CPANfile-&gt;load('cpanfile');

# get the CPAN::Meta::Prereqs instance that represents the prerequisites
my $prereqs = $cpanfile-&gt;prereqs;

# get the CPAN::Meta::Requirements that represents the requirements.  We want
# all the possible requirements that this module requires (i.e. those needed
# on a live server, but also those needed to build and test and develop it
# too) but not optional recommendations
my $requirements = $prereqs-&gt;merged_requirements([
&nbsp;&nbsp;'runtime', 'build', 'test', 'configure', 'develop',
],[
&nbsp;&nbsp;'requires',
]);

# And turn that into a sorted list of modules names
my @module_names = sort $requirements-&gt;required_modules;

We now know the immediate direct dependencies of our distribution in terms of module names, but how can we work out what distributions those modules are contained in, and in turn what those distributions themselves depend on?

Using MetaCPAN to Produce a Full Dependency Tree

MetaCPAN is, aside from being the most useful place to view the documentation and browse the code of everything on the CPAN, at its heart an Elasticsearch database that contains meta information on each of the modules. We can use the MetaCPAN API to ask for the dependencies of modules, their dependencies, and so on to create a graph of each of the modules.

Let's look at the code that's needed to do this. First we create an instance of the MetaCPAN::Client that can be used to connect to the MetaCPAN API that sits on top of the Elasticsearch database.

my $mcpan = MetaCPAN::Client-&gt;new(
&nbsp;&nbsp;ua =&gt; HTTP::Tiny::Mech-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;mechua =&gt; WWW::Mechanize::Cached-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;cache =&gt; CHI-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;driver   =&gt; 'File',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;root_dir =&gt; '/tmp/metacpan-cache',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;),
&nbsp;&nbsp;&nbsp;&nbsp;),
&nbsp;&nbsp;),
);

This invocation makes use of an on-disk cache for each request to MetaCPAN so when we run this script multiple times we don't need to re-lookup information we've already fetched. This both speeds things up and makes the MetaCPAN admins considerably less grumpy!

The code to look up the distribution a module comes in is straightforward:

sub module_to_dist($module_name) {
&nbsp;&nbsp;&nbsp;&nbsp;my $dist;
&nbsp;&nbsp;&nbsp;&nbsp;unless(eval {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;my $mod_obj = $mcpan-&gt;module( $module_name );
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$dist = $mod_obj-&gt;distribution;
&nbsp;&nbsp;&nbsp;&nbsp;1 }) {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;warn $@;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return;
&nbsp;&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;&nbsp;return $dist;
}
memoize('module_to_dist');

This will allow us to pass in module names like HTTP::Response and get back responses like HTTP-Message to tell us the distribution that contains HTTP::Response.

Similarly we can get the release object back for a given distribution:

sub dist_to_release($dist_name) {
&nbsp;&nbsp;&nbsp;&nbsp;my $release;
&nbsp;&nbsp;&nbsp;&nbsp;unless(eval {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$release = $mcpan-&gt;release( $dist_name );
&nbsp;&nbsp;&nbsp;&nbsp;1 }) {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;warn $@;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return;
&nbsp;&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;&nbsp;return $release;
}
memoize('dist_to_release');

This release object has a dependency method that returns an array reference containing the names of all the modules this particular release (in this case the latest one on the CPAN for that name) depends on.

foreach my $dep ($release-&gt;dependency-&gt;@*) {
&nbsp;&nbsp;say &quot; * $dep &quot;;
}

Using these two methods we can then easily build a hash mapping dependencies:

my %map;
sub add_mapping($from, $to) {
&nbsp;&nbsp;&nbsp;&nbsp;$map{ $from } ||= [];
&nbsp;&nbsp;&nbsp;&nbsp;push $map{ $from }-&gt;@*, $to;
&nbsp;&nbsp;&nbsp;&nbsp;return;
}

sub lookup_module($module_name) {
&nbsp;&nbsp;&nbsp;&nbsp;return if $map{ &quot;mod:$module_name&quot; };
&nbsp;&nbsp;&nbsp;&nbsp;return if $module_name eq 'perl';
&nbsp;&nbsp;&nbsp;&nbsp;return if Module::CoreList-&gt;first_release( $module_name );

    # work out the distribution for this module
    my $dist = module_to_dist( $module_name )
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;or return;

&nbsp;&nbsp;&nbsp;&nbsp;add_mapping( &quot;mod:$module_name&quot;, &quot;dist:$dist&quot; );
&nbsp;&nbsp;&nbsp;&nbsp;lookup_dist($dist);
}

sub lookup_dist($dist) {
&nbsp;&nbsp;&nbsp;&nbsp;return if $map{ &quot;dist:$dist&quot; };

&nbsp;&nbsp;&nbsp;&nbsp;my $release = dist_to_release( $dist )
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;or return;

    # okay, need to work out this distribution's dependencies and repeat
    foreach my $dep ($release-&gt;dependency-&gt;@*) {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;my $mod = $dep-&gt;{module};
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;next if $mod eq 'perl';
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;next if Module::CoreList-&gt;first_release( $mod );
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;add_mapping( &quot;dist:$dist&quot;, &quot;mod:$mod&quot; );
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;lookup_module($mod);
&nbsp;&nbsp;&nbsp;&nbsp;}
}

foreach (@module_names) {
&nbsp;&nbsp;&nbsp;&nbsp;add_mapping( 'cpanfile', &quot;mod:$_&quot; );
&nbsp;&nbsp;&nbsp;&nbsp;lookup_module($_);
}

And then you can obviously dump that out to as JSON into a JavaScript file.

print 'data='.encode_json(\%map);

Graphing

As comprehensive as this data structure is, it's not easy to understand at a glance. What we want to do is turn this into some sort of easy to follow directed graph with nodes for the distributions and modules connected together with lines representing the dependencies.

Any number of JavaScript libraries can be used to turn the chunk of JavaScript we just created into an on-screen graph in a web browser. My personal favorite is VivaGraph, simply because CPAN dependency graphs can get very very large and it has excellent performance on larger graphs, especially when used in WebGL mode opposed to the default SVG rendering engine.

The actual code to build the graph is fairly straightforward:

var graph = Viva.Graph.graph();

var nodesAlreadyAdded = {};
var maybeAddNode = function(nodeName) {
&nbsp;&nbsp;&nbsp;&nbsp;if (nodesAlreadyAdded[nodeName])
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return;
&nbsp;&nbsp;&nbsp;&nbsp;nodesAlreadyAdded[nodeName] = 1;
&nbsp;&nbsp;&nbsp;&nbsp;graph.addNode(nodeName);
}
var addEdge = function(from,to) {
&nbsp;&nbsp;&nbsp;&nbsp;maybeAddNode(from);
&nbsp;&nbsp;&nbsp;&nbsp;maybeAddNode(to);
&nbsp;&nbsp;&nbsp;&nbsp;graph.addLink(from, to);
}
for (var key in data)
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;for (var index = 0; index&lt;data[key].length; index++)
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;addEdge( key, data[key][index] );

VivaGraph is quite customizable, and the full code to fiddle with the presentation options, switch on WebGL mode, add custom colors, labels, alter the length of the links depending what's linking, etc, etc is all worth taking a look.

Conclusion

Several projects I work on install half of the CPAN. While this is a good thing (since I don't have to write or maintain all the code that constitutes half of the CPAN,) I often find I end up depending on some hard to install or unreliable module. By graphing my dependency tree I can work out exactly why I'm depending on a module and work out what steps I can take to mitigate the situation.

Scrape the Halls

2015-12-09T00:00:00Z

Here's a shocker: the Santa Factories doesn't manufacture all of the children's toys for Christmas. For particular toys and special requests, the elves will buy the toys, and just take care of the wrapping and delivery. But don't you think they are going around with this outsourcing in an indiscriminate manner; the Big Man in Red made it very clear that toys should not be bought from big mega-corporations, but only from Mom'n'Pop shops, where they are built out of love and honest desire to make children happy.

Noble sentiments. But one that throws some wrenches in the finely-tuned North Pole's toy managing software. Mega-corporations might be soulless, but they usually have systems backed by solid REST APIs. Mom and Pop shops? A basic website is usually all you get. It's not pretty, but for those cases develfopers have to revert to crude but effective web scraping.

One of their tools is Web::Query, which is heavily inspired by the ubiquitous jQuery. With it, they can use CSS selectors, or even XPath expressions, to access and munge their target websites.

A Working Example

Let's look at the wonderful Vermont Teddy Bear website. Santa approves of this company because they always make sure that they ship their teddy bears in packaging with air holes (so the bears can breathe) and each bear gets free complimentary health care (where by the company will fix the bear if it's sick and shipped back to the Teddy Bear Hospital.)

Here's the current page for all their hobby bears:

If our elves are going to work out the price of the products they need to take a look at the source code of the page with their browser's Web Inspector. It turns out the part of the page's HTML markup they're going to be interested in looks like this:

&lt;ul id=&quot;products&quot;&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;li&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;div class=&quot;ProductImageDashed&quot;&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;...
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;/div&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;div class=&quot;ProductImageDescr&quot;&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;a id=&quot;ctl00_MainContent_UcC2CategorySellGroups1_dlSellGroups_ctl00_lnkSellGroupText&quot;
               href=&quot;../SellGroup/15-yoga-bear.aspx&quot;&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;span id=&quot;ctl00_MainContent_UcC2CategorySellGroups1_dlSellGroups_ctl00_LabelProductName&quot;&gt;15&quot; Yoga Bear&lt;/span&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;/a&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;br&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;a id=&quot;ctl00_MainContent_UcC2CategorySellGroups1_dlSellGroups_ctl00_LabelPricing&quot;
               class=&quot;productsprice&quot; href=&quot;../SellGroup/15-yoga-bear.aspx&quot;&gt;$79.99&lt;/a&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;/div&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;/li&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;li&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;div class=&quot;ProductImageDashed&quot;&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;...
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;/div&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;div class=&quot;ProductImageDescr&quot;&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;a id=&quot;ctl00_MainContent_UcC2CategorySellGroups1_dlSellGroups_ctl01_lnkSellGroupText&quot;
               href=&quot;../SellGroup/Ballerina-Bear.aspx&quot;&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;span id=&quot;ctl00_MainContent_UcC2CategorySellGroups1_dlSellGroups_ctl01_LabelProductName&quot;&gt;15&quot; Ballerina Bear&lt;/span&gt;&lt;/a&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;br&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;a id=&quot;ctl00_MainContent_UcC2CategorySellGroups1_dlSellGroups_ctl01_LabelPricing&quot;
               class=&quot;productsprice&quot; href=&quot;../SellGroup/Ballerina-Bear.aspx&quot;&gt;$69.99&lt;/a&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;/div&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&lt;/li&gt;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;...
&lt;/ul&gt;

A Small Script

Using Web::Query, the elves are able to retrieve all the information on that page rather easily with a tiny tiny script:

use 5.20.0;
use experimental 'postderef';

use Data::Printer;
use Web::Query;

my %toys = wq( 'http://www.vermontteddybear.com/Category/Hobbies.aspx?View=All' )
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;find('#products li .ProductImageDescr')
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;map(sub {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;my $name  = $_-&gt;find('a:first-child')-&gt;text;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;my $price = $_-&gt;find('.productsprice')-&gt;text;

&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return ($name =&gt; $price);
&nbsp;&nbsp;&nbsp;&nbsp;})-&gt;@*;

p %toys

Let's break this down a little to see what those elves are up to:

wq( 'http://www.vermontteddybear.com/Category/Hobbies.aspx?View=All' )

This goes to the web and downloads a page, and creates a Web::Query object containing the top node of that page.

-&gt;find('#products li .ProductImageDescr')

This returns a new Web::Query object (based on the old Web::Query object) that contains all the nodes that match the CSS selector we passed in (and nothing else.) In this case it's all the ProductImageDescr divs in <li> elements inside the element with the products id assigned to it.

-&gt;map(sub {
&nbsp;&nbsp;&nbsp;...
})

This calls the passed subroutine multiple times, once per previously matched node, with a new Web::Query object that contains just the one node that we're currently processing passed via the context variable $_.

my $name  = $_-&gt;find('a:first-child')-&gt;text;
my $price = $_-&gt;find('.productsprice')-&gt;text;

This finally does further lookups from the point of view each node the map receives. So, for example, the .productsprice selector just matches the price under this particular .ProductImageDescr node, not every .productsprice in the entire document.

Filtering

After all that, running that script kinda produces some of the right data:

    # perl get_bears.pl
    {
        &#39;15&quot; Artist Bear&#39;                       &quot;$69.99&quot;,
        &#39;15&quot; Aviator Bear &#39;                     &quot;$79.99&quot;,
        &#39;15&quot; Ballerina Bear&#39;                    &quot;$69.99&quot;,
        &#39;15&quot; Basketball Bear&#39;                   &quot;$69.99&quot;,
        &#39;15&quot; Cooking Bear&#39;                      &quot;$79.99&quot;,
        &#39;15&quot; Everything Grows with Love Bear&#39;   &quot;$69.99&quot;,
        &#39;15&quot; Golfer Bear&#39;                       &quot;$79.99&quot;,
        &#39;15&#39;&#39; Gone Fishin&#39; Bear&#39;                &quot;$79.99&quot;,
        &#39;15&quot; Handy Bear&#39;                        &quot;$79.99&quot;,
        &#39;15&quot; Lady Golfer&#39;                       &quot;$79.99&quot;,
        &#39;15&quot; Martial Arts Bear&#39;                 &quot;$79.99&quot;,
        &#39;15&#39;&#39; Racecar Driver Bear&#39;              &quot;$69.99&quot;,
        &#39;15&quot; Runner Bear&#39;                       &quot;$69.99&quot;,
        &#39;15&quot; Sewing Bear&#39;                       &quot;$79.99&quot;,
        &#39;15&quot; Skier Bear&#39;                        &quot;$79.99&quot;,
        &#39;15&quot; Soccer Bear&#39;                       &quot;$69.99&quot;,
        &#39;15&quot; Surf&#39;s Up Bear&#39;                    &quot;$69.99&quot;,
        &#39;15&quot; Tennis Bear&#39;                       &quot;$79.99&quot;,
        &#39;15&quot; Train Engineer&#39;                    &quot;$69.99&quot;,
        &#39;15&quot; Yoga Bear&#39;                         &quot;$79.99&quot;,
        &#39;Arts &amp; Crafts Bears&#39;                   &quot;&quot;,
        &#39;Bears for Dance Lovers&#39;                &quot;&quot;,
        &#39;Bears For Peace&#39;                       &quot;&quot;,
        Music                                   &quot;&quot;,
        &#39;Religious Bears&#39;                       &quot;&quot;
    }

However, Santa don't really want the data for the categories at the bottom of the page that doesn't include pricing. Using the filter method we're able to discard any result which the passed subroutine doesn't return true for:

use 5.20.0;
use experimental 'postderef';

use Data::Printer;
use Web::Query;

my %toys = wq( 'http://www.vermontteddybear.com/Category/Hobbies.aspx?View=All' )
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;find('#products li .ProductImageDescr')
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;filter(sub {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return length $_-&gt;find('.productsprice')-&gt;text &gt; 0;
&nbsp;&nbsp;&nbsp;&nbsp;})
&nbsp;&nbsp;&nbsp;&nbsp;-&gt;map(sub {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;my $name  = $_-&gt;find('a:first-child')-&gt;text;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;my $price = $_-&gt;find('.productsprice')-&gt;text;

&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return ($name =&gt; $price);
&nbsp;&nbsp;&nbsp;&nbsp;})-&gt;@*;

p %toys

Success!

Setting the User Agent

A few days later the elves were in a bit of a pickle. Their script had stopped working! It turned out that the Vermont Teddy Bear company had been having some problems with people who weren't on the nice list, and they'd blocked the standard Perl user agent string, and the elves' code was collateral damage.

Because elves are conscientious, they decided to change the UserAgent to make sure that the shops can see that it's their web scrapers that visited their sites with a minor code change at the top of all their Web::Scraper scripts:

$web::Query::UserAgent = LWP::UserAgent-&gt;new( 
&nbsp;&nbsp;&nbsp;&nbsp;agent =&gt; 'SnowReindeer/4.0.0.0', # pronounced &quot;four-HO-HO-HO!&quot;
);

Live programming perl with Reply

2015-12-08T00:00:00Z

Of all the things Perl is and is not, it is most definitely a dynamic language. We don't run Perl through a compiler and then run the resulting executable, we just give perl some code and it runs it. In a language like C or Java, we'd have to rebuild every time we wanted to run a test, but Perl allows me to hit 'save' in my editor, alt-tab to my terminal and hit <up><enter> to rerun my test.

Obviously this helps speed up my test workflow enormously, but we can still do better. What if we could edit our application while it was running? This is the promise of a REPL (Read Eval Print Loop). In this article we'll be exploring a new REPL for Perl called Reply to do some live-coding.

You'll need a recent-ish perl installed as well as git if you're going to follow along

Installation

Let's try installing Reply through cpanminus with the cpanm utility (my prompt is the simple %):

    % cpanm Reply Term::ReadLine::Gnu Proc::InvokeEditor
    --&gt; Working on Reply
    Fetching http://www.cpan.org/authors/id/D/DO/DOY/Reply-0.37.tar.gz ... OK
    Configuring Reply-0.37 ... OK
    ==&gt; Found dependencies: Config::INI::Reader::Ordered
    --&gt; Working on Config::INI::Reader::Ordered
    Fetching http://www.cpan.org/authors/id/R/RJ/RJBS/Config-INI-Reader-Ordered-0.020.tar.gz ... OK
    Configuring Config-INI-Reader-Ordered-0.020 ... OK
    Building and testing Config-INI-Reader-Ordered-0.020 ... OK
    Successfully installed Config-INI-Reader-Ordered-0.020
    Building and testing Reply-0.37 ... OK
    Successfully installed Reply-0.37
    2 distributions installed

Don't worry if your output looks different, so long as the modules installed successfully, you're good to go! We're also installing a bunch of other modules that are required for some of the plugins we'll try later to work.

Getting Started

Let's open a repl with the reply command:

    % reply
    /Users/user/.replyrc not found. Generating a default...
    0&gt;

Okay, looks good so far. Let's try running some basic Perl:

    0&gt;  $i = &quot;foo&quot;
    Global symbol &quot;$i&quot; requires explicit package name at reply input line 1.
    BEGIN not safe after errors--compilation aborted at reply input line 7.

Okay, so we're running under strict. Excellent! I also notice that readline bindings work, so you can use the arrow keys and standard readline shortcuts easily to edit your input. Autocomplete 'just works'(tm) as well (it's on the TAB key)

    1&gt; my $i = &quot;foo&quot;
    $res[0] = &#39;foo&#39;

Okay, the basics work. Note also that we don't need to put a semicolon at the end of a line. When you hit enter, it will treat it as a complete statement. That's an important limitation that's worth mentioning.

Let's see if we can load it into an existing project. Quit reply with Ctrl-c and find some code.

    % cd ~/code/asset-pack # my local copy of https://github.com/jjl/asset-pack.git
    % reply -Ilib # -Ilib = add &#39;lib&#39; to @INC so we can see those perl modules
    0&gt; use Asset::Pack;
    1&gt;

Hurray, that worked. Sadly Asset::Pack isn't useful unless you want to package an asset as a Perl file, so let's use the repl to explore List::Util:

    1&gt; use List::Util qw(first);
    2&gt; first {/abc/} &quot;def&quot;, &quot;hij&quot;
    $res[0] = undef
    3&gt; first {/abc/} &quot;abc&quot;, &quot;def&quot;
    $res[1] = &#39;abc&#39;

These two simple examples show off 'first', which takes a block. Let's look at its prototype:

    4&gt; prototype(\&amp;first)
    $res[2] = &#39;&amp;@&#39;

Plugins Intro

At this point you can already do a fair amount. Now let's look at that .replyrc file that reply said it wrote earlier:

    # less ~/.replyrc
    script_line1 = use strict
    script_line2 = use warnings
    script_line3 = use 5.020001
    
    [Interrupt]
    [FancyPrompt]
    [DataDumper]
    [Colors]
    [ReadLine]
    [Hints]
    [Packages]
    [LexicalPersistence]
    [ResultCache]
    [Autocomplete::Packages]
    [Autocomplete::Lexicals]
    [Autocomplete::Functions]
    [Autocomplete::Globals]
    [Autocomplete::Methods]
    [Autocomplete::Commands]

Wow, that's quite a lot. Comparing against https://metacpan.org/release/Reply, I see that's most of the plugins that ship in the core distribution!

Here's what these plugins do (and what you're getting out of the box!)

Name	Purpose
Interrupt	Stop long-running code with `ctrl-c`
FancyPrompt	Adds a line counter to the prompt
DataDumper	Formats results with `Data::Dumper`
Colors	Colors results
ReadLine	Enables ReadLine input method (keybindings)
Hints	Enables `strict` to work, among others (persists hints)
Packages	Makes `package` declarations work
LexicalPersistence	Makes `my` declarations work
ResultCache	Results are put into `@res` for later use
Autocomplete::*	Autocompletion of various types

If you don't want some of those, simply delete those lines from your config file and they won't be loaded next time you start a repl.

Take a look at https://metacpan.org/release/Reply to see all the basic plugins.

Editing multiple lines

One of the handier plugins is Reply::Plugin::Editor, which allows you to edit multiple lines in your text editor of choice. Add this to the bottom of your .replyrc:

    [Editor]
    editor=emacs # or vim, nano etc...

Now when you're in reply and you type #e, your editor will open. When you save the file and quit your editor, the code will be evaluated all at once. This allows you to define subroutines more easily because now you can split statements over multiple lines.

    0&gt; #e
    &lt;editor opens&gt;
    sub hello {
      &quot;Hello, @{[shift]}.&quot;;
    }
    &lt;save and close&gt;
    1&gt; hello(&quot;world&quot;)
    $res[0]=&quot;Hello, world.&quot;

Sharing templates will get you on the nice list

2015-12-07T00:00:00Z

It was the night before Christmas Eve and the elves in Santa's Grotto were typing away on their keyboards getting ready for the tomorrow night, making sure the last minute issues were fixed. Unfortunately the day had started badly - the elves in the QA department had reported three bugs in quick succession with their website. If the elves didn't address the problems in the next few hours, Christmas would be ruined!

The Problems

The QA elves had identified three problems with the website the team packing the sleigh use to record their work:

If I filter with the widget the text is in suddenly in English, but if I hit reload it's Elvish as it should be!
If I browse to the page it looks great, but if I refresh it goes bad!
The total at the bottom of this table is wrong! Aren't there tests?

Pronto the Front End Develfoper

The leader of elvish front-end development team scratched her head for a moment. The first two seemed to be similar bugs, but in one case the "client side" was wrong and in the other the "server side" was wrong.

After six cups of elf eggnog, the answer finally hit her! The JavaScript code that ran on the client side had its own templating language, and so the changes to the templates had to be made to both templates that generated the output. The templates that generate the page on the server side and the JavaScript templates that create HTML from the JSON loaded from the server in AJAJ requests need to be identical! Any differences would end up with the bugs they were seeing.

After much cross referencing between the two templating languages (and worrying about the minutiae of the different syntaxes) Pronto managed to commit a fix just a few hours before the deadline.

Sighing, Proto thought having to maintain two templating languages and two sets of identical templates is always going to be a huge pain for my team

Retro the Back-End Develfoper

Meanwhile the lead of back-end team looked for the source of the third and final bug, the table total bug. Her team grepped as hard as they could around lib/SantasWorkshop/ but the table logic was nowhere to be found!

Finally, one of the team had a realisation - the logic wasn't in the modules, it was in one of the back-end templates themselves! And he was right, the addition - and the bug - was in the template file. Retro shook her head; no wonder there wasn't a test for it! Quickly she fixed the bug and pushed out a new release, but no-one in her team felt right about not being able to add a regression test for the code.

Sighing, Retro thought having all this logic in the templates where it can't be tested is always going to be a huge pain for my team

Santa's Mustache

When Santa finally got back from his around the world dash, he scheduled debriefing meetings with his developers to learn about what could be improved for next year. When he heard all about the last minute problems that had nearly ended in worldwide disappointment for the children his forehead wrinkled under his big red hat. He sat quietly for a moment, stroking his mustache...

A smile crept across Santa's face. "Ho ho ho, I know of a solution to both your problems", he said, his grin widening. "Have you heard of Mustache?" The elves shook their head, but one of them brought up the website on his icePhone 6.

Mustache provides logic-less templates and has parsers for multiple languages including JavaScript and Perl!

By being logic-less you're forced to put your logic into your Perl modules

where it's easy to write unit tests for your subroutines.
By being usable in JavaScript and Perl you can write one set of templates and

render them on the server side or the client side as needed.

Hogan.js and Text::Hogan

There are actually a few options even within Perl and JavaScript for mustache libraries. The elves gave a few a try, and eventually settled on hogan.js (from Twitter) and its Perl-ish clone Text::Hogan (from your story-teller.)

In Perl:

use Text::Hogan::Compiler;

my $text = &quot;Hello, {{name}}!&quot;;

my $template = Text::Hogan::Compiler-&gt;new-&gt;compile($text);

say $template-&gt;render({ name =&gt; &quot;Santa&quot; });

In JavaScript:

var text = &quot;Hello, {{name}}!&quot;;

var template = Hogan.compile(text);

console.log(template.render({name: &quot;Santa&quot;});

Despite the "logic-less" claim Mustache templates do provide some simple constructs you can use for optional blocks or looping blocks.

use Text::Hogan::Compiler;
use Time::Moment;

my $text = &lt;&lt;'END_MUSTACHE';
&lt;h1&gt;Santa's Dashboard&lt;/h1&gt;

&lt;h2&gt;Nice/Naughty List&lt;/h2&gt;
&lt;ul&gt;
{{#list}}
&lt;li&gt;{{name}} - {{nice}}&lt;/li&gt;
{{/list}}

&lt;h2&gt;Is it Christmas yet?&lt;/h2&gt;
{{#is_it_christmas_yet}}&lt;p&gt;Yes, it's Christmas!&lt;/p&gt;{{/is_it_christmas_yet}}
{{^is_it_christmas_yet}}&lt;p&gt;No, it's not Christmas yet.&lt;/p&gt;{{/is_it_christmas_yet}}
END_MUSTACHE

my %data = (
&nbsp;&nbsp;&nbsp;&nbsp;list =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;sort { $a-&gt;{name} cmp $b-&gt;{name} }
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;( map { +{ name =&gt; $_, nice =&gt; &quot;nice&quot;    } } qw(Fred Betty)   ),
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;( map { +{ name =&gt; $_, nice =&gt; &quot;naughty&quot; } } qw(Barney Wilma) ),
&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;is_it_christmas_yet =&gt; Time::Moment-&gt;now-&gt;strftime(&quot;%m-%d&quot;) eq '12-25',
);

my $template = Text::Hogan::Compiler-&gt;new-&gt;compile($text);
say $template-&gt;render(\%data);

As you can see # is used for ifs and loops, and ^ is used for negative checks. For more details see the mustache(5) man page.

One more issue

The elves had gleefully replaced all their old templates with new mustache based ones, and written tests for all their code that was previously locked away in template files. Hooray! But then one day, shortly before next Christmas, another bug report came in:

"I don't think we can use these new templates during the Christmas rush. Our metrics show that the site has gotten much slower since we switched."

Luckily one of the elvish development team was ready for this. Not wanting to fall into the trap of premature optimization he hadn't yet used one of hogan.js and Text::Hogan's most powerful features: pre-rendering.

Using Text::Hogan::Compiler's compile method (like in the examples above) means you only compile a template to Perl code once per process (due to clever internal caching.) Using pre-rendering however, you can actually get at the generated Perl code and cache it somewhere on disk / in memcache, etc.

use Text::Hogan::Compiler;

my $text = &quot;Hello, {{name}}!&quot;;

my $perl_code = Text::Hogan::Compiler-&gt;new-&gt;compile(
&nbsp;&nbsp;&nbsp;&nbsp;$text, { as_string =&gt; 1 }
);

say $perl_code;

The Perl code that comes out the other end isn't pretty, but it renders really quickly:

{ code =&gt; sub { my ($self,$c,$p,$i) = @_; $t-&gt;b($i = $i || &quot;&quot;);
$t-&gt;b(&quot;Hello, &quot;);$t-&gt;b($t-&gt;v($t-&gt;f(&quot;name&quot;,$c,$p,0)));$t-&gt;b(&quot;!&quot;);
return $t-&gt;fl(); }, &quot;partials&quot; =&gt; {  }, &quot;subs&quot; =&gt; {  } }

The JavaScript library hogan.js can pull the same trick with its "hulk" command-line tool or with various grunt, gulp or webpack plugins.

Once the change to pre-compile the templates went live the site was even faster than it was on the old templates. Christmas was saved again!

Calculating cooking times the easy way

2015-12-06T00:00:00Z

We've all been there when cooking - you have one thing that should be cooked at 200℃ for 30 minutes, another that asks for 220℃ for 35 minutes, and something else that only wants 180℃ for 26 minutes. However, you only have the one oven, so there's going to have to be compromises!

After one too many times guessing appropriate adjustments in my head, I decided "this sounds like something a computer can be doing for me quickly". So, enter Convert::CookingTimes. Given a set of item names, temperatures and durations, it works out the average of the temperatures requested, then adjusts the cooking times to suit (so things being cooked at a higher temperature than normal will get their cooking times reduced and vice-versa). It will then present a list of instructions telling you what temperature to pre-heat the oven to, and what should be put in and when, for everything to end up done at the same time.

So, let's say we're doing a nice tasty English Christmas dinner. We have:

A bunch of potatoes that need roasting for 45 minutes at 200℃
A turkey that's meant to be cooked for two hours at 180℃
And the stuffing that needs to go in for quartre of an hour at 210℃

On a chart this looks something like this:

However, since we need to cook them all at the same temperature we need to adjust the cooking times to compensate. Let's use our Perl module:

my ($temperature, $steps) = Convert::CookingTimes-&gt;adjust_times(
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Roast spuds', temp =&gt; 200, time =&gt; 45,  },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Turkey',      temp =&gt; 180, time =&gt; 120, },
&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Stuffing',    temp =&gt; 210, time =&gt; 15,  },
);

print Dumper {
&nbsp;&nbsp;temperature =&gt; $temperature,
&nbsp;&nbsp;steps =&gt; $steps,
};

The steps are returned from adjust_times as a reference to an array of hashrefs. These are the same items as passed in, reordered to be in the order you need to put them in the oven. Each of them is a hashref with the keys name, adjusted_time (how long to cook that thing for in total) and, for convenience, time_until_next (the amount of time to wait before the next item in the list is added to the oven in order for everything to be done at the same time). When we run our little script we get this handy output:

$VAR1 = {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'steps' =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'name' =&gt; 'Turkey',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'adjusted_time' =&gt; 108,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'time_until_next' =&gt; 63
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'time_until_next' =&gt; 29,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'adjusted_time' =&gt; 45,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'name' =&gt; 'Roast spuds'
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'name' =&gt; 'Stuffing',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'adjusted_time' =&gt; 16
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;],
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'temperature' =&gt; 200
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;};

Plotting these on a chart shows us how the time and temperature for the potatoes and stuffings have been adjusted from the original values (marked with the blue circles):

To make our lives even easier, the output of adjust_times can be passed to summarise_instructions to produce a set of human-readable summarised instructions like so:

say for Convert::CookingTimes-&gt;summarise_instructions(
&nbsp;&nbsp;&nbsp;&nbsp;Convert::CookingTimes-&gt;adjust_times(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Roast spuds', temp =&gt; 200, time =&gt; 45,  },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Turkey',      temp =&gt; 180, time =&gt; 120, },
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;{ name =&gt; 'Stuffing',    temp =&gt; 210, time =&gt; 15,  },
&nbsp;&nbsp;&nbsp;&nbsp;)
);

Which produces the highly readable output:

  Warm oven up to 200 degrees.
  Cooking the whole meal will take 108 minutes.
  Add Turkey and cook for 63 minutes
  Add Roast spuds and cook for 29 minutes
  Add Stuffing and cook for 16 minutes

Of course, it's an algorithm, not a cook, so you'll want to use a bit of common sense especially if the range of temperatures was particularly wide - maybe use a meat thermometer to check for a safe internal temperature if you're unsure!

For ultimate laziness, I have a little web interface on my home server which presents various stats and CRUD interfaces etc - including one to store the cooking times and temperatures for things I cook commonly, along with a page I can go and tick the things I'm planning to cook, hit submit, and the stored times and temperatures are passed to Convert::CookingTimes to produce a list of steps to follow easily. Now, if I can just automate the actual cooking away too... hmm, I wonder if that food delivery website Just Eat has an API...

Improving User Messages

2015-12-05T00:00:00Z

Better Messages Please

The new product owner was determined to make an impression on the site as quickly as possible, so she produced a list of "quick wins" for us to work on. Number one on her list was the quality of our error messages.

Like pretty much every piece of software, our error messages suck. When users enter data, we validate it and tell them if there were any problems. We display messages like "1 error(s) were found". It's down to programmer laziness of course. And the wrong kind of laziness at that. But it seemed to be a simple enough thing to fix.

I moved the ticket into "in progress" and reached for Lingua::EN::Inflect, only to find something interesting: Lingua::EN::Inflect is now in maintenance mode and has been superceeded by a new module called Lingua::EN::Inflexion. The notice in Lingua::EN::Inflect says that the new module "offers a cleaner and more convenient interface, has many more features (including plural->singular inflexions), and is also much better tested". It's written by Damian Conway, so those claims seem likely to be accurate. I settled down to read the documentation.

Singulars and Plurals

The problem with the message is that it doesn't know whether it needs to use singular or plural versions of the words in the text. Lingua::EN::Inflexion makes it easy to start with a singular noun and get the plural version.

use Lingua::EN::Inflexion;

my @singulars = qw[cow pig sheep];

foreach (@singulars) {
&nbsp;&nbsp;say &quot;$_ -&gt; &quot;, noun($_)-&gt;plural;
}

Which gives us:

    cow -&gt; cows
    pig -&gt; pigs
    sheep -&gt; sheep

We can also go in the other direction.

use Lingua::EN::Inflexion;

my @plurals = qw[cows pigs sheep];

foreach (@plurals) {
&nbsp;&nbsp;say &quot;$_ -&gt; &quot;, noun($_)-&gt;singular;
}

This outputs:

    cows -&gt; cow
    pigs -&gt; pig
    sheep -&gt; sheep

You can also ask the object whether its invocant was singular or plural.

use Lingua::EN::Inflexion;

my @nouns = qw[cow pigs sheep];

foreach (@nouns) {
&nbsp;&nbsp;say &quot;$_ is singular&quot; if noun($_)-&gt;is_singular;
&nbsp;&nbsp;say &quot;$_ is plural&quot;   if noun($_)-&gt;is_plural;
}

This will tell us:

    cow is singular
    pigs is plural
    sheep is singular
    sheep is plural

Notice that, unsurprisingly, "sheep" is both singular and plural.

You can also use the as_regex() to get a regex that matches both the singular and plural versions of the noun.

use Lingua::EN::Inflexion;

my $string = 'Ermintrude is the best of all the cows';

if ($string =~ noun('cow')-&gt;as_regex) {
&nbsp;&nbsp;say $&amp;;
}

$& will contain "cows", not "cow". And it's even cleverer than that.

use Lingua::EN::Inflexion;

my $string = 'Ermintrude is ye best of all ye kine';

if ($string =~ noun('cow')-&gt;as_regex) {
&nbsp;&nbsp;say $&amp;;
}

Because "kine" is an obscure old plural for "cow".

If you print the value returned from noun('cow')->as_regex, you'll see that it is (?^i:kine|cows|cow) - so it's case insensitive too.

Verbs and Adjectives

Lingua::EN::Inflexion doesn't just work on nouns. You can inflect verbs and adjectives too using the verb() and adj() constructors.

my @verbs = qw[is has sits];

for (@verbs) {
&nbsp;&nbsp;say &quot;The plural of $_ is &quot; . verb($_)-&gt;plural;
}

Which produces:

    The plural of is is are
    The plural of has is have
    The plural of sits is sit

And

my @adjectives = qw[my your his];

for (@adjectives) {
&nbsp;&nbsp;say &quot;The plural of $_ is &quot; . adj($_)-&gt;plural;
}

Which gives:

    The plural of my is our
    The plural of your is your
    The plural of his is their

For more complex requirements, you can get the present participle, past tense and past participle of verbs.

my @verbs = qw[is has sits];

for (@verbs) {
&nbsp;&nbsp;say &quot;The present participle of $_ is &quot; . verb($_)-&gt;pres_part;
&nbsp;&nbsp;say &quot;The past tense of $_ is &quot; . verb($_)-&gt;past;
&nbsp;&nbsp;say &quot;The past participle of $_ is &quot; . verb($_)-&gt;past_part. &quot;\n&quot;;
}

Which produces:

The present participle of is is being
The past tense of is is was
The past participle of is is been

The present participle of has is having
The past tense of has is had
The past participle of has is had

The present participle of sits is sitting
The past tense of sits is sat
The past participle of sits is sat

Building a Message

So now we have all of the pieces that we need to construct our message. We need to know how many errors were found. Let's assume that's in $count. Then our code looks like this:

my $msg = &quot;$count &quot;;

if ($count == 1) {
&nbsp;&nbsp;$msg .= noun('error')-&gt;singular;
} else {
&nbsp;&nbsp;$msg .= noun('error')-&gt;plural'
}
$msg =. ' ';
if ($count == 1) {
&nbsp;&nbsp;$msg .= verb('was')-&gt;singular;
} else {
&nbsp;&nbsp;$msg .= verb('was')-&gt;plural'
}
$msg =. ' found';

Now you can start to see why so many systems make do with the terrible messages that we are trying to get rid of here. It's just too complicated to write code like this every time you want to display a message to the user.

You can try to make it a little simpler, I suppose.

my $cardinality = ($count == 1 ? 'singular' : 'plural');
my $msg = &quot;$count &quot;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;. noun('error')-&gt;$cardinality
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;. ' '
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;. verb('was')-&gt;$cardinality
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;. ' was found';

But it's really not that much better. There has to be a better way. And, of course, that's really why I'm writing this article.

Inflecting Sentences

Lingua::EN::Inflexion exports four routines. We've seen three of them (noun(), verb(), and adj()). The fourth one is called inflect() and that's the one which solves our problem and gives us our "quick win".

The subroutine takes a single string argument, where the string contains some special markup defining how you want the string processed. This string is expanded into a new string which is then returned.

In the simplest case, you would use it like this:

use Lingua::EN::Inflexion;

for (0 .. 3) {
&nbsp;&nbsp;say inflect(&quot;&lt;#:$_&gt; &lt;N:error&gt; &lt;V:was&gt; found&quot;);
}

The output is:

    0 errors were found
    1 error was found
    2 errors were found
    3 errors were found

Simply by changing the number that is interpolated into the string, the noun and verb have both been changed appropriately.

We have used three of inflect()'s special mark-up tags here. <#:...> sets and displays the number which will be used in the rest of the output and <N:...> and <V:...> can be used to insert nouns and verbs which will be inflected. There's a fourth tag, <A:...> which can be used for adjectives, as you can see in this (slightly contrived) example.

use Lingua::EN::Inflexion;

for (1 .. 3) {
&nbsp;&nbsp;say inflect(&quot;The report had &lt;#:$_&gt; &lt;N:authors&gt; &quot; .
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&quot;&lt;A:our&gt; recommendations are ... &quot;);
}

Which produces the following output:

    The report had 1 author my recommendations are ... 
    The report had 2 authors our recommendations are ... 
    The report had 3 authors our recommendations are ...

Improving the Output

This is already much better than the output than you get from many programs, but there are easy ways to make it better. We can start by displaying "No" rather than "0". This is achieved by adding an n option to the <#:...> tags. Options are added between the command character (the #, N, V or A) and the colon.

use Lingua::EN::Inflexion;

for (0 .. 3) {
&nbsp;&nbsp;say inflect(&quot;&lt;#n:$_&gt; &lt;N:error&gt; &lt;V:was&gt; found&quot;);
}

This gives us:

    no errors were found
    1 error was found
    2 errors were found
    3 errors were found

Some people prefer that zero items are displayed as singular rather than plural. We can accommodate that by using s instead of n.

use Lingua::EN::Inflexion;

for (0 .. 3) {
&nbsp;&nbsp;say inflect(&quot;&lt;#s:$_&gt; &lt;N:error&gt; &lt;V:was&gt; found&quot;);
}

The output then changes to:

    no error was found
    1 error was found
    2 errors were found
    3 errors were found

If you would rather have "a" or "an" when the count is one, then you can use a (and you can stack options, so you can use it in addition to either n or s).

use Lingua::EN::Inflexion;

for (0 .. 3) {
&nbsp;&nbsp;say inflect(&quot;&lt;#na:$_&gt; &lt;N:error&gt; &lt;V:was&gt; found&quot;);
}

Which gives us:

    no errors were found
    an error was found
    2 errors were found
    3 errors were found

It's quite common to spell out the numbers when the count is small. If you use the w option, then inflect() will do that for numbers up to 10.

use Lingua::EN::Inflexion;

for (0 .. 2, 9 .. 11) {
&nbsp;&nbsp;say inflect(&quot;&lt;#naw:$_&gt; &lt;N:error&gt; &lt;V:was&gt; found&quot;);
}

The output is:

    no errors were found
    an error was found
    two errors were found
    nine errors were found
    ten errors were found
    11 errors were found

Finally, you can use f to get fuzzy descriptions of the numbers.

use Lingua::EN::Inflexion;

for (0, 1, 2, 4, 7, 10) {
&nbsp;&nbsp;say inflect(&quot;&lt;#f:$_&gt; &lt;N:error&gt; &lt;V:was&gt; found&quot;);
}

Which gives us:

    no errors were found
    one error was found
    a couple of errors were found
    a few errors were found
    several errors were found
    many errors were found

Finally - A Real Quick Win

Users have become used to the "1 error(s) was found" style of message because it is ubiquitous. And that's because fixing the problem isn't exactly hard, it's just tedious. There's too much code to write to fix one small niggle in the user experience. Mostly, we think it's not worth the effort.

But the inflect() subroutine fixes that. Now getting it right is as trivial as it should be. That's the right kind of laziness. Damian was obviously getting bored of writing all of that code every time he wanted a grammatically satisfying user message, so he decided to fix the problem by writing a solution that he (and, through the wonder of CPAN, everyone else) could use to easily produce vastly improved messages.

So our product manager got her quick win. And now yours can too.

And your users will get a much better user experience.

Help! Rudolf's Nose Won't Light Up!

2015-12-04T00:00:00Z

Often we find ourselves writing code that copes with optional dependencies; Code that will use a module to do amazing things if it's installed, but will muddle through with some lesser code path if that dependency is missing or unavailable on the system. When developing this code we need to test how the code works in both situations, preferably without breaking parts of our system setup just to check that the alternative code paths still work!

How can we do this? Gather round, I have a story to tell...

A Christmas Tale

At the north pole Cyber-Santa was in a bit of a pickle because he'd forgotten to charge the batteries for his new Robo-Reindeer's light-up nose! How would he be able to find his way through the dark and deliver techno-toys to all the good programmers and sysadmins?

Cyber-Santa was stressing out and whining on Twitter when one of his older elves reminded him that cost over-runs on the Reindeer Upgrade Project meant that he was still using the old sleigh, and that still had mounting brackets for old oil lamps.

"But do we know that those lamps still work? Are they bright enough?", Cyber-Santa asked

"Oh yes", replied the elf. "Don't you remember, last Christmas we weren't sure whether all the new Robo-Reindeer would be ready in time, so we did our test run both with and without cybernetic cervids, and everything worked just fine."

"Let me show you how we tested this", said the elf elaborated, "I'll take you step by step through what we normally do. First, we dig the sleigh out from under that snowdrift. Would you mind doing it, only my poor old back is giving me gyp right now....and then could you fetch the reindeer and attach them to the sleigh?",

So Santa dug out the sleigh, fetched the reindeer, got kicked by the reindeer, harnessed them and finally climbed up into the driver's seat, all sweaty and bruised and smelling of reindeer.

"So at this point, we're ready to go, right?" asked the elf.

"Yes!", said Cyber-Santa.

"Wrong!", replied the elf, "We're not yet ready. If you turn to page two of your Sleigh Operations Manual you'll see the pre-flight checklist. The ninety fourth item on the list (after 'are the presents tied down?' and 'do you have banging choonz queued up on your iPod?') is 'is the robot providing sufficient lighting to navigate by?'".

And so Santa checked, and the glowing Robo-NoZe™ wasn't working because of that flat battery.

"And after checklist item ninety four it tells you that if it isn't working you should use an oil lamp, doesn't it", scolded the elf.

Santa looked a bit sheepish and apologised, muttering something about being too eager to get his deliveries done so he could relax with a pint and some pork scratchings.

"I'll let you off this time", scolded the elf, "but don't do it again."

"But ... but ..." Santa said hesitantly "how do we know it will work?"

"Oh, right, I was going to show you how we tested this wasn't I. Sorry, I'm getting forgetful in my old age. Let's go indoors and simulate it on your laptop where it'll be nice and warm" smirked the elf, who really preferred the previous Santa, because the elf's children got to play with left over toys and far preferred traditional wooden blocks and balls and things instead of the modern nonsense that Cyber-Santa was obsessed with.

Modeling With Perl

"First let's simulate what you just did", said the elf. "We'll create a sleigh object, and a factory class to simulate the field that the reindeer come from.

my $sleigh   = Sleigh-&gt;new();
my @reindeer = ReindeerFactory-&gt;fetch(9);

"Then we'll harness the reindeer to the sleigh and have the sleigh run through the pre-flight checks because you're so forgetful. Then, once the pre-flight checks are complete we can get going:

$sleigh-&gt;harness(@reindeer);
if ($sleigh-&gt;pre_flight()) {
  # FIXME, deliver presents here
}

"So far, so simple. Now, consider that right now your pasture contains Robo-Reindeer, but previously it contained normal reindeer. So the ReindeerFactory has to look something like this:

package ReindeerFactory;

my $reindeer_class = eval &quot;use RoboReindeer&quot; ? &quot;RoboReindeer&quot; :
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;eval &quot;use BioReindeer&quot;  ? &quot;BioReindeer&quot;  :
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;die(&quot;No reindeer found\n&quot;);

sub fetch {
&nbsp;&nbsp;my $number_wanted = shift;
&nbsp;&nbsp;return (($reindeer_class-&gt;new()) x $number_wanted);
}

"I see", said Santa, "so if the RoboReindeer module is installed (or if in real life I've got RoboReindeer in the pasture) then the factory will give me those, otherwise it'll give me BioReindeer. Very clever. That looks like a pain to test though."

"Yes, unfortunately it is" admitted the elf. "We had to run through the whole damned process twice, once for Robo-Reindeer, once for normal ones, being very careful to keep the two completely separate."

Santa was very thankful that he had elves to do that sort of hard work for him, but thought that it looked like a jolly useful technique for some of his hobby projects. "If only I could automate that in Perl..." mused Santa. But he put that aside, because he had a busy two days ahead of him.

Magic in @INC

After he'd done his two days work for the whole year, and was stretched out on the sofa with a glass of brandy and some mince pies, Santa was still wondering how to automate that. Obviously he could wrap all his tests in a shell script that would install/uninstall modules as appropriate, but that seemed terribly inelegant. But then it dawned on him - all he needed to do was interfere with how Perl loaded modules.

Normally the @INC array is just a list of directories in which perl will look, one directory after another, for modules that you try to use. But you can also put code-refs in it. For example:

  $ perl -E &#39;
    BEGIN { unshift @INC, sub { say &quot;Hello World&quot; } }
    use Foo;
  &#39;
  Hello World
  [loud complaining from perl]

(NB the BEGIN block is required so that we get to diddle @INC at compile- time. The complaining from perl is because say returns something that perl doesn't know what to do with)

When Perl finds a code-ref in @INC it passes the desired module to the code- ref, with its name reformatted from something like Foo::Bar to a filename like Foo/Bar.pm. Your code-ref can then decide not to do anything, thus making perl look in the next place listed in @INC, or it can return the source code for a module:

To have your sub-routine do nothing and have Perl carry on to the next entry in @INC have it return undef:

  $ perl -E &#39;
    BEGIN { unshift @INC, sub { return undef } }
    use File::Temp;
  &#39;

That code-ref has absolutely no effect - when Perl tries to use File::Temp it first executes our subroutine, which returns undef, so Perl then tries to load it from the directories that make up the rest of the list, and eventually succeeds.

So what if we want to prevent File::Temp from loading? Our @INC hook has to return an open filehandle which Perl can read the module code from, and the code we return (which Perl will then read and execute as if it were the File::Temp module) should just die instead:

  $ perl -E &#39;
    BEGIN { unshift @INC, sub {
      # is this what we&#39;re hiding?  return an alternative file-handle
      if ($_[1] eq &quot;File/Temp.pm&quot;) {
        open my $fh, &quot;&lt;&quot;, \&quot;die(qq{$_[1] is hidden})&quot;;
        return $fh;
      }

      # not something we&#39;re hiding, return undef so Perl will continue as normal
      return undef;
    } }
    use File::Temp;
  &#39;
  File/Temp.pm is hidden at /loader/0x7ffe498186e8/File/Temp.pm line 1.
  Compilation failed in require at -e line 8.
  BEGIN failed--compilation aborted at -e line 8.

PERL5OPT and -M

Santa was very happy and wrapped this up in a module:

package Without;

sub import {
&nbsp;&nbsp;shift;
  # translate a list of modules to a list of filenames
  my @hidden = map {
&nbsp;&nbsp;&nbsp;&nbsp;s!::!/!g;
&nbsp;&nbsp;&nbsp;&nbsp;&quot;$_.pm&quot;;
&nbsp;&nbsp;} @_;

&nbsp;&nbsp;unshift @INC, sub {
    # $_[0] is this sub-routine itself.
    my $wanted = $_[1];
&nbsp;&nbsp;&nbsp;&nbsp;if(grep { $wanted eq $_ } @hidden) {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;open my $fh, &quot;&lt;&quot;, \&quot;die(qq{$wanted is hidden})&quot;;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;return $fh
&nbsp;&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;&nbsp;return undef;
&nbsp;&nbsp;}
}

1;

So that he could invoke like this to test his code with both RoboReindeer and BioReindeer, with one but not the other, and even without both:

  make test &amp;&amp;
  PERL5OPT=-MWithout=RoboReindeer             make test &amp;&amp;
  PERL5OPT=-MWithout=BioReindeer              make test &amp;&amp;
  PERL5OPT=-MWithout=RoboReindeer,BioReindeer make test

PERL5OPT is an environment variable that contains extra command line arguments that will be passed to any Perl process. -M is used to load a module on the command line, but using it to pass arguments to the module's import()method is less well known.

A few days later

Santa was very pleased with himself and later that week he went to his local Perl Mongers meeting, with his laptop, so that he could show everyone his nifty new trick.

"Oh, you wanted Devel::Hide", they told him, adding that PERL5OPT isn't used in taint-mode and that the trick of using open to turn a scalar into a filehandle didn't work in some really old perls.

"Bother", said Santa, as he deleted his code and installed Devel::Hide from the CPAN. "Ah well, it was fun anyway."

  make test &amp;&amp;
  PERL5OPT=-MDevel::Hide=RoboReindeer             make test &amp;&amp;
  PERL5OPT=-MDevel::Hide=BioReindeer              make test &amp;&amp;
  PERL5OPT=-MDevel::Hide=RoboReindeer,BioReindeer make test

Winter Platypus

2015-12-03T00:00:00Z

The boss (Mr. Claus) asked me to whip up some decorations for the Christmas party, and since this is a modern outfit (as you know we have the the largest toy and child database in the world), cutting some paper snowflakes just wasn't going to impress.

I decided to write a little Perl program to render these three dimensional snowflakes and make them spin around on screen.

Roles

The first step was to create a class that represented a snowflake, and knew how to draw it. As the rendering of the snowflake is distinct from the actual attributes of the snowflake itself, I decided to create separate roles for the model and drawing code and combine these together in the end into one concrete snowflake class.

So, starting with a model to represent the physical characteristics of each snowflake, using a Moose role:

package SnowflakeModel;

use Moose::Role;
&nbsp;&nbsp;
has num_twigs =&gt; (
&nbsp;&nbsp;is =&gt; 'ro', 
&nbsp;&nbsp;isa =&gt; 'Num', 
&nbsp;&nbsp;default =&gt; sub { int(rand 4) + 3 },
);

has pinkie_length =&gt; (
&nbsp;&nbsp;is =&gt; 'ro',
&nbsp;&nbsp;isa =&gt; 'Num',
&nbsp;&nbsp;default =&gt; sub { 0.5 + (rand)/2.0 }
);

has branch_length =&gt; (
&nbsp;&nbsp;is =&gt; 'ro',
&nbsp;&nbsp;isa =&gt; 'Num',
&nbsp;&nbsp;default =&gt; sub { 1.0 + (rand) },
);
&nbsp;&nbsp;
has segments =&gt; (
&nbsp;&nbsp;is =&gt; 'ro',
&nbsp;&nbsp;isa =&gt; 'Int',
&nbsp;&nbsp;default =&gt; sub { int(rand 4) + 2 },
);
&nbsp;&nbsp;
has $_ =&gt; (is =&gt; 'rw', isa =&gt; 'Num', default =&gt; 0.0 )
&nbsp;&nbsp;for qw( x y z );
&nbsp;&nbsp;
has $_ =&gt; (is =&gt; 'rw', isa =&gt; 'Num', default =&gt; 0.0 )
&nbsp;&nbsp;for qw( xspin yspin zspin );

1;

The model keeps track of the number of branches, and twigs (it would be the "leaf" node, but this being a winter party the leaves have obviously fallen).

The next step was to write some code to draw the snowflake. After some tweaking, I decided on a recursive algorithm using OpenGL.

package SnowflakeDraw;

use 5.010;
use Moose::Role;
use GL;
use GLUT;
&nbsp;&nbsp;
requires qw( 
&nbsp;&nbsp;num_twigs pinkie_length branch_length segments
&nbsp;&nbsp;x y z xspin yspin zspin
);
&nbsp;&nbsp;
sub draw_twig {
&nbsp;&nbsp;my($self, $base, $height, $sides) = @_;
&nbsp;&nbsp;glPushMatrix();
&nbsp;&nbsp;&nbsp;&nbsp;glRotated(-90.0, 1.0, 0.0, 0.0);
&nbsp;&nbsp;&nbsp;&nbsp;glutSolidCone($base, $height, $sides, 5);
&nbsp;&nbsp;glPopMatrix();
}
&nbsp;&nbsp;
sub draw_branch {
&nbsp;&nbsp;my($self, $size, $left, $segments) = @_;
&nbsp;&nbsp;$segments //= $self-&gt;segments;
&nbsp;&nbsp;&nbsp;&nbsp;
&nbsp;&nbsp;glPushMatrix();
&nbsp;&nbsp;&nbsp;&nbsp;glPushMatrix();
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glRotated(30, 0.0, 0.0, 1.0);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_branch($size/1.5, $size, int($segments/2)) if $segments &gt; 1;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_twig(0.025, $size, 6);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glRotated(-60, 0.0, 0.0, 1.0);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_branch($size/1.5, $size, int($segments/2)) if $segments &gt; 1;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_twig(0.025, $size, 6);
&nbsp;&nbsp;&nbsp;&nbsp;glPopMatrix();
&nbsp;&nbsp;&nbsp;&nbsp;glTranslated(0.0, $left/($segments*.75), 0.0);
&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_branch(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$size / 1.5,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$left-$left/($segments*.75), 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;int($segments-1)
&nbsp;&nbsp;&nbsp;&nbsp;) if $segments &gt; 1;
&nbsp;&nbsp;glPopMatrix();
}

sub draw {
&nbsp;&nbsp;my($self) = @_;
&nbsp;&nbsp;&nbsp;&nbsp;
&nbsp;&nbsp;glPushMatrix();
&nbsp;&nbsp;&nbsp;&nbsp;glTranslated($self-&gt;x, $self-&gt;y, $self-&gt;z);
&nbsp;&nbsp;&nbsp;&nbsp;glRotated($self-&gt;xspin, 1.0, 0.0, 0.0);
&nbsp;&nbsp;&nbsp;&nbsp;glRotated($self-&gt;yspin, 0.0, 1.0, 0.0);
&nbsp;&nbsp;&nbsp;&nbsp;glRotated($self-&gt;zspin, 0.0, 0.0, 1.0);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
&nbsp;&nbsp;&nbsp;&nbsp;glEnable(GL_COLOR_MATERIAL);
&nbsp;&nbsp;&nbsp;&nbsp;glEnable(GL_BLEND);
&nbsp;&nbsp;&nbsp;&nbsp;glColor4d(0.60, 0.86, 1.0, 0.35);

&nbsp;&nbsp;&nbsp;&nbsp;for(1..$self-&gt;num_twigs) {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glPushMatrix();
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glRotated(360/$self-&gt;num_twigs*($_-1), 0.0, 0.0, 1.0);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_branch(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;pinkie_length/1.25, 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;branch_length/1.25,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_twig(0.05, $self-&gt;branch_length/1.25, 12);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glPopMatrix();
&nbsp;&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
&nbsp;&nbsp;&nbsp;&nbsp;glPushMatrix();
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glRotated(90, 1.0, 0.0, 0.0);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_branch($self-&gt;pinkie_length/1.25, $self-&gt;branch_length/1.25);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glRotated(90, 0.0, 1.0, 0.0);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_branch($self-&gt;pinkie_length/1.25, $self-&gt;branch_length/1.25);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_twig(0.05, $self-&gt;branch_length/1.25, 12);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glRotated(-180, 1.0, 0.0, 0.0);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_branch($self-&gt;pinkie_length/1.25, $self-&gt;branch_length/1.25);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;glRotated(90, 0.0, 1.0, 0.0);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_branch($self-&gt;pinkie_length/1.25, $self-&gt;branch_length/1.25);
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;$self-&gt;draw_twig(0.05, $self-&gt;branch_length/1.25, 12);
&nbsp;&nbsp;&nbsp;&nbsp;glPopMatrix();

&nbsp;&nbsp;&nbsp;&nbsp;glDisable(GL_BLEND);
&nbsp;&nbsp;&nbsp;&nbsp;glDisable(GL_COLOR_MATERIAL);
&nbsp;&nbsp;glPopMatrix();
}

1;

OpenGL is a portable API for drawing 3D graphics with fancy effects. Now I can combine the model and the draw logic into a single Moose class.

package Snowflake;

use Moose;
with ('SnowflakeModel', 'SnowflakeDraw');

sub spin {
&nbsp;&nbsp;my($self, $xdelta, $ydelta, $zdelta) = @_;
&nbsp;&nbsp;$self-&gt;xspin( $self-&gt;xspin + $xdelta );
&nbsp;&nbsp;$self-&gt;yspin( $self-&gt;yspin + $ydelta );
&nbsp;&nbsp;$self-&gt;zspin( $self-&gt;zspin + $zdelta );
}

1;

I've been working on this team for a number of years, and we have frequently had to switch vendors and change implementations many times for various projects. If I have to replace the OpenGL code in the future, this separation of concerns helps ease the transition because the model and draw logic are in separate files, reducing the temptation of mixing them.

OpenGL and Perl

In order to use the GL functions from Perl, I wrote a partial set of GL bindings for Perl using FFI. FFI is a technique for calling code in dynamic libraries from a scripting language like Perl without writing XS, which is tied closely to the internal implementation of Perl itself.

We here at North Pole Inc. are big users of FFI because we don't have many XS programmers, and we often need to call into libraries written in other languages which don't have XS bindings yet. Last year we were using FFI::Raw, which at the time was the only practical FFI available on CPAN.

Over our long summer break this year, an aquatic mammal who was visiting from down under introduced us to FFI::Platypus. We liked it so much we have largely migrated to it for all of our existing FFI code. Here are my bindings for the base OpenGL library.

package GL;

use strict;
use warnings;
use FFI::Platypus;
use FFI::CheckLib qw( find_lib_or_die );
use base qw( Exporter );
&nbsp;
# standard constants defined with Perl

use constant {
&nbsp;&nbsp;GL_SMOOTH              =&gt; 0x1D01,
&nbsp;&nbsp;GL_DEPTH_TEST          =&gt; 0x0B71,
&nbsp;&nbsp;GL_BLEND               =&gt; 0x0BE2,
&nbsp;&nbsp;GL_TRUE                =&gt; 0,
&nbsp;&nbsp;GL_FALSE               =&gt; 0,
&nbsp;&nbsp;GL_LIGHTING            =&gt; 0x0B50,
&nbsp;&nbsp;GL_LIGHT0              =&gt; 0x4000,
&nbsp;&nbsp;GL_DIFFUSE             =&gt; 0x1201,
&nbsp;&nbsp;GL_POSITION            =&gt; 0x1203,
&nbsp;&nbsp;GL_COLOR_BUFFER_BIT    =&gt; 0x00004000,
&nbsp;&nbsp;GL_DEPTH_BUFFER_BIT    =&gt; 0x00000100,
&nbsp;&nbsp;GL_CULL_FACE           =&gt; 0x0B44,
&nbsp;&nbsp;GL_PROJECTION          =&gt; 0x1701,
&nbsp;&nbsp;GL_MODELVIEW           =&gt; 0x1700,
&nbsp;&nbsp;GL_SRC_ALPHA           =&gt; 0x0302,
&nbsp;&nbsp;GL_ONE_MINUS_SRC_ALPHA =&gt; 0x0303,
&nbsp;&nbsp;GL_COLOR_MATERIAL      =&gt; 0x0B57,
};

# wire up FFI::Platypus directly to the binary OpenGL libraries
# (using FFI::CheckLib to find them wherever they are on our system)

our $ffi = FFI::Platypus-&gt;new(
&nbsp;&nbsp;lib =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;$^O eq 'darwin' ? (
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&quot;/System/Library/Frameworks/OpenGL.framework/Libraries/libGL.dylib&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&quot;/System/Library/Frameworks/OpenGL.framework/Libraries/libGLU.dylib&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&quot;/System/Library/Frameworks/GLUT.framework/GLUT&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;) : (
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;find_lib_or_die(lib =&gt; 'glut'),
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;find_lib_or_die(lib =&gt; 'GLU'),
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;find_lib_or_die(lib =&gt; 'GL'),
&nbsp;&nbsp;&nbsp;&nbsp;)
&nbsp;&nbsp;],
);

# declare named shortcuts for the in-built c-types

$ffi-&gt;type('unsigned int' =&gt; 'GLenum');
$ffi-&gt;type('unsigned char' =&gt; 'GLboolean');
$ffi-&gt;type('int' =&gt; 'GLint');
$ffi-&gt;type('double' =&gt; 'GLdouble');
$ffi-&gt;type('float[]' =&gt; 'GLfloat_array');
$ffi-&gt;type('unsigned int' =&gt; 'GLbitfield');
$ffi-&gt;type('int' =&gt; 'GLsizei');

# declare the functions and how their parameters and return
# values should be mapped to Perl scalars

$ffi-&gt;attach( glShadeModel =&gt; ['GLenum'] =&gt; 'void' );
$ffi-&gt;attach( glEnable     =&gt; ['GLenum'] =&gt; 'void' );
$ffi-&gt;attach( glDisable    =&gt; ['GLenum'] =&gt; 'void' );
$ffi-&gt;attach( glPushMatrix =&gt; [] =&gt; 'void' );
$ffi-&gt;attach( glPopMatrix  =&gt; [] =&gt; 'void' );
$ffi-&gt;attach( glFlush      =&gt; [] =&gt; 'void' );
$ffi-&gt;attach( glRotated    =&gt; [ 'GLdouble', 'GLdouble', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLdouble', 'GLdouble' ] =&gt; 'void' );
$ffi-&gt;attach( glTranslated =&gt; ['GLdouble', 'GLdouble', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLdouble' ] =&gt; 'void' );
$ffi-&gt;attach( glColor4d    =&gt; [ 'GLdouble', 'GLdouble', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLdouble', 'GLdouble' ] =&gt; 'void' );
$ffi-&gt;attach( glColor3d    =&gt; [ 'GLdouble', 'GLdouble', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLdouble' ] =&gt; 'void' );
$ffi-&gt;attach( glLightfv    =&gt; [ 'GLenum', 'GLenum', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLfloat_array' ] =&gt; 'void' );
$ffi-&gt;attach( glClear      =&gt; [ 'GLbitfield' ] =&gt; 'void' );
$ffi-&gt;attach( glScaled     =&gt; [ 'GLdouble', 'GLdouble', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLdouble' ] =&gt; 'void' );
$ffi-&gt;attach( glClearColor =&gt; ['float', 'float', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'float', 'float' ] =&gt; 'void' );
$ffi-&gt;attach( glMatrixMode =&gt; [ 'GLenum' ] =&gt; 'void' );
$ffi-&gt;attach( glViewport   =&gt; [ 'GLint', 'GLint', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLsizei', 'GLsizei' ] =&gt; 'void' );
$ffi-&gt;attach( glBlendFunc  =&gt; [ 'GLenum', 'GLenum' ] =&gt; 'void' );
$ffi-&gt;attach( glLoadIdentity =&gt; [] =&gt; 'void' );
$ffi-&gt;attach( gluPerspective =&gt; ['GLdouble','GLdouble',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLdouble','GLdouble'] =&gt; 'void' );

# export those functions to the caller

our @EXPORT = (grep /^(gl|GL_)/i, keys %GL::);

1;

After the usual module imports, you can see the first thing that I've defined are a number of constants which are used by OpenGL. These constants are usually defined in C header (.h) files. This can be problematic if the constants change frequently, but so long as the library is stable and the implementers are not feeling cruel this can be okay.

The next piece of code creates an instance of FFI::Platypus which we will use to create the bindings to the library:

our $ffi = FFI::Platypus-&gt;new(
&nbsp;&nbsp;lib =&gt; [
&nbsp;&nbsp;&nbsp;&nbsp;$^O eq 'darwin' ? (
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&quot;/System/Library/Frameworks/OpenGL.framework/Libraries/libGL.dylib&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&quot;/System/Library/Frameworks/OpenGL.framework/Libraries/libGLU.dylib&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&quot;/System/Library/Frameworks/GLUT.framework/GLUT&quot;,
&nbsp;&nbsp;&nbsp;&nbsp;) : (
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;find_lib_or_die(lib =&gt; 'glut'),
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;find_lib_or_die(lib =&gt; 'GLU'),
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;find_lib_or_die(lib =&gt; 'GL'),
&nbsp;&nbsp;&nbsp;&nbsp;)
&nbsp;&nbsp;],
);

We need to tell Platypus which dynamic libraries to search in order to find functions, so we are using FFI::CheckLib, which is a portable way of searching for libraries in the usual system locations. It provides a similar interface to the like-named Devel::CheckLib, but is smarter about finding dynamic libraries. We have a mixed environment of OS X and Linux for toy deliveries and testing, so it had to work on both platforms. Although FFI::CheckLib generally works well in Windows, Linux, OS X (and others), the OpenGL libraries on OS X are part of what they call a "framework", which isn't supported by FFI::CheckLib yet, so I hard coded the location of the libraries on that platform.

The next part of the code defines the types used by the library:

$ffi-&gt;type('unsigned int' =&gt; 'GLenum');
...

This line defines GLenum used throughout the GL library. Although you could just use 'unsigned int' throughout your code where GLenum is called for, this makes my code more readable, and it is easier to fix the type in one place if I make a mistake with GLenum.

In general, the type system for Platypus is a bit different than other FFI implementations that I've used. Instead of providing only basic hardware types like "sixteen bit signed integer", Platypus encourages the use of language and platform specific types--typically the same types that are understood by your library interface specifications (In C the header file). For example long is a 32 or 64 bit signed integer depending on your platform and char might be either signed or unsigned! You can even tell Platypus that you are working with Fortran or Rust and use the native types of those languages in your bindings.

Finally in the meat of the module we attach the functions from the library into the GL namespace:

$ffi-&gt;attach( glEnable =&gt; ['GLenum'] =&gt; 'void' );
...
# which is called thusly:
glEnable(GL_LIGHT0);

The attach method takes a function defined in the dynamic library and attaches it as a real Perl subroutine. The advantage to this approach is that the code that calls our GL library doesn't need to know or care that it is using an FFI implementation or an XS one. It just looks like Perl.

I needed some higher level types, like arrays (Platypus supports a number of higher level types like this):

$ffi-&gt;type('float[]' =&gt; 'GLfloat_array');
...
$ffi-&gt;attach( glLightfv    =&gt; [ 'GLenum', 'GLenum',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLfloat_array' ] =&gt; 'void' );
...
glLightfv(GL_LIGHT0, GL_DIFFUSE, [.9, .9, 1.0, 1.0]);
glLightfv(GL_LIGHT0, GL_POSITION, [1.0, 1.0, 1.0, 0.0]);

To do this sort of thing, many FFI implementations require you to create an array object and pass that in as an argument. Unfortunately there is an overhead to creating objects for single use calls like this, and it also exposes unnecessary complexity to your caller.

Finally, this module uses Exporter to export all of its functions to the caller's namespace:

use base qw( Exporter );
...
our @EXPORT = (grep /^(gl|GL_)/i, keys %GL::);

Many libraries implement hundreds of functions and keeping @EXPORT in sync with functions as we add them is very tedious. Instead we use %GL:: which is a special hash that keeps track of the data structures (including subroutines) in the GL namespace. It has to be put at the bottom of the module because %GL:: won't be populated until the attach calls are made.

The last module we need provides the Glut bindings. Glut provides a simple and portable OpenGL focused event loop for applications that do not require anything more complicated.

package GLUT;

use strict;
use warnings;
use 5.010;
use GL ();
use base qw( Exporter );
&nbsp;&nbsp;
use constant {
&nbsp;&nbsp;GLUT_RGB      =&gt; 0x0000,
&nbsp;&nbsp;GLUT_DOUBLE   =&gt; 0x0002,
&nbsp;&nbsp;GLUT_DEPTH    =&gt; 0x0010,
};

my $ffi = $GL::ffi;
&nbsp;&nbsp;
$ffi-&gt;load_custom_type('FFI::Platypus::Type::StringArray' =&gt; 'string_array');

$ffi-&gt;attach( glutInit =&gt; ['int*', 'string_array' ] =&gt; 'void' =&gt; sub {
&nbsp;&nbsp;my($xsub, @args) = @_;
&nbsp;&nbsp;my $size = scalar @args;
&nbsp;&nbsp;$xsub-&gt;(\$size, \@args);
});
&nbsp;&nbsp;
$ffi-&gt;attach( glutInitDisplayMode =&gt; ['unsigned int'] =&gt; 'void' );
$ffi-&gt;attach( glutInitWindowSize  =&gt; ['int', 'int']   =&gt; 'void' );
$ffi-&gt;attach( glutCreateWindow    =&gt; ['string']       =&gt; 'int'  );
$ffi-&gt;attach( glutMainLoop        =&gt; [ ] =&gt; 'void' );
$ffi-&gt;attach( glutSwapBuffers     =&gt; [] =&gt; 'void' );
$ffi-&gt;attach( glutPostRedisplay   =&gt; [] =&gt; 'void' );
$ffi-&gt;attach( glutSolidCone        =&gt; [ 'GLdouble', 'GLdouble', 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'GLint', 'GLint' ] =&gt; 'void' );
&nbsp;&nbsp;
$ffi-&gt;attach( glutDisplayFunc =&gt; [ '()-&gt;void' ] =&gt; 'void' =&gt; sub {
&nbsp;&nbsp;my($xsub, $callback) = @_;
&nbsp;&nbsp;state $closure = $ffi-&gt;closure($callback);
&nbsp;&nbsp;$xsub-&gt;($closure);
});

$ffi-&gt;attach( glutIdleFunc =&gt; [ '()-&gt;void' ] =&gt; 'void' =&gt; sub {
&nbsp;&nbsp;my($xsub, $callback) = @_;
&nbsp;&nbsp;state $closure = $ffi-&gt;closure($callback);
&nbsp;&nbsp;$xsub-&gt;($closure);
});

$ffi-&gt;attach( glutReshapeFunc =&gt; [ '(int,int)-&gt;void' ] =&gt; 'void' =&gt; sub {
&nbsp;&nbsp;my($xsub, $callback) = @_;
&nbsp;&nbsp;state $closure = $ffi-&gt;closure($callback);
&nbsp;&nbsp;$xsub-&gt;($closure);
});
&nbsp;&nbsp;
our @EXPORT = (grep /^(GLUT_|glut)/i, keys %GLUT::);

1;

A few things are interesting here. Firstly, the glutInit() takes an array of C strings as its second argument.

$ffi-&gt;load_custom_type('FFI::Platypus::Type::StringArray' =&gt; 'string_array');

$ffi-&gt;attach( glutInit =&gt; ['int*', 'string_array' ] =&gt; 'void' =&gt; sub {
&nbsp;&nbsp;my($xsub, @args) = @_;
&nbsp;&nbsp;my $size = scalar @args;
&nbsp;&nbsp;$xsub-&gt;(\$size, \@args);
});

Platypus' type system provides most of the common basic types that you will need. A few more specialized types, like arrays of C strings require the use of custom types. Here we are using FFI::Platypus::Type::StringArray which is frequently useful and available on CPAN, but not part of the Platypus core.

Also interesting here is that we are using a wrapper (the last argument to the attach) call. This is to hide some of the messy differences between C and Perl. In C when you pass a dynamic array into a function you have to provide the size of the array as an additional parameter. In Perl, arrays already know how many elements they have. Basically the above code is a short cut for this:

$ffi-&gt;attach( [ glutInit =&gt; '_glutInit'] =&gt; 
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;['int*', 'string_array'  ] =&gt; 'void');

sub glutInit {
&nbsp;&nbsp;my(@args) = @_;
&nbsp;&nbsp;my $size = scalar @args;
&nbsp;&nbsp;_glutInit(\$size, \@args);
}

In this second version we attach glutInit with a different name in Perl and call it from the "real" glutInit.

Also the size of the array is passed in as a pointer to an integer so that Glut can alter its value. Although in this particular case we ignore any changes made by Glut, the scalar $size is updated if glutInit makes a change. This is frequently useful, because a common pattern in C is to pass variables by reference by passing a pointer to that variable.

The last thing that I want to point out is the use of closures:

$ffi-&gt;attach( glutDisplayFunc =&gt; [ '()-&gt;void' ] =&gt; 'void' =&gt; sub {
&nbsp;&nbsp;my($xsub, $callback) = @_;
&nbsp;&nbsp;state $closure = $ffi-&gt;closure($callback);
&nbsp;&nbsp;$xsub-&gt;($closure);
});

Or calling back into Perl from C. This is extremely useful, but it is also a little tricky, because of the different ways that Perl and C manage memory. In C you must explicitly allocate and deallocate all memory. The convention is that the module that allocates a particular object will be responsible for deallocating it as well. In Perl the language itself takes responsibility for deallocating objects when they are no longer used anywhere in the Perl runtime. Unfortunately when we create a closure and pass it into Glut code, there is no way for Perl to keep track of whether or not the closure is still in use by Glut! In order to prevent Perl from reclaiming the subroutine before Glut is done with it, I save the closure into a state variable, which will keep it in scope for the life of the program.

Bringing It All Together

Now that we have all the ingredients, we can write out main script:

use strict;
use warnings;
use GL;
use GLUT;
use Snowflake;

glutInit(@ARGV);
glutInitDisplayMode(GLUT_DOUBLE | GLUT_RGB | GLUT_DEPTH);
glutInitWindowSize(1500,500);
glutCreateWindow('snowflake');
glLightfv(GL_LIGHT0, GL_DIFFUSE, [.9, .9, 1.0, 1.0]);
glLightfv(GL_LIGHT0, GL_POSITION, [1.0, 1.0, 1.0, 0.0]);
glEnable(GL_LIGHT0);
glEnable(GL_LIGHTING);
glEnable(GL_CULL_FACE);
glShadeModel(GL_SMOOTH);
glClearColor(1.0, 1.0, 1.0, 0.0);
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);

glEnable(GL_DEPTH_TEST);

my @flakes = map { Snowflake-&gt;new(z =&gt; -5.0, x =&gt; $_) } ( 2.0, 0.0, -2.0 );

sub display {

&nbsp;&nbsp;glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT);
&nbsp;&nbsp;glLoadIdentity();

&nbsp;&nbsp;$_-&gt;draw for @flakes;

&nbsp;&nbsp;glFlush();
&nbsp;&nbsp;glutSwapBuffers();
}

sub idle {
&nbsp;&nbsp;$flakes[0]-&gt;spin(0.3, 0.6, 0.0);
&nbsp;&nbsp;$flakes[1]-&gt;spin(0.3, 0.0, 0.6);
&nbsp;&nbsp;$flakes[2]-&gt;spin(0.0, 0.3, 0.6);
&nbsp;&nbsp;glutPostRedisplay();
}

sub reshape {
&nbsp;&nbsp;my($x, $y) = @_;
&nbsp;&nbsp;exit if $x == 0 || $y == 0;

&nbsp;&nbsp;glMatrixMode(GL_PROJECTION);
&nbsp;&nbsp;glLoadIdentity();
&nbsp;&nbsp;gluPerspective(30.0, $x / $y, 0.5, 20.0);
&nbsp;&nbsp;glMatrixMode(GL_MODELVIEW);
&nbsp;&nbsp;glViewport(0, 0, $x, $y);
}

glutDisplayFunc(\&amp;display);
glutIdleFunc(\&amp;idle);
glutReshapeFunc(\&amp;reshape);
glutMainLoop();

Notice that thanks to the care of FFI::Platypus and a few wrappers in the GLUT module, our main script doesn't have to know or care that it is using FFI.

I have three pretty snowflakes for the holiday party.

My coworker android friend Mr. Lore also enjoyed it since it reminded him of his friend The Crystalline Entity.

Fast CPAN Module Installation

2015-12-02T00:00:00Z

"This build is taking forever", complained Cookie Cutter, the newest elf to join Santa's Continuous Integration team, "We'll be lucky if it's done by next Christmas, let alone this one!".

"Well, we do use a lot of CPAN modules", Snowstorm, head of the team, explained. "They take a while to install on a new machine, but we're certainly not going to re-write all that code ourselves. I just wish it would install quicker."

"Well," Cookie Cutter smiled, "I might have a way..."

I write Perl everyday with great CPAN modules.

To install modules from the CPAN, I was using cpanm. I love it because it just works. One command not only installs the module, but first installs all the dependencies of that module that aren't already installed, and all the dependencies of those modules, and so on and so on

   shell&gt; cpanm Catalyst

If you develop a serious Perl software, it often depends on hundreds of CPAN modules. In fact, dependence on Catalyst implies dependence on 100+ CPAN modules at least.

Because of this it can take quite a lot of time to install a module with cpanm. This is because cpanm installs them in series, downloading one and examining one module at a time.

Like Cookie Cutter, I always hoped I could install CPAN modules faster.

In Perl QA Hackathon 2015, Tatsuhiko Miyagawa, the author of cpanm, developed Menlo (the code name of cpanm 2.0). And he announced that Menlo would be maintained and released as a regular Perl module in his blog post. This allows us to write Perl code that depends on Menlo. This is exciting, isn't it?

Using Menlo I was finally able to write a CPAN module installer called cpm which installed in parallel. Rather than downloading one module and examining each module one at a time like cpanm does, as soon as cpm has identified multiple dependencies it starts download and install more than one module at once. This parallelism makes cpm faster than any other CPAN module installer.

Are you sure cpm is fast?

As cpm is a module just like any other on the CPAN, its installation is straightforward:

   $ cpanm App::cpm

Now you have cpm! Let's try installing Plack with both cpanm and cpm, and compare their elapsed times. Because cpm does not run test cases, we need to execute cpanm with --notest option in order to get a fair test:

   $ time cpanm -L extlib --notest --quiet Plack
   ...
   real    0m47.705s

Next cpm:

   $ time cpm install Plack
   ...
   real    0m16.629s

Wow, this shows cpm (16sec) is about 3 times faster than cpanm (47sec)!

Of course results will change depending on the situation, so why don't you try it yourself?

TODO

In YAPC::Asia 2015, I could talked with miyagawa about cpanm. Then he said the parallel feature might be merged into cpanm itself. I was really happy to hear that.

To merge cpm into cpanm, there are some TODOs or issues that must be resolved:

cpm will need to support platforms that do not have fork(2) system call. Currently cpm doesn't work on such platforms.
Messy log output (a big issue!) Currently cpm uses Menlo in parallel and the outputs of all the Menlos are just redirected to one file. So outputs are mixed and really messy. I believe the logging is important for stable software. Do you accept the messiness, or do you have any ideas to resolve this?

Meanwhile, back at the North Pole...

"You see", said Cookie Cutter, "cpm is a CPAN module installer which is faster than other CPAN module installers."

"And we can install it just with 'cpanm App::cpm'?", asked Snowstorm, "That's it?"

"Yep! All we need to do is change one line in our installer script to start using it. And hopefully if we and other people find cpm useful and stable, then it may be merged into cpanm itself!""

Where in the World?

2015-12-01T00:00:00Z

Santa had a problem, and the problem was kids. Not that he didn't love the children - far from it, their happiness was why he did what he did after all - but now there were more than ever of them. World population had grown to the point where there were 2.2 billion children who potentially wanted a gift, and that was a lot of mince pies to get through in one night!

To ensure that he'd have time to make all the deliveries he'd taken the unprecedented step of installing agents in homes around the world - elves that sat on shelves - who were able to report on any problem, from waking children to adverse weather conditions, that might slow him down. Traditionally a Shelf Elf would report by flying home each night leading up to Christmas, but on the big night itself the elf would have to report back in real time. Luckily for Santa, so many houses had internet connections that the Elf could use to report issues via a simple web form the Wise Old Elf had set up on the North Pole extranet.

This is where our hero Candy Cane comes in. Candy Cane sighed as he read the story in the latest Elf development sprint: "A proof of concept exists that displays the Shelf Elf reports on a map so that Central Elf Command can coordinate them as Santa moves around the world". 2 points.

Should be straight forward, thought Candy Cane to himself, We agreed in estimation that all I have to do is take the location from each report and feed it to the MapBox JavaScript library, and we'll have a nice map. Easy peasy. With Elf joy in his heart from working on something he loved, he opened up the database schema to see how to get the location from the reports table.

The joy was short lived. With a sinking heart Candy realized that the reports didn't actually contain a location. They just contained the child's name the Elf was responsible for: fine for giving to the magical reindeer who instinctively knew the way to every chimney top, but useless for plotting on a map.

The elf cast his gaze over the other columns, trying to figure out what to do, when his eyes settled on the IP address that the report was submitted from. Hmmm, he thought, just maybe...

GeoIP2

GeoIP2 is the Perl interface to the MaxMind geolocation services, providing a way to map an IP address to, amongst other things, a physical location in the world - perfect for plotting Elf reports on a map based on an IP address alone. MaxMind provides the GeoLite2 databases which anyone can periodically download for free from their website to do offline geolocation.

From Perl this is relatively straight forward to use. First create the reader with the database:

my $reader = GeoIP2::Database::Reader-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;file    =&gt; $MMDB_DATABASE_LOCATION,
&nbsp;&nbsp;&nbsp;&nbsp;locales =&gt; [ 'en' ],
);

Then do a lookup on an IP address:

# lookup where the IP is with the &quot;city&quot; level of precision
my $where = $reader-&gt;city( ip =&gt; $ip );

From this model you can ask for various things, for example the location of the IP:

my $location = $where-&gt;location;
my ($lat, $long) = ($location-&gt;latitude, $location-&gt;longitude);

Or information on the nearest city:

my $nearest_city = $where-&gt;city;
my $city_name = $nearest_city-&gt;name;

All kinds of things that you can render on a map.

MapBox

Once the hard work is out of the way, Candy Cane had the relatively simple job of rendering the reports on a map. While a complicated version would come later, Candy decided for the proof of concept a simple Mojolicious::Lite application that used the MapBox API would be sufficient:

#!/usr/bin/perl

use Mojolicious::Lite;
use 5.18.0;
use GeoIP2::Database::Reader;
use File::Spec::Functions qw(:ALL);
use File::Basename qw(dirname);

my $MAPBOX_TOKEN = 'pk.eyJ1IjoiMnNob3J0cGxhbmzzIiwiYSI6ImNpZmw1ZzdnMTV5aXBpdWx4dDhpbjF6ZGQifQ.C3lPhZeBCapfVSQhpcGsLA';
my $MMDB_DATABASE_LOCATION = catfile(dirname(__FILE__),'GeoLite2-City.mmdb');   

sub report_to_point {
&nbsp;&nbsp;&nbsp;&nbsp;my $report = shift;

&nbsp;&nbsp;&nbsp;&nbsp;state $reader = GeoIP2::Database::Reader-&gt;new(
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;file    =&gt; $MMDB_DATABASE_LOCATION,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;locales =&gt; [ 'en' ],
&nbsp;&nbsp;&nbsp;&nbsp;);

    # lookup where the IP is with the &quot;city&quot; level of precision
    my $where = $reader-&gt;city( ip =&gt; $report-&gt;{ip} );

    # define a &quot;point feature&quot; data structure that MapBox understands
    return {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;type =&gt; 'Feature',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;properties =&gt; {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;title =&gt; $where-&gt;city-&gt;name,
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;description =&gt; $report-&gt;{description},
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;},
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;geometry =&gt; {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;type =&gt; 'Point',
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;coordinates =&gt; [ $where-&gt;location-&gt;longitude, $where-&gt;location-&gt;latitude ],
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;}
&nbsp;&nbsp;&nbsp;&nbsp;};
}

get '/' =&gt; sub {
&nbsp;&nbsp;my $c = shift;

  # get the reports from the database, and turn them into mapbox &quot;points&quot;
  state $pg = Mojo::Pg-&gt;new('postgresql://postgres@/test');
&nbsp;&nbsp;my $features = $pg-&gt;db
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;query('SELECT * FROM reports')
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;hashes
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt;map(sub { report_to_point($_) });

&nbsp;&nbsp;$c-&gt;render(
&nbsp;&nbsp;&nbsp;&nbsp;features =&gt; $features,
&nbsp;&nbsp;&nbsp;&nbsp;token =&gt; $MAPBOX_TOKEN,
&nbsp;&nbsp;);
} =&gt; 'index';

app-&gt;start;

__DATA__

@@ index.html.ep
% use Mojo::JSON qw(to_json);
&lt;!DOCTYPE html&gt;
&lt;html&gt;
&lt;head&gt;
&lt;meta charset=utf-8 /&gt;
&lt;title&gt;Shelf Elf Reports&lt;/title&gt;
&lt;meta name='viewport' content='initial-scale=1,maximum-scale=1,user-scalable=no' /&gt;
&lt;script src='https://api.mapbox.com/mapbox.js/v2.2.2/mapbox.js'&gt;&lt;/script&gt;
&lt;link href='https://api.mapbox.com/mapbox.js/v2.2.2/mapbox.css' rel='stylesheet' /&gt;
&lt;style&gt;
&nbsp;&nbsp;body { margin:0; padding:0; }
&nbsp;&nbsp;#map { position:absolute; top:0; bottom:0; width:100%; }
&lt;/style&gt;
&lt;/head&gt;
&lt;body&gt;
&lt;div id='map'&gt;&lt;/div&gt;
&lt;script&gt;
L.mapbox.accessToken = '&lt;%= $token %&gt;';

var map = L.mapbox.map('map', 'mapbox.light').setView([29, -26], 2);

var myLayer = L.mapbox.featureLayer().addTo(map);
myLayer.setGeoJSON({
&nbsp;&nbsp;&nbsp;&nbsp;type: 'FeatureCollection',
&nbsp;&nbsp;&nbsp;&nbsp;features: &lt;%== to_json $features %&gt;
});

&lt;/script&gt;
&lt;/body&gt;
&lt;/html&gt;

Wait till Santa sees this thought Candy, laughing to himself how he'd managed to get the map working despite not having what anyone would have traditionally thought of as location data. Santa wouldn't be asking where in the world? the problems were anymore, but he probably would be asking where in the world? had Candy got the brilliant idea to use IP Geolocation.

Perl Advent Calendar 2015

One More Thing

Without You This Would Not Be Possible

The Gift of The CPAN

That One More Thing

The Perl Powered Christmas Tree

The Software

The Hardware

SEE ALSO

Escaping the Basement For Christmas

Slack&#39;s API

Hey You $#%! Fix My Computer!

SEE ALSO

Automate Christmas with Ansible and Perl

The Perl of Christmas Future

Beyond Modern Perl

Enabling Features

Looking At The Experimental Features Used In The Example

The &#39;signature&#39; feature

Postfix Dereferencing, the postderef feature

Standard Features Used In The Example

The say Feature

The state Feature

The fc Feature

In Conclusion

SEE ALSO

Perl and Redis

Redis

Redis::Fast

Cache::Redis

Redis::LeaderBoard

Redis::Namespace

Conclusion

SEE ALSO

Santa Sorts By Example

SEE ALSO

Christmas Wishes

The Problem With JSON

Introducing Sereal

Compression

Scaling Up For More Impressive Results

Even More Compression

Success

No More Leaking Glue

SEE ALSO

Building Santa&#39;s Naughty and Nice List with Stepford

What is Stepford?

Dependencies and Productions

Step Classes

What Goes Into the Naughty and Nice List?

Building our First Step

Atomic File Steps

More Steps

Running Your Steps

Why Stepford?

The Code

See Also

Garlands of YAML and JSON

Keep it short, keep it sweet

Keep it magic, when you need to be l33t

crash kayo zamm splatt

Configuring Your Editor

Configuring Your Terminal Emulator

Making an OS X Service

Keyboard Maestro

Typing Autocompletion

The True Perl Laziness

SEE ALSO:

(JSON::)Paths in the snow

SEE ALSO

Configuration Station

SEE ALSO

Extracting more value out of your script&#39;s comments

SEE ALSO

Just What Are You Installing Now?

cpanfile

Parsing the cpanfile format

Using MetaCPAN to Produce a Full Dependency Tree

Graphing

Conclusion

Slack's API

The 'signature' feature

Postfix Dereferencing, the `postderef` feature

The `say` Feature

The `state` Feature

The `fc` Feature

Building Santa's Naughty and Nice List with Stepford

Extracting more value out of your script's comments

Santa's Mustache

Help! Rudolf's Nose Won't Light Up!

Solving Cookie Cutter's Problem