Gearman-1.11/0000755000175000017500000000000011324751023013174 5ustar dormandodormandoGearman-1.11/HACKING0000644000175000017500000000036011262246612014166 0ustar dormandodormandoSubversion is here: http://code.sixapart.com/svn/gearman/ Enjoy. We're not actively hacking on it, though, because it pretty much just works for us. If you have feature requests (or even patches!), let us know (brad@danga.com, etc) Gearman-1.11/TODO0000644000175000017500000000021311262246612013664 0ustar dormandodormando* deal with jobservers timing out (going off net) in the middle of workers doing work and submitting a job, status, grabbing a job, etc Gearman-1.11/Makefile.PL0000644000175000017500000000110211262246612015144 0ustar dormandodormandouse 5.008; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME'=> 'Gearman', 'VERSION_FROM' => 'lib/Gearman/Client.pm', 'PREREQ_PM' => { String::CRC32 => 0, }, # e.g., Module::Name => 1.1 AUTHOR => 'Brad Fitzpatrick ', ABSTRACT => "Client and worker libraries for gearman job dispatch dispatch. Server is in separate package.", ); 1; Gearman-1.11/MANIFEST0000644000175000017500000000101311262260327014323 0ustar dormandodormandoCHANGES HACKING lib/Gearman/Client.pm lib/Gearman/JobStatus.pm lib/Gearman/Objects.pm lib/Gearman/ResponseParser.pm lib/Gearman/ResponseParser/Taskset.pm lib/Gearman/Task.pm lib/Gearman/Taskset.pm lib/Gearman/Util.pm lib/Gearman/Worker.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP This list of files META.yml t/00-use.t t/10-all.t t/20-leaktest.t t/30-maxqueue.t t/40-prefix.t t/50-wait_timeout.t t/51-large_args.t t/60-stop-if.t t/lib/GearTestLib.pm t/TestGearman.pm t/worker.pl t/65-responseparser.t TODO Gearman-1.11/t/0000755000175000017500000000000011324751023013437 5ustar dormandodormandoGearman-1.11/t/TestGearman.pm0000644000175000017500000000527411262246612016223 0ustar dormandodormandopackage TestGearman; use base qw(Exporter); @EXPORT = qw(start_server wait_for_port start_worker respawn_children pid_is_dead PORT %Children $NUM_SERVERS); use strict; use List::Util qw(first);; use IO::Socket::INET; use POSIX qw( :sys_wait_h ); our $Bin; use FindBin qw( $Bin ); # TODO: use a variation of t/lib/GearTestLib::free_port to find 3 free ports use constant PORT => 9050; our $NUM_SERVERS = 1; our %Children; END { kill_children() } sub start_server { my($port) = @_; my @loc = ("$Bin/../../../../server/gearmand", # using svn "$Bin/../../../../../server/gearmand", # using svn and 'disttest' '/usr/bin/gearmand', # where some distros might put it '/usr/sbin/gearmand', # where other distros might put it ); my $server = first { -e $_ } @loc or return 0; my $ready = 0; local $SIG{USR1} = sub { $ready = 1; }; my $pid = start_child([ $server, '-p' => $port, '-n' => $$ ]); $Children{$pid} = 'S'; while (!$ready) { select undef, undef, undef, 0.10; } return $pid; } sub start_worker { my($port, $args) = @_; my $num_servers; unless (ref $args) { $num_servers = $args; $args = {}; } $num_servers ||= $args->{num_servers} || 1; my $worker = "$Bin/worker.pl"; my $servers = join ',', map '127.0.0.1:' . (PORT + $_), 0..$num_servers-1; my $ready = 0; my $pid; local $SIG{USR1} = sub { $ready = 1; }; $pid = start_child([ $worker, '-s' => $servers, '-n' => $$, ($args->{prefix} ? ('-p' => $args->{prefix}) : ()) ]); $Children{$pid} = 'W'; while (!$ready) { select undef, undef, undef, 0.10; } return $pid; } sub start_child { my($cmd) = @_; my $pid = fork(); die $! unless defined $pid; unless ($pid) { exec $^X, '-Iblib/lib', '-Ilib', @$cmd or die $!; } $pid; } sub kill_children { kill INT => keys %Children; } sub wait_for_port { my($port) = @_; my $start = time; while (1) { my $sock = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port"); return 1 if $sock; select undef, undef, undef, 0.25; die "Timeout waiting for port $port to startup" if time > $start + 5; } } sub pid_is_dead { my($pid) = @_; return if $pid == -1; my $type = delete $Children{$pid}; if ($type eq 'W') { ## Right now we can only restart workers. start_worker(PORT, $NUM_SERVERS); } } sub respawn_children { for my $pid (keys %Children) { if (waitpid($pid, WNOHANG) > 0) { pid_is_dead($pid); } } } 1; Gearman-1.11/t/50-wait_timeout.t0000644000175000017500000000244711262246612016573 0ustar dormandodormando#!/usr/bin/perl use strict; use Gearman::Client; use Storable qw( freeze ); use Test::More; use Time::HiRes qw(time); use lib 't'; use TestGearman; # This is testing the MAXQUEUE feature of gearmand. There's no direct # support for it in Gearman::Worker yet, so we connect directly to # gearmand to configure it for the test. if (start_server(PORT)) { plan tests => 3; } else { plan skip_all => "Can't find server to test with"; exit 0; } wait_for_port(PORT); start_worker(PORT); my $client = Gearman::Client->new; isa_ok($client, 'Gearman::Client'); $client->job_servers('127.0.0.1:' . PORT); my $tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); my $failed = 0; my $completed = 0; my %handles; # handle => iter # For a total of 5 events, that will be 20 seconds; till they complete. foreach my $iter (1..5) { my $handle; $handle = $tasks->add_task('long', $iter, { uniq => $iter, on_complete => sub { $completed++; delete $handles{$handle}; diag "Got result for $iter"; }, on_fail => sub { $failed++ }, }); $handles{$handle} = $iter; } $tasks->wait(timeout => 11); my $late_tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); # vim: filetype=perl Gearman-1.11/t/20-leaktest.t0000644000175000017500000000333611262246612015670 0ustar dormandodormando#!/usr/bin/perl use strict; our $Bin; use FindBin qw( $Bin ); use Gearman::Client; use Storable qw( freeze ); use Test::More; use IO::Socket::INET; use POSIX qw( :sys_wait_h ); use List::Util qw(first);; use lib "$Bin/lib"; use GearTestLib; use constant NUM_SERVERS => 3; if (! eval "use Devel::Gladiator; 1;") { plan skip_all => "This test requires Devel::Gladiator"; exit 0; } my $s1 = Test::GearServer->new; if (! $s1) { plan skip_all => "Can't find server to test with"; exit 0; } plan tests => 6; my $client = Gearman::Client->new; $client->job_servers($s1->ipport); my $tasks = $client->new_task_set; my $handle = $tasks->add_task(dummy => 'xxxx', on_complete => sub { die "shouldn't complete"; }, on_fail => sub { warn "Failed...\n"; }); ok($handle, "got handle"); my $sock = IO::Socket::INET->new(PeerAddr => $s1->ipport); ok($sock, "got raw connection"); my $num = sub { my $what = shift; my $n = 0; print $sock "gladiator all\r\n"; while (<$sock>) { last if /^\./; /(\d+)\s$what/ or next; $n = $1; } return $n; }; is($num->("Gearman::Server::Client"), 2, "2 clients connected (debug and caller)"); my $num_inets = $num->("IO::Socket::INET"); # a server change made this change from 3 to 4... so accept either. just make # sure it decreases by one later... ok($num_inets == 3 || $num_inets == 4, "3 or 4 sockets (clients + listen) (got $num_inets)"); $tasks->cancel; sleep(0.10); my $num_inets2 = $num->("IO::Socket::INET"); is($num_inets2, $num_inets-1, "2 sockets (client + listen)"); is($num->("Gearman::Server::Client"), 1, "1 client connected (debug)"); __END__ eval { $client->do_task(sum => []) }; Gearman-1.11/t/60-stop-if.t0000644000175000017500000000404511262246612015437 0ustar dormandodormando#!/usr/bin/perl use strict; use Gearman::Client; use Storable qw(thaw); use Test::More; use lib 't'; use TestGearman; if (start_server(PORT)) { plan tests => 12; } else { plan skip_all => "Can't find server to test with"; exit 0; } wait_for_port(PORT); start_worker(PORT); my $client = Gearman::Client->new; isa_ok($client, 'Gearman::Client'); $client->job_servers('127.0.0.1:' . PORT); { # If we start up too fast, then the worker hasn't gone 'idle' yet. sleep 1; my $result = $client->do_task('check_stop_if'); my ($is_idle, $last_job_time) = @{thaw($$result)}; is($is_idle, 0, "We shouldn't be idle yet"); is($last_job_time, undef, "No job should have been processed yet"); } { my $result = $client->do_task('check_stop_if'); my ($is_idle, $last_job_time) = @{thaw($$result)}; is($is_idle, 0, "We still shouldn't be idle yet"); isnt($last_job_time, undef, "We should have processed a job now"); my $time_diff = time() - $last_job_time; # On a really slow system this test could fail, maybe. ok($time_diff < 3, "That last job should have been within the last 3 seconds"); } diag "Sleeping for 5 seconds"; sleep 5; { my $result = $client->do_task('check_stop_if'); my ($is_idle, $last_job_time) = @{thaw($$result)}; is($is_idle, 0, "We still shouldn't be idle yet"); isnt($last_job_time, undef, "We should have processed a job now"); my $time_diff = time() - $last_job_time; # On a really slow system this test could fail, maybe. ok($time_diff > 3, "That last job should have been more than 3 seconds ago"); ok($time_diff < 8, "That last job should have been less than 8 seconds ago"); } $client->do_task('work_exit'); sleep 2; # make sure the worker has time to shut down and isn't still in the 'run' loop { my $result = $client->do_task('check_stop_if'); my ($is_idle, $last_job_time) = @{thaw($$result)}; is($is_idle, 0, "We shouldn't be idle yet"); is($last_job_time, undef, "No job should have been processed yet"); } # vim: filetype=perl Gearman-1.11/t/40-prefix.t0000644000175000017500000000431411262246612015350 0ustar dormandodormando#!/usr/bin/perl use strict; use Gearman::Client; use Storable qw( freeze ); use Test::More; use Time::HiRes 'sleep'; use lib 't'; use TestGearman; if (start_server(PORT)) { plan tests => 9; } else { plan skip_all => "Can't find server to test with"; exit 0; } $NUM_SERVERS = 3; for (1..($NUM_SERVERS-1)) { start_server(PORT + $_) } start_worker(PORT, { prefix => 'prefix_a', num_servers => $NUM_SERVERS }); start_worker(PORT, { prefix => 'prefix_b', num_servers => $NUM_SERVERS }); my @job_servers = map { '127.0.0.1:' . (PORT + $_) } 0..$NUM_SERVERS; my $client_a = Gearman::Client->new(prefix => 'prefix_a'); isa_ok($client_a, 'Gearman::Client'); $client_a->job_servers(@job_servers); my $client_b = Gearman::Client->new(prefix => 'prefix_b'); isa_ok($client_b, 'Gearman::Client'); $client_b->job_servers(@job_servers); # basic do_task test is(${$client_a->do_task('echo_prefix', 'beep test')}, 'beep test from prefix_a', 'basic do_task() - prefix a'); is(${$client_b->do_task('echo_prefix', 'beep test')}, 'beep test from prefix_b', 'basic do_task() - prefix b'); is(${$client_a->do_task(Gearman::Task->new('echo_prefix', \('beep test')))}, 'beep test from prefix_a', 'Gearman::Task do_task() - prefix a'); is(${$client_b->do_task(Gearman::Task->new('echo_prefix', \('beep test')))}, 'beep test from prefix_b', 'Gearman::Task do_task() - prefix b'); my %tasks = ( a => $client_a->new_task_set, b => $client_b->new_task_set, ); my %out; for my $k (keys %tasks) { $out{$k} = ''; $tasks{$k}->add_task('echo_prefix' => "$k", { on_complete => sub { $out{$k} .= ${ $_[0] } } }); } $tasks{$_}->wait for keys %tasks; for my $k (sort keys %tasks) { is($out{$k}, "$k from prefix_$k", "taskset from client_$k"); } ## dispatch_background tasks also support prefixing my $bg_task = Gearman::Task->new('echo_sleep', \('sleep prefix test')); my $handle = $client_a->dispatch_background($bg_task); ## wait for the task to be done my $status; my $n = 0; do { sleep 0.1; $n++; diag "still waiting..." if $n == 12; $status = $client_a->get_status($handle); } until $status->percent == 1 or $n == 20; is $status->percent, 1, "Background task completed using prefix"; Gearman-1.11/t/lib/0000755000175000017500000000000011324751023014205 5ustar dormandodormandoGearman-1.11/t/lib/GearTestLib.pm0000644000175000017500000000354311262246612016721 0ustar dormandodormandopackage GearTestLib; use strict; use IO::Socket::INET; use Exporter 'import'; use FindBin; use Carp qw(croak); use vars qw(@EXPORT); @EXPORT = qw(sleep); sub sleep { my $n = shift; select undef, undef, undef, $n; } sub free_port { my $port = shift; my $type = shift || "tcp"; my $sock; while (!$sock) { $sock = IO::Socket::INET->new(LocalAddr => '127.0.0.1', LocalPort => $port, Proto => $type, ReuseAddr => 1); return $port if $sock; $port = int(rand(20000)) + 30000; } return $port; } sub start_child { my($cmd) = @_; my $pid = fork(); die $! unless defined $pid; unless ($pid) { exec 'perl', '-Iblib/lib', '-Ilib', @$cmd or die $!; } $pid; } package Test::GearServer; use List::Util qw(first); my $requested_port = 8999; sub new { my $class = shift; my $port = GearTestLib::free_port(++$requested_port); my @loc = ("$FindBin::Bin/../../../../server/gearmand", # using svn '/usr/bin/gearmand', # where some distros might put it '/usr/sbin/gearmand', # where other distros might put it ); my $server = first { -e $_ } @loc; unless ($server) { warn "Can't find gearmand in any of: @loc\n"; return 0; } my $ready = 0; local $SIG{USR1} = sub { $ready = 1; }; my $pid = GearTestLib::start_child([ $server, '-p' => $port, '-n' => $$ ]); while (!$ready) { select undef, undef, undef, 0.10; } return bless { pid => $pid, port => $port, }, $class; } sub ipport { my $self = shift; return "127.0.0.1:$self->{port}"; } sub DESTROY { my $self = shift; kill 9, $self->{pid} if $self->{pid}; } 1; Gearman-1.11/t/51-large_args.t0000644000175000017500000000231111262246612016156 0ustar dormandodormando#!/usr/bin/perl use strict; use Gearman::Client; use Storable qw( freeze ); use Test::More; use Time::HiRes qw(time); use lib 't'; use TestGearman; # This is testing the MAXQUEUE feature of gearmand. There's no direct # support for it in Gearman::Worker yet, so we connect directly to # gearmand to configure it for the test. if (start_server(PORT)) { plan tests => 3; } else { plan skip_all => "Can't find server to test with"; exit 0; } wait_for_port(PORT); start_worker(PORT); my $client = Gearman::Client->new; isa_ok($client, 'Gearman::Client'); $client->job_servers('127.0.0.1:' . PORT); my $tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); my $arg = "x" x ( 5 * 1024 * 1024 ); $tasks->add_task('long', \$arg, { on_complete => sub { my $rr = shift; if (length($$rr) != length($arg)) { fail("Large job failed size check: got ".length($$rr).", want ".length($arg)); } elsif ($$rr ne $arg) { fail("Large job failed content check"); } else { pass("Large job succeeded"); } }, on_fail => sub { fail("Large job failed"); }, }); $tasks->wait(timeout => 10); # vim: filetype=perl Gearman-1.11/t/10-all.t0000644000175000017500000001643511262246612014627 0ustar dormandodormando#!/usr/bin/perl use strict; use Gearman::Client; use Storable qw( freeze ); use Test::More; use lib 't'; use TestGearman; if (start_server(PORT)) { plan tests => 33; } else { plan skip_all => "Can't find server to test with"; exit 0; } $NUM_SERVERS = 3; for (1..($NUM_SERVERS-1)) { start_server(PORT + $_) } # kinda useless, now that start_server does this for us, but... for (0..($NUM_SERVERS-1)) { ## Sleep, wait for servers to start up before connecting workers. wait_for_port(PORT + $_); } ## Start two workers, look for $NUM_SERVERS job servers, starting at ## port number PORT. start_worker(PORT, $NUM_SERVERS); start_worker(PORT, $NUM_SERVERS); my $client = Gearman::Client->new(exceptions => 1); isa_ok($client, 'Gearman::Client'); $client->job_servers(map { '127.0.0.1:' . (PORT + $_) } 0..$NUM_SERVERS); eval { $client->do_task(sum => []) }; like($@, qr/scalar or scalarref/, 'do_task does not accept arrayref argument'); my $out = $client->do_task(sum => freeze([ 3, 5 ])); is($$out, 8, 'do_task returned 8 for sum'); my $tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); my $sum; my $failed = 0; my $completed = 0; my $handle = $tasks->add_task(sum => freeze([ 3, 5 ]), { on_complete => sub { $sum = ${ $_[0] } }, on_fail => sub { $failed = 1 } }); $tasks->wait; is($sum, 8, 'add_task/wait returned 8 for sum'); is($failed, 0, 'on_fail not called on a successful result'); ## Now try a task set with 2 tasks, and make sure they are both completed. $tasks = $client->new_task_set; my @sums; $tasks->add_task(sum => freeze([ 1, 1 ]), { on_complete => sub { $sums[0] = ${ $_[0] } }, }); $tasks->add_task(sum => freeze([ 2, 2 ]), { on_complete => sub { $sums[1] = ${ $_[0] } }, }); $tasks->wait; is($sums[0], 2, 'First task completed (sum is 2)'); is($sums[1], 4, 'Second task completed (sum is 4)'); ## Test some failure conditions: ## Normal failure (worker returns undef or dies within eval). is($client->do_task('fail'), undef, 'Job that failed naturally returned undef'); ## the die message is available in the on_fail sub my $msg = undef; $tasks = $client->new_task_set; $tasks->add_task('fail_die', undef, { on_exception => sub { $msg = shift }, }); $tasks->wait; like($msg, qr/test reason/, 'the die message is available in the on_fail sub'); ## Worker process exits. is($client->do_task('fail_exit'), undef, 'Job that failed via exit returned undef'); pid_is_dead(wait()); ## Worker process times out (takes longer than timeout seconds). TODO: { todo_skip 'timeout is not yet implemented', 1; is($client->do_task('sleep', 5, { timeout => 3 }), undef, 'Job that timed out after 3 seconds returns failure'); } # Test sleeping less than the timeout is(${$client->do_task('sleep_three', '1:less')}, 'less', 'We took less time than the worker timeout'); # Do it three more times to check that 'uniq' (implied '-') # works okay. 3 more because we need to go past the timeout. is(${$client->do_task('sleep_three', '1:one')}, 'one', 'We took less time than the worker timeout, again'); is(${$client->do_task('sleep_three', '1:two')}, 'two', 'We took less time than the worker timeout, again'); is(${$client->do_task('sleep_three', '1:three')}, 'three', 'We took less time than the worker timeout, again'); # Now test if we sleep longer than the timeout is($client->do_task('sleep_three', 5), undef, 'We took more time than the worker timeout'); # This task and the next one would be hashed with uniq onto the # previous task, except it failed, so make sure it doesn't happen. is($client->do_task('sleep_three', 5), undef, 'We took more time than the worker timeout, again'); is($client->do_task('sleep_three', 5), undef, 'We took more time than the worker timeout, again, again'); # Check hashing on success, first job sends in 'a' for argument, second job # should complete and return 'a' to the callback. { my $tasks = $client->new_task_set; $tasks->add_task('sleep_three', '2:a', { uniq => 'something', on_complete => sub { is(${$_[0]}, 'a', "'a' received") }, on_fail => sub { fail() }, }); sleep 1; $tasks->add_task('sleep_three', '2:b', { uniq => 'something', on_complete => sub { is(${$_[0]}, 'a', "'a' received, we were hashed properly") }, on_fail => sub { fail() }, }); $tasks->wait; } # Check to make sure there are no hashing glitches with an explicit # 'uniq' field. Both should fail. { my $tasks = $client->new_task_set; $tasks->add_task('sleep_three', '10:a', { uniq => 'something', on_complete => sub { fail("This can't happen!") }, on_fail => sub { pass("We failed properly!") }, }); sleep 5; $tasks->add_task('sleep_three', '10:b', { uniq => 'something', on_complete => sub { fail("This can't happen!") }, on_fail => sub { pass("We failed properly again!") }, }); $tasks->wait; } ## Test retry_count. my $retried = 0; is($client->do_task('fail' => '', { on_retry => sub { $retried++ }, retry_count => 3, }), undef, 'Failure response is still failure, even after retrying'); is($retried, 3, 'Retried 3 times'); $tasks = $client->new_task_set; $completed = 0; $failed = 0; $tasks->add_task(fail => '', { on_complete => sub { $completed = 1 }, on_fail => sub { $failed = 1 }, }); $tasks->wait; is($completed, 0, 'on_complete not called on failed result'); is($failed, 1, 'on_fail called on failed result'); ## Test high_priority. ## Create a taskset with 4 tasks, and have the 3rd fail. ## In on_fail, add a new task with high priority set, and make sure it ## gets executed before task 4. To make this reliable, we need to first ## kill off all but one of the worker processes. my @worker_pids = grep { $Children{$_} eq 'W' } keys %Children; kill INT => @worker_pids[1..$#worker_pids]; $tasks = $client->new_task_set; $out = ''; $tasks->add_task(echo_ws => 1, { on_complete => sub { $out .= ${ $_[0] } } }); $tasks->add_task(echo_ws => 2, { on_complete => sub { $out .= ${ $_[0] } } }); $tasks->add_task(echo_ws => 'x', { on_fail => sub { $tasks->add_task(echo_ws => 'p', { on_complete => sub { $out .= ${ $_[0] }; }, high_priority => 1 }); }, }); $tasks->add_task(echo_ws => 3, { on_complete => sub { $out .= ${ $_[0] } } }); $tasks->add_task(echo_ws => 4, { on_complete => sub { $out .= ${ $_[0] } } }); $tasks->add_task(echo_ws => 5, { on_complete => sub { $out .= ${ $_[0] } } }); $tasks->add_task(echo_ws => 6, { on_complete => sub { $out .= ${ $_[0] } } }); $tasks->wait; like($out, qr/p.+6/, 'High priority tasks executed in priority order.'); ## We just killed off all but one worker--make sure they get respawned. respawn_children(); ## Test dispatch_background and get_status. $handle = $client->dispatch_background(long => undef, { on_complete => sub { $out = ${ $_[0] } }, }); # wait for job to start being processed: sleep 1; ok($handle, 'Got a handle back from dispatching background job'); my $status = $client->get_status($handle); isa_ok($status, 'Gearman::JobStatus'); ok($status->known, 'Job is known'); ok($status->running, 'Job is still running'); is($status->percent, .5, 'Job is 50 percent complete'); do { sleep 1; $status = $client->get_status($handle); } until $status->percent == 1; Gearman-1.11/t/30-maxqueue.t0000644000175000017500000000245311262246612015706 0ustar dormandodormando#!/usr/bin/perl use strict; use Gearman::Client; use Storable qw( freeze ); use Test::More; use lib 't'; use TestGearman; # This is testing the MAXQUEUE feature of gearmand. There's no direct # support for it in Gearman::Worker yet, so we connect directly to # gearmand to configure it for the test. if (start_server(PORT)) { plan tests => 6; } else { plan skip_all => "Can't find server to test with"; exit 0; } wait_for_port(PORT); { my $sock = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => PORT, ); ok($sock, "connect to jobserver"); $sock->write( "MAXQUEUE long 1\n" ); my $input = $sock->getline(); ok($input =~ m/^OK\b/i); } start_worker(PORT); my $client = Gearman::Client->new; isa_ok($client, 'Gearman::Client'); $client->job_servers('127.0.0.1:' . PORT); my $tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); my $failed = 0; my $completed = 0; foreach my $iter (1..5) { my $handle = $tasks->add_task('long', $iter, { on_complete => sub { $completed++ }, on_fail => sub { $failed++ } }); } $tasks->wait; ok($completed == 2 || $completed == 1, 'number of success'); # One in the queue, plus one that may start immediately ok($failed == 3 || $failed== 4, 'number of failure'); # All the rest Gearman-1.11/t/65-responseparser.t0000644000175000017500000000375611262246612017146 0ustar dormandodormandouse strict; use warnings; use Test::More tests => 9; use Gearman::Client; our $last_packet = undef; our @packets; my $parser = Gearman::ResponseParser::Test->new(); test_packet("\0RES\0\0\0\x0a\0\0\0\x01!", { len => 1, blobref => \"!", #" type => 'no_job', }); test_packet("\0RES\0\0\0\x0a\0\0\0\0", { len => 0, blobref => \"", #" type => 'no_job', }); ## multiple packets my $pkt = "\0RES\0\0\0\x0a\0\0\0\0"; test_multi_packet("$pkt$pkt", { len => 0, blobref => \"", #" type => 'no_job', }, { len => 0, blobref => \"", #" type => 'no_job', }); # Message split into two packets test_packet("\0RE", undef); test_packet("S\0\0\0\x0a\0\0\0\0", { len => 0, blobref => \"", #" type => 'no_job', }); # Message with payload split into two packets test_packet("\0RES\0\0\0\x0a\0\0\0\x02a", undef); test_packet("b", { len => 2, blobref => \"ab", #" type => 'no_job', }); # Two packets, with the first containing a full message # and a partial message, and the second containing the # remainder of the partial message. test_packet("\0RES\0\0\0\x0a\0\0\0\x02ab\0RES\0\0\0\x0a\0\0\0\x02b", { len => 2, blobref => \"ab", #" type => 'no_job', }); test_packet("a", { len => 2, blobref => \"ba", #" type => 'no_job', }); sub test_packet { my ($data, $expected) = @_; my $test_name = "Parsing ".enc($data); $last_packet = undef; $parser->parse_data(\$data); is_deeply($last_packet, $expected, $test_name); } sub test_multi_packet { my ($data, @expected) = @_; my $test_name = "Parsing ".enc($data); @packets = (); $parser->parse_data(\$data); is_deeply(\@packets, \@expected, $test_name); } sub enc { my $data = $_[0]; $data =~ s/([\W])/"%" . uc(sprintf("%2.2x",ord($1)))/eg; return $data; } package Gearman::ResponseParser::Test; use Gearman::ResponseParser; use base qw(Gearman::ResponseParser); sub on_packet { $main::last_packet = $_[1]; push @main::packets, $_[1]; } Gearman-1.11/t/00-use.t0000644000175000017500000000016711262246612014645 0ustar dormandodormandouse strict; use Test::More tests => 3; use_ok('Gearman::Util'); use_ok('Gearman::Worker'); use_ok('Gearman::Client'); Gearman-1.11/t/worker.pl0000755000175000017500000000402011262246612015310 0ustar dormandodormando#!/usr/bin/perl -w use strict; use lib 'lib'; use Gearman::Worker; use Storable qw(thaw nfreeze); use Getopt::Long qw( GetOptions ); GetOptions( 's|servers=s' => \(my $servers), 'n=i' => \(my $notifypid), 'p=s' => \(my $prefix), ); die "usage: $0 -s " unless $servers; my @servers = split /,/, $servers; my $worker = Gearman::Worker->new($prefix ? (prefix => $prefix) : ()); $worker->job_servers(@servers); $worker->register_function(sum => sub { my $sum = 0; $sum += $_ for @{ thaw($_[0]->arg) }; $sum; }); $worker->register_function(fail => sub { undef }); $worker->register_function(fail_die => sub { die 'test reason' }); $worker->register_function(fail_exit => sub { exit 255 }); $worker->register_function(sleep => sub { sleep $_[0]->arg }); $worker->register_function(sleep_three => 3 => sub { my ($sleep, $return) = $_[0]->arg =~ m/^(\d+)(?::(.+))?$/; sleep $sleep; return $return; }); $worker->register_function(echo_ws => sub { select undef, undef, undef, 0.25; $_[0]->arg eq 'x' ? undef : $_[0]->arg; }); $worker->register_function(echo_prefix => sub { join " from ", $_[0]->arg, $prefix; }); $worker->register_function(echo_sleep => sub { my($job) = @_; $job->set_status(1, 1); sleep 2; ## allow some time to read the status join " from ", $_[0]->arg, $prefix; }); $worker->register_function(long => sub { my($job) = @_; $job->set_status(50, 100); sleep 2; $job->set_status(100, 100); sleep 2; return $job->arg; }); my $nsig; $nsig = kill 'USR1', $notifypid if $notifypid; my $work_exit = 0; $worker->register_function(work_exit => sub { $work_exit = 1; }); my ($is_idle, $last_job_time); $worker->register_function(check_stop_if => sub { return nfreeze([$is_idle, $last_job_time]); }); my $stop_if = sub { ($is_idle, $last_job_time) = @_; if ($work_exit) { $work_exit = 0; return 1; } return 0; }; $worker->work(stop_if => $stop_if) while (1); Gearman-1.11/lib/0000755000175000017500000000000011324751023013742 5ustar dormandodormandoGearman-1.11/lib/Gearman/0000755000175000017500000000000011324751023015314 5ustar dormandodormandoGearman-1.11/lib/Gearman/ResponseParser.pm0000644000175000017500000000632411262246612020636 0ustar dormandodormandopackage Gearman::ResponseParser; use strict; # this is an abstract base class. See: # Gearman::ResponseParser::Taskset (for Gearman::Client, the sync version), or # Gearman::ResponseParser::Danga (for Gearman::Client::Danga, the async version) # subclasses should call this first, then add their own data in underscore members sub new { my $class = shift; my %opts = @_; my $src = delete $opts{'source'}; die if %opts; my $self = bless { source => $src, # the source object/socket that is primarily feeding this. }, $class; $self->reset; return $self; } sub source { my $self = shift; return $self->{source}; } sub on_packet { my ($self, $packet, $parser) = @_; die "SUBCLASSES SHOULD OVERRIDE THIS"; } sub on_error { my ($self, $errmsg, $parser) = @_; # NOTE: this interface will evolve. die "SUBCLASSES SHOULD OVERRIDE THIS"; } sub reset { my $self = shift; $self->{header} = ''; $self->{pkt} = undef; } # don't override: # FUTURE OPTIMIZATION: let caller say "you can own this scalarref", and then we can keep it # on the initial settin of $self->{data} and avoid copying into our own. overkill for now. sub parse_data { my ($self, $data) = @_; # where $data is a scalar or scalarref to parse my $dataref = ref $data ? $data : \$data; my $err = sub { my $code = shift; $self->on_error($code); return undef; }; while (my $lendata = length $$data) { # read the header my $hdr_len = length $self->{header}; unless ($hdr_len == 12) { my $need = 12 - $hdr_len; $self->{header} .= substr($$dataref, 0, $need, ''); next unless length $self->{header} == 12; my ($magic, $type, $len) = unpack( "a4NN", $self->{header} ); return $err->("malformed_magic") unless $magic eq "\0RES"; my $blob = ""; $self->{pkt} = { type => Gearman::Util::cmd_name($type), len => $len, blobref => \$blob, }; next; } # how much data haven't we read for the current packet? my $need = $self->{pkt}{len} - length(${ $self->{pkt}{blobref} }); # copy the MAX(need, have) my $to_copy = $lendata > $need ? $need : $lendata; ${$self->{pkt}{blobref}} .= substr($$dataref, 0, $to_copy, ''); if ($to_copy == $need) { $self->on_packet($self->{pkt}, $self); $self->reset; } } if (defined($self->{pkt}) && length(${ $self->{pkt}{blobref} }) == $self->{pkt}{len}) { $self->on_packet($self->{pkt}, $self); $self->reset; } } # don't override: sub eof { my $self = shift; $self->on_error("EOF"); # ERROR if in middle of packet } # don't override: sub parse_sock { my ($self, $sock) = @_; # $sock is readable, we should sysread it and feed it to $self->parse_data my $data; my $rv = sysread($sock, $data, 128 * 1024); if (! defined $rv) { $self->on_error("read_error: $!"); return; } # FIXME: EAGAIN , EWOULDBLOCK if (! $rv) { $self->eof; return; } $self->parse_data(\$data); } 1; Gearman-1.11/lib/Gearman/Taskset.pm0000644000175000017500000002417211324750465017307 0ustar dormandodormandopackage Gearman::Taskset; use strict; use Carp (); use Gearman::Client; use Gearman::Util; use Gearman::ResponseParser::Taskset; use Scalar::Util (); # i thought about weakening taskset's client, but might be too weak. use Time::HiRes (); 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} = {}; $self->{cancelled} = 0; $self->{hooks} = {}; return $self; } sub DESTROY { my Gearman::Taskset $ts = shift; # During global cleanup this may be called out of order, and the client my not exist in the taskset. return unless $ts->{client}; 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 run_hook { my Gearman::Taskset $self = shift; my $hookname = shift || return; my $hook = $self->{hooks}->{$hookname}; return unless $hook; eval { $hook->(@_) }; warn "Gearman::Taskset hook '$hookname' threw error: $@\n" if $@; } sub add_hook { my Gearman::Taskset $self = shift; my $hookname = shift || return; if (@_) { $self->{hooks}->{$hookname} = shift; } else { delete $self->{hooks}->{$hookname}; } } # this method is part of the "Taskset" interface, also implemented by # Gearman::Client::Async, where no tasksets make sense, so instead the # Gearman::Client::Async object itself is also its taskset. (the # client tracks all tasks). so don't change this, without being aware # of Gearman::Client::Async. similarly, don't access $ts->{client} without # going via this accessor. sub client { my Gearman::Taskset $ts = shift; return $ts->{client}; } sub cancel { my Gearman::Taskset $ts = shift; $ts->{cancelled} = 1; if ($ts->{default_sock}) { close($ts->{default_sock}); $ts->{default_sock} = undef; } while (my ($hp, $sock) = each %{ $ts->{loaned_sock} }) { $sock->close; } $ts->{waiting} = {}; $ts->{need_handle} = []; $ts->{client} = undef; } 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; } # event loop for reading in replies sub wait { my Gearman::Taskset $ts = shift; my %opts = @_; my $timeout; if (exists $opts{timeout}) { $timeout = delete $opts{timeout}; $timeout += Time::HiRes::time() if defined $timeout; } Carp::carp "Unknown options: " . join(',', keys %opts) . " passed to Taskset->wait." if keys %opts; my %parser; # fd -> Gearman::ResponseParser object 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 $tries = 0; while (!$ts->{cancelled} && keys %{$ts->{waiting}}) { $tries++; my $time_left = $timeout ? $timeout - Time::HiRes::time() : 0.5; my $nfound = select($rout=$rin, undef, $eout=$rin, $time_left); if ($timeout && $time_left <= 0) { $ts->cancel; return; } next if ! $nfound; foreach my $fd (keys %watching) { next unless vec($rout, $fd, 1); # TODO: deal with error vector my $sock = $watching{$fd}; my $parser = $parser{$fd} ||= Gearman::ResponseParser::Taskset->new(source => $sock, taskset => $ts); eval { $parser->parse_sock($sock); }; if ($@) { # TODO this should remove the fd from the list, and reassign any tasks to other jobserver, or bail. # We're not in an accessable place here, so if all job servers fail we must die to prevent hanging. die( "Job server failure: $@" ); } } } } # ->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); $ts->run_hook('add_task', $ts, $task); my $req = $task->pack_submit_packet($ts->client); 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. 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; # socket to singularly read from my ($res, $err); $res = Gearman::Util::read_res_packet($sock, \$err); return 0 unless $res; return $ts->_process_packet($res, $sock); } 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_exception") { ${ $res->{'blobref'} } =~ s/^(.+?)\0// or die "Bogus work_exception from server"; my $shandle = $1; my $task_list = $ts->{waiting}{$shandle} or die "Uhhhh: got work_exception for unknown handle: $shandle\n"; my Gearman::Task $task = $task_list->[0] or die "Uhhhh: task_list is empty on work_exception for handle $shandle\n"; $task->exception($res->{'blobref'}); 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} [${$res->{blobref}}]"; } 1; Gearman-1.11/lib/Gearman/Task.pm0000644000175000017500000002120611262246612016561 0ustar dormandodormandopackage Gearman::Task; use strict; use Carp (); use String::CRC32 (); use Gearman::Taskset; use Gearman::Util; BEGIN { my $storable = eval { require Storable; 1 } if !defined &RECEIVE_EXCEPTIONS || RECEIVE_EXCEPTIONS(); $storable ||= 0; if (defined &RECEIVE_EXCEPTIONS) { die "Exceptions support requires Storable: $@"; } else { eval "sub RECEIVE_EXCEPTIONS () { $storable }"; die "Couldn't define RECEIVE_EXCEPTIONS: $@\n" if $@; } } # 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_exception on_fail on_retry on_status retry_count timeout high_priority try_timeout )) { $self->{$k} = delete $opts->{$k}; } $self->{retry_count} ||= 0; $self->{is_finished} = 0; # bool: if success or fail has been called yet on this. if (%{$opts}) { Carp::croak("Unknown option(s): " . join(", ", sort keys %$opts)); } $self->{retries_done} = 0; return $self; } sub run_hook { my Gearman::Task $self = shift; my $hookname = shift || return; my $hook = $self->{hooks}->{$hookname}; return unless $hook; eval { $hook->(@_) }; warn "Gearman::Task hook '$hookname' threw error: $@\n" if $@; } sub add_hook { my Gearman::Task $self = shift; my $hookname = shift || return; if (@_) { $self->{hooks}->{$hookname} = shift; } else { delete $self->{hooks}->{$hookname}; } } sub is_finished { my Gearman::Task $task = $_[0]; return $task->{is_finished}; } 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 undef on non-uniq packet, or the hash value (0-32767) if uniq sub hash { my Gearman::Task $task = shift; my $merge_on = $task->{uniq} && $task->{uniq} eq "-" ? $task->{argref} : \ $task->{uniq}; if ($$merge_on) { return _hashfunc( $merge_on ); } else { return undef; } } # 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 Gearman::Client $client = shift; my $is_background = shift; my $mode = $is_background ? "submit_job_bg" : ($task->{high_priority} ? "submit_job_high" : "submit_job"); my $func = $task->{func}; if (my $prefix = $client && $client->prefix) { $func = join "\t", $prefix, $task->{func}; } return Gearman::Util::pack_req_command($mode, join("\0", $func || '', $task->{uniq} || '', ${ $task->{argref} } || '')); } sub fail { my Gearman::Task $task = shift; my $reason = shift; return if $task->{is_finished}; # 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); } $task->final_fail($reason); } sub final_fail { my Gearman::Task $task = $_[0]; my $reason = $_[1]; return if $task->{is_finished}; $task->{is_finished} = $_[1] || 1; $task->run_hook('final_fail', $task); $task->{on_fail}->($reason) if $task->{on_fail}; $task->{on_post_hooks}->() if $task->{on_post_hooks}; $task->wipe; return undef; } sub exception { my Gearman::Task $task = shift; return unless RECEIVE_EXCEPTIONS; my $exception_ref = shift; my $exception = Storable::thaw($$exception_ref); $task->{on_exception}->($$exception) if $task->{on_exception}; return; } sub complete { my Gearman::Task $task = shift; return if $task->{is_finished}; my $result_ref = shift; $task->{is_finished} = 'complete'; $task->run_hook('complete', $task); $task->{on_complete}->($result_ref) if $task->{on_complete}; $task->{on_post_hooks}->() if $task->{on_post_hooks}; $task->wipe; } sub status { my Gearman::Task $task = shift; return if $task->{is_finished}; 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; } sub set_on_post_hooks { my Gearman::Task $task = shift; my $code = shift; $task->{on_post_hooks} = $code; } sub wipe { my Gearman::Task $task = shift; foreach my $f (qw(on_post_hooks on_complete on_fail on_retry on_status hooks)) { $task->{$f} = undef; } } sub func { my Gearman::Task $task = shift; return $task->{func}; } sub timeout { my Gearman::Task $task = shift; return $task->{timeout} unless @_; return $task->{timeout} = 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 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 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 * timeout Automatically fail, calling your on_fail callback, after this many seconds have elapsed without an on_fail or on_complete being called. Defaults to 0, which means never. Bypasses any retry_count remaining. =item * try_timeout Automatically fail, calling your on_retry callback (or on_fail if out of retries), after this many seconds have elapsed. Defaults to 0, which means never. =back =head2 $task->is_finished Returns bool: whether or not task is totally done (on_failure or on_complete callback has been called) =cut Gearman-1.11/lib/Gearman/Worker.pm0000644000175000017500000004710111262246612017132 0ustar dormandodormando#!/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)); die "work_status write failed" unless Gearman::Util::send_req($self->{jss}, \$req); return 1; } sub argref { my Gearman::Job $self = shift; return $self->{argref}; } sub arg { my Gearman::Job $self = shift; return ${ $self->{argref} }; } sub handle { my Gearman::Job $self = shift; return $self->{handle}; } package Gearman::Worker; use Socket qw(IPPROTO_TCP TCP_NODELAY SOL_SOCKET PF_INET SOCK_STREAM); use fields ( 'job_servers', 'js_count', 'prefix', 'debug', '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', # ability -> subref (ability is func with optional prefix) 'timeouts', # ability -> timeouts 'client_id', # random identifer string, no whitespace 'parent_pipe', # bool/obj: if we're a child process of a gearman server, # this is socket to our parent process. also means parent # sock can never disconnect or timeout, etc.. ); BEGIN { my $storable = eval { require Storable; 1 } if !defined &THROW_EXCEPTIONS || THROW_EXCEPTIONS(); $storable ||= 0; if (defined &THROW_EXCEPTIONS) { die "Exceptions support requires Storable: $@"; } else { eval "sub THROW_EXCEPTIONS () { $storable }"; die "Couldn't define THROW_EXCEPTIONS: $@\n" if $@; } } 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->{timeouts} = {}; $self->{client_id} = join("", map { chr(int(rand(26)) + 97) } (1..30)); $self->{prefix} = undef; $self->debug($opts{debug}) if $opts{debug}; if ($ENV{GEARMAN_WORKER_USE_STDIO}) { open my $sock, '+<&', \*STDIN or die "Unable to dup STDIN to socket for worker to use."; $self->{job_servers} = [ $sock ]; $self->{parent_pipe} = $sock; die "Unable to initialize connection to gearmand" unless $self->_on_connect($sock); } elsif ($opts{job_servers}) { $self->job_servers(@{ $opts{job_servers} }); } $self->prefix($opts{prefix}) if $opts{prefix}; return $self; } sub _get_js_sock { my Gearman::Worker $self = shift; my $ipport = shift; my %opts = @_; my $on_connect = delete $opts{on_connect}; # Someday should warn when called with extra opts. warn "getting job server socket: $ipport" if $self->debug; # special case, if we're a child process of a gearman::server # parent process, talking over a unix pipe... return $self->{parent_pipe} if $self->{parent_pipe}; 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) { warn "job server down since $down_since" if $self->debug; 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; } } warn "connecting to '$ipport'" if $self->debug; my $sock = IO::Socket::INET->new(PeerAddr => $ipport, 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; unless ($self->_on_connect($sock) && $on_connect && $on_connect->($sock)) { delete $self->{sock_cache}{$ipport}; return undef; } return $sock; } # Housekeeping things to do on connection to a server. Method call # with one argument being the 'socket' we're going to take care of. # returns true on success, false on failure. sub _on_connect { my ($self, $sock) = @_; my $cid_req = Gearman::Util::pack_req_command("set_client_id", $self->{client_id}); return undef unless Gearman::Util::send_req($sock, \$cid_req); # get this socket's state caught-up foreach my $ability (keys %{$self->{can}}) { my $timeout = $self->{timeouts}->{$ability}; unless ($self->_set_ability($sock, $ability, $timeout)) { return undef; } } return 1; } sub _set_ability { my Gearman::Worker $self = shift; my ($sock, $ability, $timeout) = @_; my $req; if (defined $timeout) { $req = Gearman::Util::pack_req_command("can_do_timeout", "$ability\0$timeout"); } else { $req = Gearman::Util::pack_req_command("can_do", $ability); } 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) or next; unless (Gearman::Util::send_req($jss, \$req)) { $self->uncache_sock("js", "err_write_reset_abilities"); } } $self->{can} = {}; $self->{timeouts} = {}; } sub uncache_sock { my ($self, $ipport, $reason) = @_; # we can't reconnect as a child process, so all we can do is die and hope our # parent process respawns us... die "Error/timeout talking to gearman parent process: [$reason]" if $self->{parent_pipe}; # normal case, we just close this TCP connectiona and we'll reconnect later. delete $self->{sock_cache}{$ipport}; } # does one job and returns. no return value. sub work { my Gearman::Worker $self = shift; my %opts = @_; my $stop_if = delete $opts{'stop_if'} || sub { 0 }; my $complete_cb = delete $opts{on_complete}; my $fail_cb = delete $opts{on_fail}; my $start_cb = delete $opts{on_start}; die "Unknown opts" if %opts; my $grab_req = Gearman::Util::pack_req_command("grab_job"); my $presleep_req = Gearman::Util::pack_req_command("pre_sleep"); my $last_job_time; # "Active" job servers are servers that have woken us up and should be # queried to see if they have jobs for us to handle. On our first pass # in the loop we contact all servers. my %active_js = map { $_ => 1 } @{$self->{job_servers}}; # ( js => last_update_time, ... ) my %last_update_time; while (1) { # "Jobby" job servers are the set of server which we will contact # on this pass through the loop, because we need to clear and use # the "Active" set to plan for our next pass through the loop. my @jobby_js = keys %active_js; %active_js = (); my $js_count = @jobby_js; my $js_offset = int(rand($js_count)); my $is_idle = 0; for (my $i = 0; $i < $js_count; $i++) { my $js_index = ($i + $js_offset) % $js_count; my $js = $jobby_js[$js_index]; my $jss = $self->_get_js_sock($js) or next; # TODO: add an optional sleep in here for the test suite # to test gearmand server going away here. (SIGPIPE on # send_req, etc) this testing has been done manually, at # least. unless (Gearman::Util::send_req($jss, \$grab_req)) { if ($!{EPIPE} && $self->{parent_pipe}) { # our parent process died, so let's just quit # gracefully. exit(0); } $self->uncache_sock($js, "grab_job_timeout"); delete $last_update_time{$js}; next; } # if we're a child process talking over a unix pipe, give more # time, since we know there are no network issues, and also # because on failure, we can't "reconnect". all we can do is # die and hope our parent process respawns us. my $timeout = $self->{parent_pipe} ? 5 : 0.50; unless (Gearman::Util::wait_for_readability($jss->fileno, $timeout)) { $self->uncache_sock($js, "grab_job_timeout"); delete $last_update_time{$js}; next; } my $res; do { my $err; $res = Gearman::Util::read_res_packet($jss, \$err); unless ($res) { $self->uncache_sock($js, "read_res_error"); delete $last_update_time{$js}; next; } } while ($res->{type} eq "noop"); if ($res->{type} eq "no_job") { unless (Gearman::Util::send_req($jss, \$presleep_req)) { delete $last_update_time{$js}; $self->uncache_sock($js, "write_presleep_error"); } $last_update_time{$js} = time; next; } unless ($res->{type} eq "job_assign") { my $msg = "Uh, wasn't expecting a $res->{type} packet."; if ($res->{type} eq "error") { $msg .= " [${$res->{blobref}}]\n"; $msg =~ s/\0/ -- /g; } die $msg; } ${ $res->{'blobref'} } =~ s/^(.+?)\0(.+?)\0// or die "Uh, regexp on job_assign failed"; my ($handle, $ability) = ($1, $2); my $job = Gearman::Job->new($ability, $res->{'blobref'}, $handle, $jss); my $jobhandle = "$js//" . $job->handle; $start_cb->($jobhandle) if $start_cb; my $handler = $self->{can}{$ability}; my $ret = eval { $handler->($job); }; my $err = $@; warn "Job '$ability' died: $err" if $err; $last_update_time{$js} = $last_job_time = time(); if (THROW_EXCEPTIONS && $err) { my $exception_req = Gearman::Util::pack_req_command("work_exception", join("\0", $handle, Storable::nfreeze(\$err))); unless (Gearman::Util::send_req($jss, \$exception_req)) { $self->uncache_sock($js, "write_res_error"); next; } } my $work_req; if (defined $ret) { my $rv = ref $ret ? $$ret : $ret; $work_req = Gearman::Util::pack_req_command("work_complete", "$handle\0$rv"); $complete_cb->($jobhandle, $ret) if $complete_cb; } else { $work_req = Gearman::Util::pack_req_command("work_fail", $handle); $fail_cb->($jobhandle, $err) if $fail_cb; } unless (Gearman::Util::send_req($jss, \$work_req)) { $self->uncache_sock($js, "write_res_error"); next; } $active_js{$js} = 1; } my @jss; my $on_connect = sub { return Gearman::Util::send_req($_[0], \$presleep_req); }; foreach my $js (@{$self->{job_servers}}) { my $jss = $self->_get_js_sock($js, on_connect => $on_connect) or next; push @jss, [$js, $jss]; } $is_idle = 1; my $wake_vec = ''; foreach my $j (@jss) { my ($js, $jss) = @$j; my $fd = $jss->fileno; vec($wake_vec, $fd, 1) = 1; } my $timeout = keys %active_js ? 0 : (10 + rand(2)); # chill for some arbitrary time until we're woken up again my $nready = select(my $wout = $wake_vec, undef, undef, $timeout); if ($nready) { foreach my $j (@jss) { my ($js, $jss) = @$j; my $fd = $jss->fileno; $active_js{$js} = 1 if vec($wout, $fd, 1); } } $is_idle = 0 if keys %active_js; return if $stop_if->($is_idle, $last_job_time); my $update_since = time - (15 + rand 60); while (my ($js, $last_update) = each %last_update_time) { $active_js{$js} = 1 if $last_update < $update_since; } } } sub register_function { my Gearman::Worker $self = shift; my $func = shift; my $timeout = shift unless (ref $_[0] eq 'CODE'); my $subref = shift; my $prefix = $self->prefix; my $ability = defined($prefix) ? "$prefix\t$func" : "$func"; my $req; if (defined $timeout) { $req = Gearman::Util::pack_req_command("can_do_timeout", "$ability\0$timeout"); $self->{timeouts}{$ability} = $timeout; } else { $req = Gearman::Util::pack_req_command("can_do", $ability); } $self->_register_all($req); $self->{can}{$ability} = $subref; } sub unregister_function { my Gearman::Worker $self = shift; my $func = shift; my $prefix = $self->prefix; my $ability = defined($prefix) ? "$prefix\t$func" : "$func"; my $req = Gearman::Util::pack_req_command("cant_do", $ability); $self->_register_all($req); delete $self->{can}{$ability}; } sub _register_all { my Gearman::Worker $self = shift; my $req = shift; foreach my $js (@{ $self->{job_servers} }) { my $jss = $self->_get_js_sock($js) or next; unless (Gearman::Util::send_req($jss, \$req)) { $self->uncache_sock($js, "write_register_func_error"); } } } # getters/setters sub job_servers { my Gearman::Worker $self = shift; return if ($ENV{GEARMAN_WORKER_USE_STDIO}); return $self->{job_servers} unless @_; my $list = [ @_ ]; $self->{js_count} = scalar @$list; foreach (@$list) { $_ .= ":7003" unless /:/; } return $self->{job_servers} = $list; } sub prefix { my Gearman::Worker $self = shift; return $self->{prefix} unless @_; $self->{prefix} = shift; } sub debug { my Gearman::Worker $self = shift; $self->{debug} = shift if @_; return $self->{debug} || 0; } 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 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 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 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 (see below) to initialize the list of job servers. It will be ignored if this worker is running as a child process of a gearman server. =item * prefix Calls I (see below) to set the prefix / namespace. =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. Calling this method will do nothing in a worker that is running as a child process of a gearman server. =head2 $worker->register_function($funcname, $subref) =head2 $worker->register_function($funcname, $timeout, $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 object representing the job that has been received by the worker. I<$timeout> is an optional parameter specifying how long the jobserver will wait for your subroutine to give an answer. Exceeding this time will result in the jobserver reassigning the task and ignoring your result. This prevents a gimpy worker from ruining the 'user experience' in many situations. The subroutine reference can return a return value, which will be sent back to the job server. =head2 $client-Eprefix($prefix) Sets the namespace / prefix for the function names. This is useful for sharing job servers between different applications or different instances of the same application (different development sandboxes for example). The namespace is currently implemented as a simple tab separated concatentation of the prefix and the function name. =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. =head2 Gearman::Job->work(%opts) Do one job and returns (no value returned). You can pass "on_start" "on_complete" and "on_fail" callbacks in I<%opts>. =head1 WORKERS AS CHILD PROCESSES Gearman workers can be run run as child processes of a parent process which embeds L. When such a parent process fork/execs a worker, it sets the environment variable GEARMAN_WORKER_USE_STDIO to true before launching the worker. If this variable is set to true, then the jobservers function and option for new() are ignored and the unix socket bound to STDIN/OUT are used instead as the IO path to the gearman server. =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 documentation for a sample client sending the I job. =cut Gearman-1.11/lib/Gearman/Util.pm0000644000175000017500000001205011324750465016576 0ustar dormandodormando 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] 23 => [ 'I', "can_do_timeout" ], # from W: FUNC[0]TIMEOUT 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: --- 26 => [ 'I', "option_req" ], # C->J: [OPT] 27 => [ 'O', "option_res" ], # J->C: [OPT] 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 25 => [ 'IO', "work_exception" ], # W->J/C: HANDLE[0]EXCEPTION 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 # for worker to declare to the jobserver that this worker is only connected # to one jobserver, so no polls/grabs will take place, and server is free # to push "job_assign" packets back down. 24 => [ 'I', "all_yours" ], # W->J --- ); 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 = $num{$type_arg} || int($type_arg); die "Bogus type arg of '$type_arg'" unless $type; # If they didn't pass in anything to send, make it be an empty string. $_[0] = '' unless defined $_[0]; 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; $sock->close() if $sock->connected; $$err_ref = $code if ref $err_ref; return undef; }; # read the header $rv = sysread($sock, $buf, 12); return $err->("read_error") unless defined $rv; return $err->("eof") unless $rv; return $err->("malformed_header") unless $rv == 12; my ($magic, $type, $len) = unpack("a4NN", $buf); return $err->("malformed_magic") unless $magic eq "\0RES"; if ($len) { my $readlen = $len; my $offset = 0; my $lim = 20 + int( $len / 2**10 ); for (my $i = 0; $readlen > 0 && $i < $lim; $i++) { # Because we know the length of the data we need to read exactly, the # most efficient way to do this in perl is with one giant buffer, and # an appropriate offset passed to sysread. my $rv = sysread($sock, $buf, $readlen, $offset); return $err->("short_body") unless $rv > 0; last unless $rv > 0; $readlen -= $rv; $offset += $rv; } return $err->("short_body") unless length($buf) == $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); local $SIG{PIPE} = 'IGNORE'; 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 = ''; 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; Gearman-1.11/lib/Gearman/ResponseParser/0000755000175000017500000000000011324751023020267 5ustar dormandodormandoGearman-1.11/lib/Gearman/ResponseParser/Taskset.pm0000644000175000017500000000074411262246612022254 0ustar dormandodormandopackage Gearman::ResponseParser::Taskset; use strict; use base 'Gearman::ResponseParser'; use Gearman::Taskset; sub new { my ($class, %opts) = @_; my $ts = delete $opts{taskset}; my $self = $class->SUPER::new(%opts); $self->{_taskset} = $ts; return $self; } sub on_packet { my ($self, $packet, $parser) = @_; $self->{_taskset}->_process_packet($packet, $parser->source); } sub on_error { my ($self, $errmsg) = @_; die "ERROR: $errmsg\n"; } 1; Gearman-1.11/lib/Gearman/JobStatus.pm0000644000175000017500000000113611262246612017575 0ustar dormandodormando package Gearman::JobStatus; use strict; sub new { my ($class, $known, $running, $nu, $de) = @_; $nu = '' unless defined($nu) && length($nu); $de = '' unless defined($de) && 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; Gearman-1.11/lib/Gearman/Objects.pm0000644000175000017500000000354011262246612017251 0ustar dormandodormandouse strict; package Gearman::Objects; # this dummy package exists purely for building RPMs, # some tools of which have requirements for above package # line and the filename to match somehow. package Gearman::Client; use fields ( 'job_servers', 'js_count', 'sock_cache', # hostport -> socket 'hooks', # hookname -> coderef 'prefix', 'debug', 'exceptions', ); 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 } 'cancelled', # bool, if taskset has been cancelled mid-processing 'hooks', # hookname -> coderef ); package Gearman::Task; use fields ( # from client: 'func', 'argref', # opts from client: 'uniq', 'on_complete', 'on_fail', 'on_exception', 'on_retry', 'on_status', 'on_post_hooks', # used internally, when other hooks are done running, prior to cleanup 'retry_count', 'timeout', 'try_timeout', 'high_priority', # from server: 'handle', # maintained by this module: 'retries_done', 'is_finished', 'taskset', 'jssock', # jobserver socket. shared by other tasks in the same taskset, # but not w/ tasks in other tasksets using the same Gearman::Client 'hooks', # hookname -> coderef ); 1; Gearman-1.11/lib/Gearman/Client.pm0000644000175000017500000002565111324750673017113 0ustar dormandodormando#!/usr/bin/perl package Gearman::Client; our $VERSION; $VERSION = '1.11'; 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->{hooks} = {}; $self->{prefix} = ''; $self->{exceptions} = 0; $self->debug($opts{debug}) if $opts{debug}; $self->set_job_servers(@{ $opts{job_servers} }) if $opts{job_servers}; $self->{exceptions} = delete $opts{exceptions} if exists $opts{exceptions}; $self->prefix($opts{prefix}) if $opts{prefix}; return $self; } sub new_task_set { my Gearman::Client $self = shift; my $taskset = Gearman::Taskset->new($self); $self->run_hook('new_task_set', $self, $taskset); return $taskset; } # getter/setter sub job_servers { my Gearman::Client $self = shift; unless (@_) { return wantarray ? @{$self->{job_servers}} : $self->{job_servers}; } $self->set_job_servers(@_); } sub set_job_servers { my Gearman::Client $self = shift; my $list = ref $_[0] ? $_[0] : [ @_ ]; # take arrayref or array $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(timeout => $task->timeout); 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($self, "background"); my $len = length($req); my $rv = $jss->write($req, $len); my $err; my $res = Gearman::Util::read_res_packet($jss, \$err); $self->_put_js_sock($jst, $jss); return 0 unless $res && $res->{type} eq "job_created"; return "$jst//${$res->{blobref}}"; } sub run_hook { my Gearman::Client $self = shift; my $hookname = shift || return; my $hook = $self->{hooks}->{$hookname}; return unless $hook; eval { $hook->(@_) }; warn "Gearman::Client hook '$hookname' threw error: $@\n" if $@; } sub add_hook { my Gearman::Client $self = shift; my $hookname = shift || return; if (@_) { $self->{hooks}->{$hookname} = shift; } else { delete $self->{hooks}->{$hookname}; } } 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); if ($res && $res->{type} eq "error") { die "Error packet from server after get_status: ${$res->{blobref}}\n"; } 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); } sub _option_request { my Gearman::Client $self = shift; my $sock = shift; my $option = shift; my $req = Gearman::Util::pack_req_command("option_req", $option); my $len = length($req); my $rv = $sock->write($req, $len); my $err; my $res = Gearman::Util::read_res_packet($sock, \$err); return unless $res; return 0 if $res->{type} eq "error"; return 1 if $res->{type} eq "option_res"; warn "Got unknown response to option request: $res->{type}\n"; return; } # 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); # If exceptions support is to be requested, and the request fails, disable # exceptions for this client. if ($self->{exceptions} && ! $self->_option_request($sock, 'exceptions')) { warn "Exceptions support denied by server, disabling.\n"; $self->{exceptions} = 0; } 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 (); } sub prefix { my Gearman::Client $self = shift; return $self->{prefix} unless @_; $self->{prefix} = shift; } sub debug { my Gearman::Client $self = shift; $self->{debug} = shift if @_; return $self->{debug} || 0; } 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 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 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 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 (see below) to initialize the list of job servers. Value in this case should be an arrayref. =item * prefix Calls I (see below) to set the prefix / namespace. =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-Edo_task($task) =head2 $client-Edo_task($funcname, $arg, \%options) Dispatches a task and waits on the results. May either provide a L 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-Edispatch_background($task) =head2 $client-Edispatch_background($funcname, $arg, \%options) Dispatches a task and doesn't wait for the result. Return value is an opaque scalar that can be used to refer to the task. =head2 $taskset = $client-Enew_task_set Creates and returns a new I object. =head2 $taskset-Eadd_task($task) =head2 $taskset-Eadd_task($funcname, $arg, $uniq) =head2 $taskset-Eadd_task($funcname, $arg, \%options) Adds a task to a taskset. Three different calling conventions are available. =head2 $taskset-Ewait Waits for a response from the job server for any of the tasks listed in the taskset. Will call the I handlers for each of the tasks that have been completed, updated, etc. Doesn't return until everything has finished running or failing. =head2 $client-Eprefix($prefix) Sets the namespace / prefix for the function names. See L for more details. =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 documentation for the worker for the I function. =head1 COPYRIGHT Copyright 2006-2007 Six Apart, Ltd. License granted to use/distribute under the same terms as Perl itself. =head1 WARRANTY This is free software. This comes with no warranty whatsoever. =head1 AUTHORS Brad Fitzpatrick (brad@danga.com) Jonathan Steinert (hachi@cpan.org) =cut =cut Gearman-1.11/CHANGES0000644000175000017500000001167611324750716014212 0ustar dormandodormando1.11 (2010-01-17) -- Switch read_res_packet to use sysread with a large buffer and offsets. This improves memory usage (sometimes drastically) and performance. -- Fix from Martin Atkins, don't print() in the Gearman::Util code and close sockets when you have an error of some kind (indicating we're out of sync) 1.10 (2009-10-04) -- Make workers wake up periodically for a particular server to make sure they aren't stale connections. This happened naturally (although at relatively low interval) in previous releases. -- Help prevent leaks when Gearman::Task->add_hook is used. -- Change worker to only 'wake up' against a gearmand that has woken it up, this prevents a constant flood of pre-sleep command from arriving at an otherwise silent gearmand. -- Fix issue where prefixes were double-prepended on function names on worker upon reconnect. -- Fix issue where the other response parser code in Util would silently truncate argument strings longer than 20*the socket buffer size. -- Fix issue where the ResponseParser class would not correctly handle messages with zero-length bodies. -- Make the Gearman::Task class autoload Storable and fail gracefully when it's not loadable. -- Initial fold-in of exceptions support in the gearman client, makes an option to the gearman server to enable it, and is disabled by default. Workers will will attempt to throw exceptions anytime Storable is available. -- fix jobs of > 32kilobytes in size so they work properly (workers would disconnect when a job greater than 32kb would arrive.) -- expose the time that the last job was processed in the stop_if hook of worker. Since a jobserver wakes up all workers in the case of a new job to be processed the concept of is_idle doesn't actually reflect if a worker has procssed jobs, rather it indicates whether the jobserver has been silent for 10 seconds. -- change server polling order in workers to start at a random point in the list during every worker pass. So we drain jobs from all servers rather than working on each of them in order. 1.09 (2007-06-29) -- document the license and copyright 1.08 (2007-05-21) -- add "package Gearman::Objects" line to Objects.pm, to ease RPM building -- reserve the packet number for "all_yours", not yet implemented -- In pack_res_command, silence any warnings about 'undefined' or 'uninitialized' variables if we aren't sending an argument along with the command. 1.07 (2007-05-07) -- continued improved support for child processes as workers, making workers go away cleanly if parent pipe dies/EPIPEs. 1.06 (2007-05-04) -- better support for Gearman::Workers as child processes talking to a Gearman::Server over unix pipe to parent -- In worker class, broke out the on connection work, and use that better in the case of being a sub process of the gearmand. 1.05 (2007-04-26) -- update the prefix code to not break Gearman::Client::Async, which was also updated to be compatible. -- Add ability for workers to be launched as sub processes of the gearmand, using a duped socketpair for communication. -- just some extra debugging/deaths during weird cases (helped find bugs when server code was massively refactored) 1.04 (2007-04-16) -- Let Gearman::Worker use hostnames for job_servers (like Gearman::Client does) (Ask) -- Add prefix setting to Gearman::Client and Gearman::Worker for simple namespace separation of different instances of the same worker and client code sharing job servers. (Ask Bjoern Hansen) -- Refactor tests to have less duplicate code (Ask Bjoern Hansen) -- Make Gearman::Client / Gearman::Worker tests use $^X instead of hardcoded 'perl' to start gearmand (Ask Bjoern Hansen) 1.03 -- Workers can now specify a timeout that when a task exceeds the time, the jobserver will reassign the task and ignore results from the defunct job. 1.02 -- Task objects weren't reusable before anyway, and now they're really not: when they complete or fail, they wipe all their internal subref members to break any potential loops. also now support a new internal hook that happens after your on_complete or on_failure callback. this is used by Gearman::Client::Async now, for cancelling timers. 1.01 -- when workers are writing status messages up to parent, die on SIGPIPE, or really any write errors, but just trap SIGPIPE now, if parent goes away. fixes a bug found via Gearman::Client::Async's test suite. 1.00 -- finally package it up and call it 1.00 now that we've been using it in (LiveJournal) production for quite a while, finding/fixing the bugs that happen when you put something into production. Gearman-1.11/MANIFEST.SKIP0000644000175000017500000000064711262246612015105 0ustar dormandodormando# Avoid version control files. \bRCS\b \bCVS\b ,v$ \B\.svn\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib$ # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# # Avoid debian directory, and rpm specfiles. \bdebian\b \.spec$ # Don't put the shipit file in distros ^\.shipit$ build.pl Gearman-1.11/META.yml0000644000175000017500000000052611324751023014450 0ustar dormandodormando# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Gearman version: 1.11 version_from: lib/Gearman/Client.pm installdirs: site requires: String::CRC32: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30