Many years ago I wrote a simple perl+mysql polling script for work. It collected votes for multiple-choice polls, stored them in a database, and returned a results page. It was so simple and easy to use, we’ve continued using it for YEARS. Every so often we ask a question that is HIGHLY controversial (I’m looking at you NOW) and we are suddenly inundated with votes, causing much of the site to slow down or return errors.

The last time this happened I made some changes to the code that made it more difficult to vote more than once. Part of that involved storing the current vote totals in Memcached instead of asking the database each time. But even with that change, we’re still running a steady 3 or 4 votes per second and would be vulnerable to legitimate spikes in traffic from on-air promotion or something similar.

So today, I’ve reworked the script to run ALL traffic through memcached and NEVER hit the database at all unless memcached is completely unavailable. The basis for this is BroddlIT’s “memcached as simple message queue” at least as far as I can figure from his rough sketch.

The general idea is, there’s a lock, a pointer to the next slot in the queue, and the queue entries themselves.

Getting the lock

This waits up to a second to get the lock by sleeping for 1/1000th of a second between attempts. You can implement multiple queues by varying the $key_prefix. If the loop exits without getting the lock, you have to decide what to do.

  my $key_prefix = "poll-queue";
  my $total_sleep = 1000000;
  while($total_sleep > 0) {
    my $lock_key = $memd->incr("$key_prefix-lock");

    if(!defined $lock_key) { # No key in cache.
      $memd->set("$key_prefix-lock", $lock_key = 1);
      $memd->set("$key_prefix-curr", 0);
      last;
    } elsif($lock_key == 1) { # We got the lock.
      last;
    }

    # Someone else has the lock, so wait 1/1000th of a second.
    $total_sleep -= usleep(1000);
  }
  if($total_sleep <= 0) {
    # You didn't get the lock. Figure something out.
  }

If you make sure you normally hold the lock for a very small amount of time, you can assume that waiting significantly longer than that without success gives you reasonable cause to take over the lock. The only trick there, as you might expect, is that you need to then release it before another process makes the same assumption.

Get Next Key Pointer

The $key_prefix-curr memcached key contains the index of the last entry in the queue. By calling the $memd->incr() method we get the next one and update the memcache at the same time. If for some reason the pointer doesn’t exist, it is created. The $key variable becomes the memcached key for this message.

  my $next_key = $memd->incr("$key_prefix-curr");
  if(!defined($next_key)) { $memd->set("$key_prefix-curr", 1); }
  my $key = sprintf("$key_prefix-key-%d", $next_key);

Store the Message in the Queue

Simple. Run this and the previous step in a loop to insert multiple values. But be careful because the lock is active, so the longer you take the longer you block other requests.

  $memd->set($key, $message);

Release the Lock

This releases the lock, which allows another process to insert its messages.

  $memd->set("$key_prefix-lock", 0);

Reading and Flushing the Queue

Obtain the lock in the same way as above, then get the $key_prefix-curr value and loop from 1. Just make sure you process the values after you release the lock so you don’t block new entries.

  my $last_key = $memd->get("$key_prefix-curr");
  for(my $i=1; $i<=$last_key; $i++) {
    my $key = sprintf("$key_prefix-key-%d", $i);
    push @messages, $memd->get($key);
  }
  $memd->set("$key_prefix-curr", 0);
  $memd->set("$key_prefix-lock", 0);

  process_messages(@messages);

So that’s it. It should require only Cache::Memcached and Time::HiRes.

Update: if you run multiple memcached daemons and connect to them all (allowing key-hash load balancing), you will probably want to set the “no_rehash” flag and add a bit more error checking. If you allow Cache::Memcached to re-hash your keys if a server connection fails, you could end up losing the various keys temporarily.

Advertisements

A method for randomly selecting N values from a finite (but unknown length) list of elements, without replacement. Algorithm is from Taming Uncertainty. This version takes lines of input on STDIN (or files on @ARGV) and selects 20 of them at random and prints the results to STDOUT.

#!/usr/bin/perl

use strict;
my $N = 20;
my $k;
my @r;

while(<>) {
  if(++$k <= $N) {
    push @r, $_;
  } elsif(rand(1) <= ($N/$k)) {
    $r[rand(@r)] = $_;
  }
}

print @r;

Yesterday at work someone was trying to pass traditional Apache SSI directives through an XSL transformation on a Google search appliance. Long story short, they vanished: HTML comments don’t make it out of that device.

