init

wcmtools/gearman/lib/Gearman/Client.pm

@@ -0,0 +1,303 @@
+#!/usr/bin/perl
+
+#TODO: fail_after_idle
+
+package Gearman::Client;
+
+use strict;
+use IO::Socket::INET;
+use Socket qw(IPPROTO_TCP TCP_NODELAY SOL_SOCKET);
+
+use Gearman::Objects;
+use Gearman::Task;
+use Gearman::Taskset;
+use Gearman::JobStatus;
+
+sub new {
+    my ($class, %opts) = @_;
+    my $self = $class;
+    $self = fields::new($class) unless ref $self;
+
+    $self->{job_servers} = [];
+    $self->{js_count} = 0;
+    $self->{sock_cache} = {};
+
+    $self->job_servers(@{ $opts{job_servers} })
+        if $opts{job_servers};
+
+    return $self;
+}
+
+sub new_task_set {
+    my Gearman::Client $self = shift;
+    return Gearman::Taskset->new($self);
+}
+
+# getter/setter
+sub job_servers {
+    my Gearman::Client $self = shift;
+    return $self->{job_servers} unless @_;
+    my $list = [ @_ ];
+    $self->{js_count} = scalar @$list;
+    foreach (@$list) {
+        $_ .= ":7003" unless /:/;
+    }
+    return $self->{job_servers} = $list;
+}
+
+sub _get_task_from_args {
+    my Gearman::Task $task;
+    if (ref $_[0]) {
+	$task = $_[0];
+	Carp::croak("Argument isn't a Gearman::Task") unless ref $_[0] eq "Gearman::Task";
+    } else {
+	my ($func, $arg_p, $opts) = @_;
+	my $argref = ref $arg_p ? $arg_p : \$arg_p;
+	Carp::croak("Function argument must be scalar or scalarref")
+	    unless ref $argref eq "SCALAR";
+	$task = Gearman::Task->new($func, $argref, $opts);
+    }
+    return $task;
+
+}
+
+# given a (func, arg_p, opts?), returns either undef (on fail) or scalarref of result
+sub do_task {
+    my Gearman::Client $self = shift;
+    my Gearman::Task $task = &_get_task_from_args;
+
+    my $ret = undef;
+    my $did_err = 0;
+
+    $task->{on_complete} = sub {
+	$ret = shift;
+    };
+
+    $task->{on_fail} = sub {
+	$did_err = 1;
+    };
+    
+    my $ts = $self->new_task_set;
+    $ts->add_task($task);
+    $ts->wait;
+
+    return $did_err ? undef : $ret;
+
+}
+
+# given a (func, arg_p, opts?) or
+# Gearman::Task, dispatches job in background.  returns the handle from the jobserver, or false if any failure
+sub dispatch_background {
+    my Gearman::Client $self = shift;
+    my Gearman::Task $task = &_get_task_from_args;
+
+    my ($jst, $jss) = $self->_get_random_js_sock;
+    return 0 unless $jss;
+
+    my $req = $task->pack_submit_packet("background");
+    my $len = length($req);
+    my $rv = $jss->write($req, $len);
+
+    my $err;
+    my $res = Gearman::Util::read_res_packet($jss, \$err);
+    return 0 unless $res && $res->{type} eq "job_created";
+    return "$jst//${$res->{blobref}}";
+}
+
+sub get_status {
+    my Gearman::Client $self = shift;
+    my $handle = shift;
+    my ($hostport, $shandle) = split(m!//!, $handle);
+    return undef unless grep { $hostport eq $_ } @{ $self->{job_servers} };
+
+    my $sock = $self->_get_js_sock($hostport)
+        or return undef;
+
+    my $req = Gearman::Util::pack_req_command("get_status",
+                                              $shandle);
+    my $len = length($req);
+    my $rv = $sock->write($req, $len);
+
+    my $err;
+    my $res = Gearman::Util::read_res_packet($sock, \$err);
+    return undef unless $res && $res->{type} eq "status_res";
+    my @args = split(/\0/, ${ $res->{blobref} });
+    return undef unless $args[0];
+    shift @args;
+    $self->_put_js_sock($hostport, $sock);
+    return Gearman::JobStatus->new(@args);
+}
+
+# returns a socket from the cache.  it should be returned to the
+# cache with _put_js_sock.  the hostport isn't verified. the caller
+# should verify that $hostport is in the set of jobservers.
+sub _get_js_sock {
+    my Gearman::Client $self = shift;
+    my $hostport = shift;
+
+    if (my $sock = delete $self->{sock_cache}{$hostport}) {
+        return $sock if $sock->connected;
+    }
+
+    my $sock = IO::Socket::INET->new(PeerAddr => $hostport,
+                                     Timeout => 1)
+        or return undef;
+
+    setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
+    $sock->autoflush(1);
+    return $sock;
+}
+
+# way for a caller to give back a socket it previously requested.
+# the $hostport isn't verified, so the caller should verify the
+# $hostport is still in the set of jobservers.
+sub _put_js_sock {
+    my Gearman::Client $self = shift;
+    my ($hostport, $sock) = @_;
+
+    $self->{sock_cache}{$hostport} ||= $sock;
+}
+
+sub _get_random_js_sock {
+    my Gearman::Client $self = shift;
+    my $getter = shift;
+    return undef unless $self->{js_count};
+
+    $getter ||= sub { my $hostport = shift; return $self->_get_js_sock($hostport); };
+
+    my $ridx = int(rand($self->{js_count}));
+    for (my $try = 0; $try < $self->{js_count}; $try++) {
+        my $aidx = ($ridx + $try) % $self->{js_count};
+        my $hostport = $self->{job_servers}[$aidx];
+        my $sock = $getter->($hostport) or next;
+        return ($hostport, $sock);
+    }
+    return ();
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Gearman::Client - Client for gearman distributed job system
+
+=head1 SYNOPSIS
+
+    use Gearman::Client;
+    my $client = Gearman::Client->new;
+    $client->job_servers('127.0.0.1', '10.0.0.1');
+
+    # running a single task
+    my $result_ref = $client->do_task("add", "1+2");
+    print "1 + 2 = $$result_ref\n";
+
+    # waiting on a set of tasks in parallel
+    my $taskset = $client->new_task_set;
+    $taskset->add_task( "add" => "1+2", {
+       on_complete => sub { ... } 
+    });
+    $taskset->add_task( "divide" => "5/0", {
+       on_fail => sub { print "divide by zero error!\n"; },
+    });
+    $taskset->wait;
+
+
+=head1 DESCRIPTION
+
+I<Gearman::Client> is a client class for the Gearman distributed job
+system, providing a framework for sending jobs to one or more Gearman
+servers.  These jobs are then distributed out to a farm of workers.
+
+Callers instantiate a I<Gearman::Client> object and from it dispatch
+single tasks, sets of tasks, or check on the status of tasks.
+
+=head1 USAGE
+
+=head2 Gearman::Client->new(\%options)
+
+Creates a new I<Gearman::Client> object, and returns the object.
+
+If I<%options> is provided, initializes the new client object with the
+settings in I<%options>, which can contain:
+
+=over 4
+
+=item * job_servers
+
+Calls I<job_servers> (see below) to initialize the list of job
+servers.  Value in this case should be an arrayref.
+
+=back
+
+=head2 $client->job_servers(@servers)
+
+Initializes the client I<$client> with the list of job servers in I<@servers>.
+I<@servers> should contain a list of IP addresses, with optional port
+numbers. For example:
+
+    $client->job_servers('127.0.0.1', '192.168.1.100:7003');
+
+If the port number is not provided, C<7003> is used as the default.
+
+=head2 $client-E<gt>do_task($task)
+
+=head2 $client-E<gt>do_task($funcname, $arg, \%options)
+
+Dispatches a task and waits on the results.  May either provide a
+L<Gearman::Task> object, or the 3 arguments that the Gearman::Task
+constructor takes.
+
+Returns a scalar reference to the result, or undef on failure.
+
+If you provide on_complete and on_fail handlers, they're ignored, as
+this function currently overrides them.
+
+=head2 $client-E<gt>dispatch_background($task)
+
+=head2 $client-E<gt>dispatch_background($funcname, $arg, \%options)
+
+Dispatches a task and doesn't wait for the result.  Return value
+is 
+
+=head2 $taskset = $client-E<gt>new_task_set
+
+Creates and returns a new I<Gearman::Taskset> object.
+
+=head2 $taskset-E<gt>add_task($task)
+
+=head2 $taskset-E<gt>add_task($funcname, $arg, $uniq)
+
+=head2 $taskset-E<gt>add_task($funcname, $arg, \%options)
+
+Adds a task to a taskset.  Three different calling conventions are
+available.
+
+=head2 $taskset-E<gt>wait
+
+Waits for a response from the job server for any of the tasks listed
+in the taskset. Will call the I<on_*> handlers for each of the tasks
+that have been completed, updated, etc.  Doesn't return until
+everything has finished running or failing.
+
+=head1 EXAMPLES
+
+=head2 Summation
+
+This is an example client that sends off a request to sum up a list of
+integers.
+
+    use Gearman::Client;
+    use Storable qw( freeze );
+    my $client = Gearman::Client->new;
+    $client->job_servers('127.0.0.1');
+    my $tasks = $client->new_task_set;
+    my $handle = $tasks->add_task(sum => freeze([ 3, 5 ]), {
+        on_complete => sub { print ${ $_[0] }, "\n" }
+    });
+    $tasks->wait;
+
+See the I<Gearman::Worker> documentation for the worker for the I<sum>
+function.
+
+=cut

wcmtools/gearman/lib/Gearman/JobStatus.pm

@@ -0,0 +1,20 @@
+
+package Gearman::JobStatus;
+
+use strict;
+
+sub new {
+    my ($class, $known, $running, $nu, $de) = @_;
+    undef $nu unless length($nu);
+    undef $de unless length($de);
+    my $self = [ $known, $running, $nu, $de ];
+    bless $self;
+    return $self;
+}
+
+sub known { my $self = shift; return $self->[0]; }
+sub running { my $self = shift; return $self->[1]; }
+sub progress { my $self = shift; return defined $self->[2] ? [ $self->[2], $self->[3] ] : undef; }
+sub percent { my $self = shift; return (defined $self->[2] && $self->[3]) ? ($self->[2] / $self->[3]) : undef; }
+
+1;

wcmtools/gearman/lib/Gearman/Objects.pm

@@ -0,0 +1,52 @@
+use strict;
+
+package Gearman::Client;
+use fields (
+            'job_servers',
+            'js_count',
+            'sock_cache',  # hostport -> socket
+            );
+
+package Gearman::Taskset;
+
+use fields (
+            'waiting',  # { handle => [Task, ...] }
+            'client',   # Gearman::Client
+            'need_handle',  # arrayref
+
+            'default_sock',     # default socket (non-merged requests)
+            'default_sockaddr', # default socket's ip/port
+
+            'loaned_sock',      # { hostport => socket }
+
+            );
+
+
+package Gearman::Task;
+
+use fields (
+            # from client:
+            'func',
+            'argref',
+            # opts from client:
+            'uniq',
+            'on_complete',
+            'on_fail',
+            'on_retry',
+            'on_status',
+            'retry_count',
+            'fail_after_idle',
+            'high_priority',
+
+            # from server:
+            'handle',
+
+            # maintained by this module:
+            'retries_done',
+            'taskset',
+            'jssock',  # jobserver socket.  shared by other tasks in the same taskset,
+                       # but not w/ tasks in other tasksets using the same Gearman::Client
+            );
+
+
+1;

wcmtools/gearman/lib/Gearman/Task.pm

@@ -0,0 +1,210 @@
+package Gearman::Task;
+
+use strict;
+use Carp ();
+use String::CRC32 ();
+
+# constructor, given: ($func, $argref, $opts);
+sub new {
+    my $class = shift;
+
+    my $self = $class;
+    $self = fields::new($class) unless ref $self;
+
+    $self->{func} = shift
+	or Carp::croak("No function given");
+
+    $self->{argref} = shift || do { my $empty = ""; \$empty; };
+    Carp::croak("Argref not a scalar reference") unless ref $self->{argref} eq "SCALAR";
+
+    my $opts = shift || {};
+    for my $k (qw( uniq
+  		   on_complete on_fail on_retry on_status
+		   retry_count fail_after_idle high_priority 
+		   )) {
+        $self->{$k} = delete $opts->{$k};
+    }
+
+    if (%{$opts}) {
+        Carp::croak("Unknown option(s): " . join(", ", sort keys %$opts));
+    }
+
+    $self->{retries_done} = 0;
+
+    return $self;
+}
+
+sub taskset {
+    my Gearman::Task $task = shift;
+
+    # getter
+    return $task->{taskset} unless @_;
+
+    # setter
+    my Gearman::Taskset $ts = shift;
+    $task->{taskset} = $ts;
+
+    my $merge_on = $task->{uniq} && $task->{uniq} eq "-" ?
+        $task->{argref} : \ $task->{uniq};
+    if ($$merge_on) {
+        my $hash_num = _hashfunc($merge_on);
+        $task->{jssock} = $ts->_get_hashed_sock($hash_num);
+    } else {
+        $task->{jssock} = $ts->_get_default_sock;
+    }
+
+    return $task->{taskset};
+}
+
+# returns number in range [0,32767] given a scalarref
+sub _hashfunc {
+    return (String::CRC32::crc32(${ shift() }) >> 16) & 0x7fff;
+}
+
+sub pack_submit_packet {
+    my Gearman::Task $task = shift;
+    my $is_background = shift;
+
+    my $mode = $is_background ?
+	"submit_job_bg" :
+	($task->{high_priority} ?
+	 "submit_job_high" :
+	 "submit_job");
+
+    return Gearman::Util::pack_req_command($mode,
+					   join("\0", $task->{func}, $task->{uniq}, ${ $task->{argref} }));
+}
+
+sub fail {
+    my Gearman::Task $task = shift;
+
+    # try to retry, if we can
+    if ($task->{retries_done} < $task->{retry_count}) {
+        $task->{retries_done}++;
+        $task->{on_retry}->($task->{retries_done}) if $task->{on_retry};
+        $task->handle(undef);
+        return $task->{taskset}->add_task($task);
+    }
+
+    return undef unless $task->{on_fail};
+    $task->{on_fail}->();
+    return undef;
+}
+
+sub complete {
+    my Gearman::Task $task = shift;
+    return unless $task->{on_complete};
+    my $result_ref = shift;
+    $task->{on_complete}->($result_ref);
+}
+
+sub status {
+    my Gearman::Task $task = shift;
+    return unless $task->{on_status};
+    my ($nu, $de) = @_;
+    $task->{on_status}->($nu, $de);
+}
+
+# getter/setter for the fully-qualified handle of form "IP:port//shandle" where
+# shandle is an opaque handle specific to the job server running on IP:port
+sub handle {
+    my Gearman::Task $task = shift;
+    return $task->{handle} unless @_;
+    return $task->{handle} = shift;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Gearman::Task - a task in Gearman, from the point of view of a client
+
+=head1 SYNOPSIS
+
+    my $task = Gearman::Task->new("add", "1+2", {
+            .....
+
+    };
+
+    $taskset->add_task($task);
+    $client->do_task($task);
+    $client->dispatch_background($task);
+
+
+=head1 DESCRIPTION
+
+I<Gearman::Task> is a Gearman::Client's representation of a task to be
+done.
+
+=head1 USAGE
+
+=head2 Gearman::Task->new($func, $arg, \%options)
+
+Creates a new I<Gearman::Task> object, and returns the object.
+
+I<$func> is the function name to be run.  (that you have a worker registered to process)
+
+I<$arg> is an opaque scalar or scalarref representing the argument(s)
+to pass to the distributed function.  If you want to pass multiple
+arguments, you must encode them somehow into this one.  That's up to
+you and your worker.
+
+I<%options> can contain:
+
+=over 4
+
+=item * uniq
+
+A key which indicates to the server that other tasks with the same
+function name and key will be merged into one.  That is, the task
+will be run just once, but all the listeners waiting on that job
+will get the response multiplexed back to them.
+
+Uniq may also contain the magic value "-" (a single hyphen) which
+means the uniq key is the contents of the args.
+
+=item * on_complete
+
+A subroutine reference to be invoked when the task is completed. The
+subroutine will be passed a reference to the return value from the worker
+process.
+
+=item * on_fail
+
+A subroutine reference to be invoked when the task fails (or fails for
+the last time, if retries were specified).  No arguments are
+passed to this callback.  This callback won't be called after a failure
+if more retries are still possible.
+
+=item * on_retry
+
+A subroutine reference to be invoked when the task fails, but is about
+to be retried.
+
+Is passed one argument, what retry attempt number this is.  (starts with 1)
+
+=item * on_status
+
+A subroutine reference to be invoked if the task emits status updates.
+Arguments passed to the subref are ($numerator, $denominator), where those
+are left up to the client and job to determine.
+
+=item * retry_count
+
+Number of times job will be retried if there are failures.  Defaults to 0.
+
+=item * high_priority
+
+Boolean, whether this job should take priority over other jobs already
+enqueued.
+
+=item * fail_after_idle
+
+Automatically fail after this many seconds have elapsed.  Defaults to 0,
+which means never.
+
+=back
+
+=cut

wcmtools/gearman/lib/Gearman/Taskset.pm

@@ -0,0 +1,269 @@
+package Gearman::Taskset;
+
+use strict;
+use Carp ();
+use Gearman::Util;
+
+sub new {
+    my $class = shift;
+    my Gearman::Client $client = shift;
+
+    my $self = $class;
+    $self = fields::new($class) unless ref $self;
+
+    $self->{waiting} = {};
+    $self->{need_handle} = [];
+    $self->{client} = $client;
+    $self->{loaned_sock} = {};
+
+    return $self;
+}
+
+sub DESTROY {
+    my Gearman::Taskset $ts = shift;
+
+    if ($ts->{default_sock}) {
+        $ts->{client}->_put_js_sock($ts->{default_sockaddr}, $ts->{default_sock});
+    }
+
+    while (my ($hp, $sock) = each %{ $ts->{loaned_sock} }) {
+        $ts->{client}->_put_js_sock($hp, $sock);
+    }
+}
+
+sub _get_loaned_sock {
+    my Gearman::Taskset $ts = shift;
+    my $hostport = shift;
+    if (my $sock = $ts->{loaned_sock}{$hostport}) {
+        return $sock if $sock->connected;
+        delete $ts->{loaned_sock}{$hostport};
+    }
+
+    my $sock = $ts->{client}->_get_js_sock($hostport);
+    return $ts->{loaned_sock}{$hostport} = $sock;
+}
+
+sub wait {
+    my Gearman::Taskset $ts = shift;
+
+    while (keys %{$ts->{waiting}}) {
+        $ts->_wait_for_packet();
+        # TODO: timeout jobs that have been running too long.  the _wait_for_packet
+        # loop only waits 0.5 seconds.
+    }
+}
+
+# ->add_task($func, <$scalar | $scalarref>, <$uniq | $opts_hashref>
+#      opts:
+#        -- uniq
+#        -- on_complete
+#        -- on_fail
+#        -- on_status
+#        -- retry_count
+#        -- fail_after_idle
+#        -- high_priority
+# ->add_task(Gearman::Task)
+#
+
+sub add_task {
+    my Gearman::Taskset $ts = shift;
+    my $task;
+
+    if (ref $_[0]) {
+        $task = shift;
+    } else {
+        my $func = shift;
+        my $arg_p = shift;   # scalar or scalarref
+        my $opts = shift;    # $uniq or hashref of opts
+
+        my $argref = ref $arg_p ? $arg_p : \$arg_p;
+        unless (ref $opts eq "HASH") {
+            $opts = { uniq => $opts };
+        }
+
+        $task = Gearman::Task->new($func, $argref, $opts);
+    }
+    $task->taskset($ts);
+
+    my $req = $task->pack_submit_packet;
+    my $len = length($req);
+    my $rv = $task->{jssock}->syswrite($req, $len);
+    die "Wrote $rv but expected to write $len" unless $rv == $len;
+
+    push @{ $ts->{need_handle} }, $task;
+    while (@{ $ts->{need_handle} }) {
+        my $rv = $ts->_wait_for_packet($task->{jssock});
+        if (! $rv) {
+            shift @{ $ts->{need_handle} };  # ditch it, it failed.
+            # this will resubmit it if it failed.
+            print " INITIAL SUBMIT FAILED\n";
+            return $task->fail;
+        }
+    }
+
+    return $task->handle;
+}
+
+sub _get_default_sock {
+    my Gearman::Taskset $ts = shift;
+    return $ts->{default_sock} if $ts->{default_sock};
+
+    my $getter = sub {
+        my $hostport = shift;
+        return
+            $ts->{loaned_sock}{$hostport} ||
+            $ts->{client}->_get_js_sock($hostport);
+    };
+
+    my ($jst, $jss) = $ts->{client}->_get_random_js_sock($getter);
+    $ts->{loaned_sock}{$jst} ||= $jss;
+
+    $ts->{default_sock} = $jss;
+    $ts->{default_sockaddr} = $jst;
+    return $jss;
+}
+
+sub _get_hashed_sock {
+    my Gearman::Taskset $ts = shift;
+    my $hv = shift;
+
+    my Gearman::Client $cl = $ts->{client};
+
+    for (my $off = 0; $off < $cl->{js_count}; $off++) {
+        my $idx = ($hv + $off) % ($cl->{js_count});
+        my $sock = $ts->_get_loaned_sock($cl->{job_servers}[$idx]);
+        return $sock if $sock;
+    }
+
+    return undef;
+}
+
+# returns boolean when given a sock to wait on.
+# otherwise, return value is undefined.
+sub _wait_for_packet {
+    my Gearman::Taskset $ts = shift;
+    my $sock = shift;  # optional socket to singularly read from
+
+    my ($res, $err);
+    if ($sock) {
+        $res = Gearman::Util::read_res_packet($sock, \$err);
+        return 0 unless $res;
+        return $ts->_process_packet($res, $sock);
+    } else {
+        # TODO: cache this vector?
+        my ($rin, $rout, $eout);
+        my %watching;
+
+        for my $sock ($ts->{default_sock}, values %{ $ts->{loaned_sock} }) {
+            next unless $sock;
+            my $fd = $sock->fileno;
+
+            vec($rin, $fd, 1) = 1;
+            $watching{$fd} = $sock;
+        }
+
+        my $nfound = select($rout=$rin, undef, $eout=$rin, 0.5);
+        return 0 if ! $nfound;
+
+        foreach my $fd (keys %watching) {
+            next unless vec($rout, $fd, 1);
+            # TODO: deal with error vector
+            my $sock = $watching{$fd};
+            $res = Gearman::Util::read_res_packet($sock, \$err);
+            $ts->_process_packet($res, $sock) if $res;
+        }
+        return 1;
+
+    }
+}
+
+sub _ip_port {
+    my $sock = shift;
+    return undef unless $sock;
+    my $pn = getpeername($sock) or return undef;
+    my ($port, $iaddr) = Socket::sockaddr_in($pn);
+    return Socket::inet_ntoa($iaddr) . ":$port";
+}
+
+# note the failure of a task given by its jobserver-specific handle
+sub _fail_jshandle {
+    my Gearman::Taskset $ts = shift;
+    my $shandle = shift;
+
+    my $task_list = $ts->{waiting}{$shandle} or
+	die "Uhhhh:  got work_fail for unknown handle: $shandle\n";
+
+    my Gearman::Task $task = shift @$task_list or
+	die "Uhhhh:  task_list is empty on work_fail for handle $shandle\n";
+
+    $task->fail;
+    delete $ts->{waiting}{$shandle} unless @$task_list;
+}
+
+sub _process_packet {
+    my Gearman::Taskset $ts = shift;
+    my ($res, $sock) = @_;
+
+    if ($res->{type} eq "job_created") {
+        my Gearman::Task $task = shift @{ $ts->{need_handle} } or
+            die "Um, got an unexpected job_created notification";
+
+        my $shandle = ${ $res->{'blobref'} };
+	my $ipport = _ip_port($sock);
+
+	# did sock become disconnected in the meantime?
+	if (! $ipport) {
+	    $ts->_fail_jshandle($shandle);
+	    return 1;
+	}
+
+        $task->handle("$ipport//$shandle");
+        push @{ $ts->{waiting}{$shandle} ||= [] }, $task;
+        return 1;
+    }
+
+    if ($res->{type} eq "work_fail") {
+        my $shandle = ${ $res->{'blobref'} };
+	$ts->_fail_jshandle($shandle);
+        return 1;
+    }
+
+    if ($res->{type} eq "work_complete") {
+        ${ $res->{'blobref'} } =~ s/^(.+?)\0//
+            or die "Bogus work_complete from server";
+        my $shandle = $1;
+
+        my $task_list = $ts->{waiting}{$shandle} or
+            die "Uhhhh:  got work_complete for unknown handle: $shandle\n";
+
+        my Gearman::Task $task = shift @$task_list or
+            die "Uhhhh:  task_list is empty on work_complete for handle $shandle\n";
+
+        $task->complete($res->{'blobref'});
+        delete $ts->{waiting}{$shandle} unless @$task_list;
+
+        return 1;
+    }
+
+    if ($res->{type} eq "work_status") {
+        my ($shandle, $nu, $de) = split(/\0/, ${ $res->{'blobref'} });
+
+        my $task_list = $ts->{waiting}{$shandle} or
+            die "Uhhhh:  got work_status for unknown handle: $shandle\n";
+
+        # FIXME: the server is (probably) sending a work_status packet for each
+        # interested client, even if the clients are the same, so probably need
+        # to fix the server not to do that.  just put this FIXME here for now,
+        # though really it's a server issue.
+        foreach my Gearman::Task $task (@$task_list) {
+            $task->status($nu, $de);
+        }
+
+        return 1;
+    }
+
+    die "Unknown/unimplemented packet type: $res->{type}";
+
+}
+
+1;

wcmtools/gearman/lib/Gearman/Util.pm

@@ -0,0 +1,128 @@
+
+package Gearman::Util;
+use strict;
+
+# I: to jobserver
+# O: out of job server
+# W: worker
+# C: client of job server
+# J : jobserver
+our %cmd = (
+            1 =>  [ 'I', "can_do" ],     # from W:  [FUNC]
+            2 =>  [ 'I', "cant_do" ],    # from W:  [FUNC]
+            3 =>  [ 'I', "reset_abilities" ],  # from W:  ---
+	    22 => [ 'I', "set_client_id" ],    # W->J: [RANDOM_STRING_NO_WHITESPACE]
+            4 =>  [ 'I', "pre_sleep" ],  # from W: ---
+
+            6 =>  [ 'O', "noop" ],        # J->W  ---
+            7 =>  [ 'I', "submit_job" ],    # C->J  FUNC[0]UNIQ[0]ARGS
+            21 =>  [ 'I', "submit_job_high" ],    # C->J  FUNC[0]UNIQ[0]ARGS
+            18 => [ 'I', "submit_job_bg" ], # C->J     " "   "  " "
+
+            8 =>  [ 'O', "job_created" ], # J->C HANDLE
+            9 =>  [ 'I', "grab_job" ],    # W->J --
+            10 => [ 'O', "no_job" ],      # J->W --
+            11 => [ 'O', "job_assign" ],  # J->W HANDLE[0]FUNC[0]ARG
+
+            12 => [ 'IO',  "work_status" ],   # W->J/C: HANDLE[0]NUMERATOR[0]DENOMINATOR
+            13 => [ 'IO',  "work_complete" ], # W->J/C: HANDLE[0]RES
+            14 => [ 'IO',  "work_fail" ],     # W->J/C: HANDLE
+
+            15 => [ 'I',  "get_status" ],  # C->J: HANDLE
+            20 => [ 'O',  "status_res" ],  # C->J: HANDLE[0]KNOWN[0]RUNNING[0]NUM[0]DENOM
+
+            16 => [ 'I',  "echo_req" ],    # ?->J TEXT
+            17 => [ 'O',  "echo_res" ],    # J->? TEXT
+
+            19 => [ 'O',  "error" ],       # J->? ERRCODE[0]ERR_TEXT
+            );
+
+our %num;  # name -> num
+while (my ($num, $ary) = each %cmd) {
+    die if $num{$ary->[1]};
+    $num{$ary->[1]} = $num;
+}
+
+sub cmd_name {
+    my $num = shift;
+    my $c = $cmd{$num};
+    return $c ? $c->[1] : undef;
+}
+
+sub pack_req_command {
+    my $type_arg = shift;
+    my $type = $num{$type_arg} || $type_arg;
+    die "Bogus type arg of '$type_arg'" unless $type;
+    my $arg = $_[0] || '';
+    my $len = length($arg);
+    return "\0REQ" . pack("NN", $type, $len) . $arg;
+}
+
+sub pack_res_command {
+    my $type_arg = shift;
+    my $type = int($type_arg) || $num{$type_arg};
+    die "Bogus type arg of '$type_arg'" unless $type;
+    my $len = length($_[0]);
+    return "\0RES" . pack("NN", $type, $len) . $_[0];
+}
+
+# returns undef on closed socket or malformed packet
+sub read_res_packet {
+    my $sock = shift;
+    my $err_ref = shift;
+
+    my $buf;
+    my $rv;
+
+    my $err = sub {
+        my $code = shift;
+        $$err_ref = $code if ref $err_ref;
+        return undef;
+    };
+
+    return $err->("malformed_header") unless sysread($sock, $buf, 12) == 12;
+    my ($magic, $type, $len) = unpack("a4NN", $buf);
+    return $err->("malformed_magic") unless $magic eq "\0RES";
+
+    if ($len) {
+        $rv = sysread($sock, $buf, $len);
+        return $err->("short_body") unless $rv == $len;
+    }
+
+    $type = $cmd{$type};
+    return $err->("bogus_command") unless $type;
+    return $err->("bogus_command_type") unless index($type->[0], "O") != -1;
+
+    return {
+        'type' => $type->[1],
+        'len' => $len,
+        'blobref' => \$buf,
+    };
+}
+
+sub send_req {
+    my ($sock, $reqref) = @_;
+    return 0 unless $sock;
+
+    my $len = length($$reqref);
+    #TODO: catch SIGPIPE
+    my $rv = $sock->syswrite($$reqref, $len);
+    return 0 unless $rv == $len;
+    return 1;
+}
+
+# given a file descriptor number and a timeout, wait for that descriptor to
+# become readable; returns 0 or 1 on if it did or not
+sub wait_for_readability {
+    my ($fileno, $timeout) = @_;
+    return 0 unless $fileno && $timeout;
+
+    my $rin = 0;
+    vec($rin, $fileno, 1) = 1;
+    my $nfound = select($rin, undef, undef, $timeout);
+
+    # nfound can be undef or 0, both failures, or 1, a success
+    return $nfound ? 1 : 0;
+}
+
+1;

wcmtools/gearman/lib/Gearman/Worker.pm

@@ -0,0 +1,366 @@
+#!/usr/bin/perl
+
+#TODO: retries?
+
+use strict;
+use Gearman::Util;
+use Carp ();
+use IO::Socket::INET;
+
+# this is the object that's handed to the worker subrefs
+package Gearman::Job;
+
+use fields (
+            'func',
+            'argref',
+            'handle',
+
+            'jss', # job server's socket
+            );
+
+sub new {
+    my ($class, $func, $argref, $handle, $jss) = @_;
+    my $self = $class;
+    $self = fields::new($class) unless ref $self;
+
+    $self->{func} = $func;
+    $self->{handle} = $handle;
+    $self->{argref} = $argref;
+    $self->{jss} = $jss;
+    return $self;
+}
+
+# ->set_status($numerator, $denominator) : $bool_sent_to_jobserver
+sub set_status {
+    my Gearman::Job $self = shift;
+    my ($nu, $de) = @_;
+
+    my $req = Gearman::Util::pack_req_command("work_status",
+                                              join("\0", $self->{handle}, $nu, $de));
+    return Gearman::Util::send_req($self->{jss}, \$req);
+}
+
+sub argref {
+    my Gearman::Job $self = shift;
+    return $self->{argref};
+}
+
+sub arg {
+    my Gearman::Job $self = shift;
+    return ${ $self->{argref} };
+}
+
+
+package Gearman::Worker;
+use Socket qw(IPPROTO_TCP TCP_NODELAY SOL_SOCKET PF_INET SOCK_STREAM);
+
+use fields (
+            'job_servers',
+            'js_count',
+            'sock_cache',        # host:port -> IO::Socket::INET
+            'last_connect_fail', # host:port -> unixtime
+            'down_since',        # host:port -> unixtime
+            'connecting',        # host:port -> unixtime connect started at
+            'can',               # func -> subref
+	    'client_id',         # random identifer string, no whitespace
+            );
+
+sub new {
+    my ($class, %opts) = @_;
+    my $self = $class;
+    $self = fields::new($class) unless ref $self;
+
+    $self->{job_servers} = [];
+    $self->{js_count} = 0;
+    $self->{sock_cache} = {};
+    $self->{last_connect_fail} = {};
+    $self->{down_since} = {};
+    $self->{can} = {};
+    $self->{client_id} = join("", map { chr(int(rand(26)) + 97) } (1..30));
+
+    $self->job_servers(@{ $opts{job_servers} })
+        if $opts{job_servers};
+
+    return $self;
+}
+
+sub _get_js_sock {
+    my Gearman::Worker $self = shift;
+    my $ipport = shift;
+
+    if (my $sock = $self->{sock_cache}{$ipport}) {
+        return $sock if getpeername($sock);
+        delete $self->{sock_cache}{$ipport};
+    }
+
+    my $now = time;
+    my $down_since = $self->{down_since}{$ipport};
+    if ($down_since) {
+        my $down_for = $now - $down_since;
+        my $retry_period = $down_for > 60 ? 30 : (int($down_for / 2) + 1);
+        if ($self->{last_connect_fail}{$ipport} > $now - $retry_period) {
+            return undef;
+        }
+    }
+
+    return undef unless $ipport =~ /(^\d+\..+):(\d+)/;
+    my ($ip, $port) = ($1, $2);
+
+    my $sock;
+    socket $sock, PF_INET, SOCK_STREAM, IPPROTO_TCP;
+    #IO::Handle::blocking($sock, 0);
+    connect $sock, Socket::sockaddr_in($port, Socket::inet_aton($ip));
+
+    #my $sock = IO::Socket::INET->new(PeerAddr => $ip,
+    #                                 Timeout => 1);
+    unless ($sock) {
+        $self->{down_since}{$ipport} ||= $now;
+        $self->{last_connect_fail}{$ipport} = $now;
+        return undef;
+    }
+    delete $self->{last_connect_fail}{$ipport};
+    delete $self->{down_since}{$ipport};
+    $sock->autoflush(1);
+    setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
+
+    $self->{sock_cache}{$ipport} = $sock;
+
+    my $cid_req = Gearman::Util::pack_req_command("set_client_id", $self->{client_id});
+    Gearman::Util::send_req($sock, \$cid_req);
+
+    # get this socket's state caught-up
+    foreach my $func (keys %{$self->{can}}) {
+        unless (_set_capability($sock, $func, 1)) {
+            delete $self->{sock_cache}{$ipport};
+            return undef;
+        }
+    }
+
+    return $sock;
+}
+
+sub _set_capability {
+    my ($sock, $func, $can) = @_;
+
+    my $req = Gearman::Util::pack_req_command($can ? "can_do" : "cant_do",
+                                              $func);
+    return Gearman::Util::send_req($sock, \$req);
+}
+
+# tell all the jobservers that this worker can't do anything
+sub reset_abilities {
+    my Gearman::Worker $self = shift;
+    my $req = Gearman::Util::pack_req_command("reset_abilities");
+    foreach my $js (@{ $self->{job_servers} }) {
+        my $jss = $self->_get_js_sock($js);
+        unless (Gearman::Util::send_req($jss, \$req)) {
+            delete $self->{sock_cache}{$js};
+        }
+    }
+
+    $self->{can} = {};
+}
+
+# does one job and returns.  no return value.
+sub work {
+    my Gearman::Worker $self = shift;
+    my $grab_req = Gearman::Util::pack_req_command("grab_job");
+    my $presleep_req = Gearman::Util::pack_req_command("pre_sleep");
+    my %fd_map;
+
+    while (1) {
+
+        my @jss;
+        my $need_sleep = 1;
+
+        foreach my $js (@{ $self->{job_servers} }) {
+            my $jss = $self->_get_js_sock($js)
+                or next;
+
+            unless (Gearman::Util::send_req($jss, \$grab_req) &&
+                    Gearman::Util::wait_for_readability($jss->fileno, 0.50)) {
+                delete $self->{sock_cache}{$js};
+                next;
+            }
+            push @jss, [$js, $jss];
+
+            my ($res, $err);
+            do {
+                $res = Gearman::Util::read_res_packet($jss, \$err);
+            } while ($res && $res->{type} eq "noop");
+
+            next unless $res;
+
+            if ($res->{type} eq "no_job") {
+                next;
+            }
+
+            die "Uh, wasn't expecting a $res->{type} packet" unless $res->{type} eq "job_assign";
+
+            ${ $res->{'blobref'} } =~ s/^(.+?)\0(.+?)\0//
+                or die "Uh, regexp on job_assign failed";
+            my ($handle, $func) = ($1, $2);
+            my $job = Gearman::Job->new($func, $res->{'blobref'}, $handle, $jss);
+            my $handler = $self->{can}{$func};
+            my $ret = eval { $handler->($job); };
+
+            my $work_req;
+            if (defined $ret) {
+                $work_req = Gearman::Util::pack_req_command("work_complete", "$handle\0" . (ref $ret ? $$ret : $ret));
+            } else {
+                $work_req = Gearman::Util::pack_req_command("work_fail", $handle);
+            }
+
+            unless (Gearman::Util::send_req($jss, \$work_req)) {
+                delete $self->{sock_cache}{$js};
+            }
+            return;
+        }
+
+        if ($need_sleep) {
+            my $wake_vec = 0;
+            foreach my $j (@jss) {
+                my ($js, $jss) = @$j;
+                unless (Gearman::Util::send_req($jss, \$presleep_req)) {
+                    delete $self->{sock_cache}{$js};
+                    next;
+                }
+                my $fd = $jss->fileno;
+                vec($wake_vec, $fd, 1) = 1;
+            }
+
+            # chill for some arbitrary time until we're woken up again
+            select($wake_vec, undef, undef, 10);
+        }
+    }
+
+}
+
+sub register_function {
+    my Gearman::Worker $self = shift;
+    my $func = shift;
+    my $subref = shift;
+
+    my $req = Gearman::Util::pack_req_command("can_do", $func);
+
+    foreach my $js (@{ $self->{job_servers} }) {
+        my $jss = $self->_get_js_sock($js);
+        unless (Gearman::Util::send_req($jss, \$req)) {
+            delete $self->{sock_cache}{$js};
+        }
+    }
+
+    $self->{can}{$func} = $subref;
+}
+
+# getter/setter
+sub job_servers {
+    my Gearman::Worker $self = shift;
+    return $self->{job_servers} unless @_;
+    my $list = [ @_ ];
+    $self->{js_count} = scalar @$list;
+    foreach (@$list) {
+        $_ .= ":7003" unless /:/;
+    }
+    return $self->{job_servers} = $list;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Gearman::Worker - Worker for gearman distributed job system
+
+=head1 SYNOPSIS
+
+    use Gearman::Worker;
+    my $worker = Gearman::Worker->new;
+    $worker->job_servers('127.0.0.1');
+    $worker->register_function($funcname => $subref);
+    $worker->work while 1;
+
+=head1 DESCRIPTION
+
+I<Gearman::Worker> is a worker class for the Gearman distributed job system,
+providing a framework for receiving and serving jobs from a Gearman server.
+
+Callers instantiate a I<Gearman::Worker> object, register a list of functions
+and capabilities that they can handle, then enter an event loop, waiting
+for the server to send jobs.
+
+The worker can send a return value back to the server, which then gets
+sent back to the client that requested the job; or it can simply execute
+silently.
+
+=head1 USAGE
+
+=head2 Gearman::Worker->new(\%options)
+
+Creates a new I<Gearman::Worker> object, and returns the object.
+
+If I<%options> is provided, initializes the new worker object with the
+settings in I<%options>, which can contain:
+
+=over 4
+
+=item * job_servers
+
+Calls I<job_servers> (see below) to initialize the list of job servers.
+
+=back
+
+=head2 $worker->job_servers(@servers)
+
+Initializes the worker I<$worker> with the list of job servers in I<@servers>.
+I<@servers> should contain a list of IP addresses, with optional port numbers.
+For example:
+
+    $worker->job_servers('127.0.0.1', '192.168.1.100:7003');
+
+If the port number is not provided, 7003 is used as the default.
+
+=head2 $worker->register_function($funcname, $subref)
+
+Registers the function I<$funcname> as being provided by the worker
+I<$worker>, and advertises these capabilities to all of the job servers
+defined in this worker.
+
+I<$subref> must be a subroutine reference that will be invoked when the
+worker receives a request for this function. It will be passed a
+I<Gearman::Job> object representing the job that has been received by the
+worker.
+
+The subroutine reference can return a return value, which will be sent back
+to the job server.
+
+=head2 Gearman::Job->arg
+
+Returns the scalar argument that the client sent to the job server.
+
+=head2 Gearman::Job->set_status($numerator, $denominator)
+
+Updates the status of the job (most likely, a long-running job) and sends
+it back to the job server. I<$numerator> and I<$denominator> should
+represent the percentage completion of the job.
+
+=head1 EXAMPLES
+
+=head2 Summation
+
+This is an example worker that receives a request to sum up a list of
+integers.
+
+    use Gearman::Worker;
+    use Storable qw( thaw );
+    use List::Util qw( sum );
+    my $worker = Gearman::Worker->new;
+    $worker->job_servers('127.0.0.1');
+    $worker->register_function(sum => sub { sum @{ thaw($_[0]->arg) } });
+    $worker->work while 1;
+
+See the I<Gearman::Client> documentation for a sample client sending the
+I<sum> job.
+
+=cut