Anyway…I had a simple solution. Since we were pumping the Google results through a Perl CGI anyway, there was no reason we couldn’t just output a fake HTML tag which the CGI would then turn into an SSI comment for Apache. This was born <ssi virtual="/foo/bar.html" />.

Then a simple s/<ssi (virtual=\"[^\"]+\")><\/ssi>/<!--#include $1 -->/; in Perl will give something Apache can understand.

That solved the immediate problem, but got me thinking about emulating the full Apache mod_include set of SSI directives using the <ssi> tag. I’m thinking of something like this:

<ssi element="include" virtual="/foo/bar.html" />

<ssi element="set" var="FOO" value="BAR" />

<ssi element="if">
  <ssi_if expr="test_condition">YES!</ssi_if>
  <ssi_elif expr="test_condition">MAYBE!</ssi_elif>
  <ssi_else>NO!</ssi_else>
</ssi>

And with that format, the original version still works if you assume a missing “element” attribute implies element="include". The <!--#if --> block isn’t quite satisfying here — any text nodes inside the <ssi> block but outside the <ssi_(if|elif|else)> blocks would be ignored, but that’s no different than odd content in, say, a <table> that doesn’t actually fall into a cell.

I don’t actually have the Perl that would do the transformation, but it wouldn’t be hard. I’ll wait until someone actually needs it.

mod_perl 2 has an annoying…feature. Because the system environ struct is not thread safe, mod_perl’s perl-script handler unties the %ENV hash from the actual environment. That means, anything that uses the C getenv/setenv/unsetenv functions to read the environment will not see changes that were made to %ENV.

An obvious example is Perl’s localtime function. It actually calls the system localtime function, which uses the C getenv to check the current value of the timezone environment variable TZ. If you try to change the timezone in a mod_perl2 program by assigning to $ENV{TZ}, localtime won’t know it.

The solution is to use the Env::C module and it’s getenv/setenv/unsetenv wrappers. It works fine, but it’s a bit cumbersome. But a simple module, loaded at server-startup time, can wrap the system localtime in a function that takes care of the environment.

package Apache2::Localtime;

use Env::C;
use Exporter;
use strict;

our @ISA = qw(Exporter);
our @EXPORT = qw(localtime);

sub import {
  my $class = shift;
  $class->export('CORE::GLOBAL', 'localtime');
}

sub localtime {
  my $time = shift || time;
  return localtime($time) unless $ENV{TZ};

  my $orig_tz = Env::C::getenv('TZ');
  Env::C::setenv('TZ', $ENV{TZ}, 1);
  my(@ret, $ret);
  if(wantarray) {
    @ret = CORE::localtime($time);
  } else {
    $ret = CORE::localtime($time);
  }
  if(defined $orig_tz) {
    Env::C::setenv('TZ', $orig_tz, 1);
  } else {
    Env::C::unsetenv('TZ');
  }
  return wantarray ? @ret : $ret;
}

1;

Put that in your @INC path at Apache2/Localtime.pm and then add use Apache2::Localtime to a PerlRequire .../initialize.pl script or something similar. The new function should override the built-in localtime and keep your timeonzes in sync.

The code was mostly taken from here.

I’ve been using Memcached for a few weeks, trying to offload some VERY heavy database load. It’s nice and blazing fast, but the implementation is sort of clunky. If I have this simple bit of code:

$key = "foobar";
$val = calculate_val($key);

It turns into this:

$key = "foobar";
$val = $memd->get($key);
if(! defined($val)) {
  $val = calculate_val($key);
  $memd->set($key, $val);
}

Repeatedly I came back to the idea of a get_or_set method that would handle this stuff, but until the obvious solution hit me, I couldn’t get it:

$key = "foobar";
$val = $memd->get_or_set($key, sub { calculate_val($key) });

A simple closure around the actual calculation block which is then passed to the get_or_set method as a callback. If the lookup finds a value the method returns it, otherwise it returns the result of calling the callback function.

The only change to Cache::Memcached is adding the get_or_set function. The easiest way is to just subclass Cache::Memcached:

package My::Memcached
use base qw(Cache::Memcached);
sub get_or_set {
  my $self = shift;
  my($key, $callback) = @_;
  my $val = $self->get($key);
  unless(defined $val) {
    $val = &$callback;
    $self->set($key, $val);
  }
  return $val;
}

1;

Now you have this simple interface:

use My::Memcached;

my $memd = new My::Memcached { servers => [...] };
my $foo = $memd->get_or_set("bar", sub { get_val("bar") });