Gearman-2.004.015/0000755000175000017500000000000013340015301012345 5ustar palikpalikGearman-2.004.015/t/0000755000175000017500000000000013340015301012610 5ustar palikpalikGearman-2.004.015/t/Server.pm0000644000175000017500000000434313340014347014431 0ustar palikpalikpackage t::Server; use strict; use warnings; use base qw/Exporter/; use fields qw/ _bin _ip _servers /; use File::Which (); use Test::TCP; use vars qw/ $ERROR /; our @EXPORT = qw/ $ERROR /; sub new { my ($self) = @_; unless (ref $self) { $self = fields::new($self); } if ($ENV{GEARMAND_ADDR}) { $self->{_servers} = [split ',', $ENV{GEARMAND_ADDR}]; } else { my $daemon = "gearmand"; my $bin = $ENV{GEARMAND_PATH} || File::Which::which($daemon); unless ($bin) { $ERROR = "Can't find $daemon to test with"; } elsif (!-X $bin) { $ERROR = "$bin is not executable"; } $self->{_ip} = $ENV{GEARMAND_IP} || "127.0.0.1"; $self->{_bin} = $bin; $self->{_servers} = []; } ## end else [ if ($ENV{GEARMAND_ADDR...})] return $self; } ## end sub new sub _start_server { my ($self) = @_; $ERROR && return; my $s = Test::TCP->new( host => $self->host, code => sub { my $port = shift; my %args = ( "--port" => $port, "--listen" => $self->host, ); # for Gearman::Server sake. It complains "Unknown option: log-file" if (-B $self->bin()) { $args{"--log-file"} = $ENV{GEARMAND_LOG_FILE} || "/dev/stderr"; if ($ENV{GEARMAND_DEBUG}) { $args{"--verbose"} = "DEBUG"; } } ## end if (-B $self->bin()) exec($self->bin(), %args) or do { $ERROR = sprintf "cannot execute %s: $!", $self->bin; }; }, ); ($ERROR) && return; return $s; } ## end sub _start_server sub job_servers { my ($self, $count) = @_; $self->bin || return @{ $self->{_servers} }; $count ||= 1; my @r; while ($count--) { my $s = $self->_start_server; $s || return; push @{ $self->{_servers} }, $s; push @r, { host => $self->host, port => $s->port }; } ## end while ($count--) return wantarray ? @r : $r[0]; } ## end sub job_servers sub bin { return shift->{_bin}; } sub host { return shift->{_ip}; } 1; Gearman-2.004.015/t/04-task.t0000644000175000017500000001243313340014354014172 0ustar palikpalikuse strict; use warnings; use Storable; use Test::More; use Test::Exception; plan tests => 33; use_ok("Gearman::Client"); use_ok("Gearman::Taskset"); use_ok("Gearman::Util"); my $mn = "Gearman::Task"; use_ok($mn); can_ok( $mn, qw/ add_hook complete data exception fail final_fail func handle hash is_finished mode pack_submit_packet run_hook set_on_post_hooks status taskset timeout warning wipe / ); my ($f, $arg) = qw/ foo bar /; my %opt = ( uniq => rand(10), on_complete => 1, on_fail => 2, on_exception => 3, on_retry => undef, on_status => 4, retry_count => 6, try_timeout => 7, background => 1, timeout => int(rand(10)), ); throws_ok { $mn->new($f, \$arg, { $f => 1 }) } qr/Unknown option/, "caught unknown option exception"; my $t = new_ok($mn, [$f, \$arg, {%opt}]); is($t->func, $f, "func"); is(${ $t->{argref} }, $arg, "argref"); foreach (keys %opt) { is($t->can($_) ? $t->$_ : $t->{$_}, $opt{$_}, $_); } is($t->{$_}, 0, $_) for qw/ is_finished retries_done /; subtest "priority mode", sub { plan tests => 21; foreach my $p (qw/low normal high/) { my $s = sprintf("submit_job%s", $p eq "normal" ? '' : '_' . $p); my $t = new_ok($mn, [$f, undef, { priority => $p }]); is($t->_priority(), $p, "$p priority"); is($t->mode(), $s, "mode of task in $p prioirty"); $t = new_ok($mn, [$f, undef, { background => 1, priority => $p }]); is( $t->mode(), join('_', $s, "bg"), "mode of background task in $p prioirty" ); } ## end foreach my $p (qw/low normal high/) { my $s = "submit_job"; my $t = new_ok($mn, [$f, undef]); is($t->mode(), $s, "mode of task without explicit priority"); $s .= "_high"; $t = new_ok($mn, [$f, undef, { high_priority => 1 }]); is($t->mode(), $s, "mode of task with high_priority=1"); $t = new_ok($mn, [$f, undef, { background => 1, high_priority => 1 }]); is( $t->mode(), join('_', $s, "bg"), "mode of background task with high_prioirty=1" ); } }; my @h = qw/ on_post_hooks on_complete on_fail on_retry on_status hooks /; subtest "wipe", sub { plan tests => scalar(@h); $t->{$_} = 1 for @h; $t->wipe(); is($t->{$_}, undef, $_) for @h; }; subtest "hook", sub { plan tests => 4; my $cb = sub { 2 * shift }; ok($t->add_hook($f, $cb)); is($t->{hooks}->{$f}, $cb); $t->run_hook($f, 2); ok($t->add_hook($f)); is($t->{hooks}->{$f}, undef); }; subtest "taskset", sub { plan tests => 9; is($t->taskset, undef, "taskset"); throws_ok { $t->taskset($f) } qr/not an instance of Gearman::Taskset/, "caught taskset($f) exception"; my $c = new_ok("Gearman::Client"); my $ts = new_ok("Gearman::Taskset", [$c]); ok($t->taskset($ts)); is($t->taskset(), $ts); is($t->hash(), $t->hash()); $t->{uniq} = '-'; is($t->taskset(), $ts); is($t->hash(), $t->hash()); }; subtest "fail", sub { plan tests => 2 * scalar(@h) - 1; $t->{is_finished} = 1; is($t->fail(), undef); $t->{is_finished} = undef; $t->{on_retry} = sub { is(shift, $t->{retry_count}, "on_retry") }; $t->{retries_done} = 0; $t->{retry_count} = 1; $t->fail($f); is($t->{retries_done}, $t->{retry_count}, "retries_done = retry_count"); $t->{is_finished} = undef; $t->{on_fail} = sub { is(shift, $f, "on_fail") }; $t->final_fail($f); is($t->{is_finished}, $f); is($t->{$_}, undef, $_) for @h; }; subtest "exception", sub { plan tests => 2; my $exc = Storable::freeze(\$f); $t->{on_exception} = sub { is(shift, $f) }; is($t->exception(\$exc), undef); }; subtest "complete", sub { plan tests => 2; $t->{is_finished} = undef; $t->{on_complete} = sub { is(shift, $f) }; $t->complete($f); is($t->{is_finished}, "complete"); }; subtest "status", sub { plan tests => 3; $t->{is_finished} = undef; $t->{on_status} = sub { is(shift, $f, "func"); is(shift, $arg, "arg"); }; ok $t->status($f, $arg), "status"; }; subtest "data", sub { plan tests => 2; $t->{is_finished} = undef; $t->{on_data} = sub { is(shift, $f, "func") }; ok $t->data($f), "data"; }; subtest "warning", sub { plan tests => 2; $t->{is_finished} = undef; $t->{on_warning} = sub { is(shift, $f, "func") }; ok $t->warning($f), "warning"; }; subtest "handle", sub { plan tests => 2; ok($t->handle($f)); is($t->{handle}, $f); }; subtest "pack_submit_packet", sub { plan tests => 5; my $c = new_ok("Gearman::Client"); my $v = Gearman::Util::pack_req_command($t->mode, join("\0", $t->func, $t->{uniq}, ${ $t->{argref} })); is $t->pack_submit_packet($c), $v; is $t->pack_submit_packet(), $v; $v = Gearman::Util::pack_req_command($t->mode, join("\0", $t->func, '', '')); ${ $t->{argref} } = undef; $t->{uniq} = undef; is $t->pack_submit_packet($c), $v; is $t->pack_submit_packet(), $v; }; done_testing(); Gearman-2.004.015/t/18-ssl.t0000644000175000017500000001111413340014354014031 0ustar palikpalikuse strict; use warnings; use List::Util qw/ sum /; use Storable qw/ freeze thaw /; use Test::More; use Test::Timer; use lib '.'; use t::Worker qw/ new_worker /; BEGIN { use IO::Socket::SSL (); if (defined($ENV{SSL_DEBUG})) { $IO::Socket::SSL::DEBUG = $ENV{SSL_DEBUG}; } } ## end BEGIN { my @env = qw/ AUTHOR_TESTING SSL_GEARMAND_HOST SSL_GEARMAND_PORT SSL_CERT_FILE SSL_KEY_FILE /; my $skip; while (my $e = shift @env) { defined($ENV{$e}) && next; $skip = $e; last; } if ($skip) { plan skip_all => sprintf 'without $ENV{%s}', $skip; } else { plan tests => 7; } } my $debug = defined($ENV{SSL_DEBUG}) && $ENV{SSL_DEBUG}; my $job_server = { use_ssl => 1, host => $ENV{SSL_GEARMAND_HOST}, port => $ENV{SSL_GEARMAND_PORT}, ca_file => $ENV{SSL_CA_FILE}, cert_file => $ENV{SSL_CERT_FILE}, key_file => $ENV{SSL_KEY_FILE}, socket_cb => sub { my ($hr) = @_; # $hr->{SSL_cipher_list} = 'DEFAULT:!DH'; # 'ALL:!LOW:!EXP:!aNULL'; if (defined($ENV{SSL_VERIFY_MODE})) { $hr->{SSL_verify_mode} = eval "$ENV{SSL_VERIFY_MODE}"; } return $hr; } }; use_ok("Gearman::Client"); use_ok("Gearman::Worker"); subtest "client echo request", sub { plan tests => 8; my $client = _client(); ok(my $sock = $client->_get_random_js_sock(), "get socket"); my $msg = "$$ client echo request"; _echo($sock, $msg); }; subtest "worker echo request", sub { plan tests => 8; my $worker = new_ok( "Gearman::Worker", [ job_servers => [$job_server], debug => $debug, ] ); ok( my $sock = $worker->_get_js_sock( $worker->job_servers()->[0], on_connect => sub { return 1; } ), "get socket" ) || return; my $msg = "$$ worker echo request"; _echo($sock, $msg); }; subtest "sum", sub { plan tests => 2; my $func = "sum"; my $cb = sub { my $sum = 0; $sum += $_ for @{ thaw($_[0]->arg) }; return $sum; }; my $worker = new_worker( debug => $debug, func => { $func, $cb }, job_servers => [$job_server], ); my $client = _client(); my @a = map { int(rand(100)) } (0 .. int(rand(10) + 1)); my $sum = sum(@a); my $out = $client->do_task( sum => freeze([@a]), { on_fail => sub { fail(explain(@_)) }, } ); is($$out, $sum, "do_task returned $sum for sum"); }; subtest "large work result", sub { plan tests => 3; # work result > 16k my $length = 1024 * int(rand(5) + 17); my $func = "doit"; my $worker = new_worker( job_servers => [$job_server], debug => $ENV{DEBUG} || 0, func => { $func, sub { return 'x' x $length } } ); my $client = _client(); ok( my $v = $client->do_task( $func => undef, { on_fail => sub { fail(explain(@_)) }, } ), "$func" ); is length(${$v}), $length; }; subtest "large task data", sub { plan tests => 3; # task data > 16k my $length = 1024 * int(rand(5) + 17); my $func = "doit"; my $worker = new_worker( job_servers => [$job_server], debug => $ENV{DEBUG} || 0, func => { $func, sub { return length(shift->arg) } } ); my $v = 'x' x $length; my $client = _client(); ok( my $r = $client->do_task( $func => $v, { on_fail => sub { fail(explain(@_)) }, } ), "$func" ); is ${$r}, length($v); }; done_testing(); sub _echo { my ($sock, $msg) = @_; ok(my $req = Gearman::Util::pack_req_command("echo_req", $msg), "prepare echo req"); my $len = length($req); ok(my $rv = $sock->write($req, $len), "write to socket"); my $err; ok(my $res = Gearman::Util::read_res_packet($sock, \$err), "read respose"); is(ref($res), "HASH", "respose is a hash"); is($res->{type}, "echo_res", "response type"); is(${ $res->{blobref} }, $msg, "response blobref"); } ## end sub _echo sub _client { return new_ok( "Gearman::Client", [ debug => $debug, exceptions => 0, job_servers => [$job_server], ] ); } ## end sub _client Gearman-2.004.015/t/50-wait_timeout.t0000644000175000017500000000506013340014354015741 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 use Test::More; use Test::Timer; use lib '.'; use t::Server (); use t::Worker qw/ new_worker /; my $gts = t::Server->new(); my @job_servers = $gts->job_servers(); @job_servers || plan skip_all => $t::Server::ERROR; my $func = "long"; use_ok("Gearman::Client"); my $client = new_ok("Gearman::Client", [job_servers => @job_servers]); my $worker = new_worker( job_servers => [@job_servers], func => { $func => sub { my ($job) = @_; $job->set_status(50, 100); sleep 2; $job->set_status(100, 100); sleep 2; return $job->arg; } } ); subtest "wait with timeout", sub { plan tests => 10; ok(my $tasks = $client->new_task_set, "new_task_set"); isa_ok($tasks, 'Gearman::Taskset'); my ($iter, $completed, $failed) = (0, 0, 0); my $opt = { uniq => $iter, on_complete => sub { $completed++; note "Got result for $iter"; }, on_fail => sub { $failed++; }, }; # For a total of 5 events, that will be 20 seconds; till they complete. foreach $iter (1 .. 5) { ok($tasks->add_task($func, $iter, $opt), "add_task('$func', $iter)"); } my $to = 11; time_ok(sub { $tasks->wait(timeout => $to) }, $to, "timeout"); ok($completed > 0, "at least one job is completed"); is($failed, 0, "no failed jobs"); }; subtest "$func args", sub { ($ENV{AUTHOR_TESTING} && $ENV{AUTHOR_TESTING} == 2) || plan skip_all => 'without $ENV{AUTHOR_TESTING}'; plan tests => 3; my $arg = 'x' x (5 * 1024 * 1024); my $m; my $tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); $tasks->add_task( $func, \$arg, { on_complete => sub { my $rr = shift; if (length($$rr) != length($arg)) { $m = join ' ', "Large job failed size check: got", length($$rr), ", want", length($arg); } elsif ($$rr ne $arg) { $m = "Large job failed content check"; } else { $m = "Large job succeeded"; } }, on_fail => sub { $m = "Large job failed"; }, } ); my $to = 10; time_ok(sub { $tasks->wait(timeout => $to) }, $to, "timeout"); is($m, "Large job succeeded", "Large job succeeded"); }; done_testing(); Gearman-2.004.015/t/03-worker.t0000644000175000017500000001077513340014354014547 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server v1.130.2 use Net::EmptyPort qw/ empty_port /; use Test::More; use Test::Timer; use Test::Exception; use lib '.'; use t::Server (); my $mn = "Gearman::Worker"; use_ok($mn); can_ok( $mn, qw/ _get_js_sock _job_request _register_all _set_ability _set_client_id _uncache_sock job_servers register_function reset_abilities send_work_complete send_work_data send_work_exception send_work_fail send_work_status send_work_warning unregister_function work / ); subtest "new", sub { plan tests => 8; my $client_id = 1 + rand(100000); my $w = new_ok($mn, [client_id => $client_id]); isa_ok($w, 'Gearman::Objects'); is(ref($w->{$_}), "HASH", "$_ is a hash ref") for qw/ last_connect_fail down_since can timeouts /; is $w->{client_id}, $client_id, "client_id"; SKIP: { $ENV{AUTHOR_TESTING} || skip 'GEARMAN_WORKER_USE_STDIO without $ENV{AUTHOR_TESTING}', 1; $ENV{GEARMAN_WORKER_USE_STDIO} = 1; throws_ok { $mn->new(debug => 1); } qr/Unable to initialize connection to gearmand/, "GEARMAN_WORKER_USE_STDIO env"; undef($ENV{GEARMAN_WORKER_USE_STDIO}); } ## end SKIP: }; subtest "register_function", sub { plan tests => 8; my $w = new_ok($mn); my ($tn, $to) = qw/foo 2/; my $cb = sub {1}; is $w->register_function($tn => $cb), undef, "register_function($tn)"; time_ok( sub { $w->register_function($tn, $to, $cb); }, $to, "register_function($to, cb)" ); SKIP: { my @job_servers = t::Server->new()->job_servers(int(rand(2) + 2)); @job_servers || skip $t::Server::ERROR, 5; ok $w->job_servers(@job_servers), "set job servers"; ok $w->register_function($tn, $to, $cb), "register_function"; is $w->{can}{$tn}, $cb, "can $tn"; ok $w->unregister_function($tn), "unregister_function"; is $w->{can}{$tn}, undef, "can not $tn"; } ## end SKIP: }; subtest "reset_abilities", sub { plan tests => 4; my $w = new_ok($mn); $w->{can}->{x} = 1; $w->{timeouts}->{x} = 1; ok($w->reset_abilities()); is(keys %{ $w->{can} }, 0); is(keys %{ $w->{timeouts} }, 0); }; subtest "work", sub { plan tests => 3; # my $gts = t::Server->new(); SKIP: { my @job_servers = t::Server->new()->job_servers(); @job_servers || skip $t::Server::ERROR, 3; my $w = new_ok($mn, [job_servers => @job_servers]); time_ok( sub { $w->work(stop_if => sub { my ($idle) = @_; is $idle, 1, "stop work if idle"; return 1; }); }, 12, "stop if timeout" ); } ## end SKIP: }; subtest "_get_js_sock", sub { plan tests => 8; my $w = new_ok($mn); is($w->_get_js_sock(), undef, "_get_js_sock() returns undef"); $w->{parent_pipe} = rand(10); my $js = { host => "127.0.0.1", port => empty_port() }; is($w->_get_js_sock($js), $w->{parent_pipe}, "parent_pipe"); delete $w->{parent_pipe}; is($w->_get_js_sock($js), undef, "_get_js_sock(...) undef"); SKIP: { my @job_servers = t::Server->new()->job_servers(); @job_servers || skip $t::Server::ERROR, 4; ok($w->job_servers(@job_servers)); $js = $w->job_servers()->[0]; my $js_str = $w->_js_str($js); $w->{last_connect_fail}{$js_str} = 1; $w->{down_since}{$js_str} = 1; isa_ok($w->_get_js_sock($js, on_connect => sub {1}), "IO::Socket::IP"); is($w->{last_connect_fail}{$js_str}, undef); is($w->{down_since}{$js_str}, undef); } ## end SKIP: }; subtest "_set_ability", sub { plan tests => 7; my $w = new_ok($mn); my $m = "foo"; is($w->_set_ability(), 0); is($w->_set_ability(undef, $m), 0); is($w->_set_ability(undef, $m, 2), 0); SKIP: { my @job_servers = t::Server->new()->job_servers(); @job_servers || skip $t::Server::ERROR, 3; ok($w->job_servers(@job_servers)); my $js = $w->job_servers()->[0]; my $js_str = $w->_js_str($js); is($w->_set_ability($w->_get_js_sock($js), $m), 1); is($w->_set_ability($w->_get_js_sock($js), $m, 2), 1); } ## end SKIP: }; done_testing(); Gearman-2.004.015/t/02-client.t0000644000175000017500000001002413340014354014476 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server v1.130.2 use Test::More; use Test::Exception; use lib '.'; use t::Server (); my $mn = "Gearman::Client"; use_ok($mn); can_ok( $mn, qw/ _get_js_sock _get_random_js_sock _get_task_from_args _job_server_status_command _option_request add_hook dispatch_background do_task get_job_server_clients get_job_server_jobs get_job_server_status get_status new_task_set run_hook / ); subtest "new", sub { my $c = new_ok($mn); isa_ok($c, "Gearman::Objects"); is($c->{backoff_max}, 90, join "->", $mn, "{backoff_max}"); is($c->{command_timeout}, 30, join "->", $mn, "{command_timeout}"); is($c->{exceptions}, 0, join "->", $mn, "{exceptions}"); is($c->{js_count}, 0, "js_count"); is(keys(%{ $c->{hooks} }), 0, join "->", $mn, "{hooks}"); is(keys(%{ $c->{sock_cache} }), 0, join "->", $mn, "{sock_cache}"); }; subtest "new_task_set", sub { my $c = new_ok($mn); my $h = "new_task_set"; my $cb = sub { pass("$h cb") }; ok($c->add_hook($h, $cb), "add_hook($h, cb)"); is($c->{hooks}->{$h}, $cb, "$h eq cb"); isa_ok($c->new_task_set(), "Gearman::Taskset"); ok($c->add_hook($h), "add_hook($h)"); is($c->{hooks}->{$h}, undef, "no hook $h"); }; subtest "js socket", sub { my $gts = t::Server->new(); my @job_servers = $gts->job_servers(); @job_servers || plan skip_all => $t::Server::ERROR; my $gc = new_ok($mn, [job_servers => [@job_servers]]); foreach ($gc->job_servers()) { ok(my $s = $gc->_get_js_sock($_), "_get_js_sock($_)") || next; isa_ok($s, "IO::Socket::IP"); } ok($gc->_get_random_js_sock()); }; subtest 'Client: "on_fail" handler is triggered on timeout' => sub { my $gts = t::Server->new(); my @job_servers = $gts->job_servers(); @job_servers || plan skip_all => $t::Server::ERROR; my ($reason, $now, $then) = (q(NO REASON), time); my $c = new_ok($mn, [job_servers => [@job_servers]]); my $timeout = 2; my $initial_error = '"on_fail" was NOT triggered'; my $expected_error = '"on_fail" was triggered'; my $error = $initial_error; my $res_ref = $c->do_task( task_that_does_not_exist => '', { timeout => $timeout, on_fail => sub { ## keep the given reason ($reason) = @_; $then = time; $error = $expected_error; }, on_complete => sub { die '"on_complete" handler was called unexpectedly'; }, } ); lives_and { is($error, $expected_error) } '"on_fail" callback was triggered on timeout'; ok( (defined $then) && ($then - $now >= $timeout), "Timeout of ${timeout}s was elapsed" ); # check if reason was set as expected # fixes unwanted behaviour: # # Task task_that_does_not_exist elapsed timeout [1514988291.35953s] # # Should be (e.g.): # # Task task_that_does_not_exist elapsed timeout [2s] # # Proves fix of issue #35 # https://github.com/p-alik/perl-Gearman/issues/35 like( $reason, qr/Task [^[:space:]]+ elapsed timeout \[${timeout}s\]/, q(Failure reason contains given timeout value) ); $expected_error = qq(ALRM handler fired after ${timeout}s); throws_ok { local $SIG{ALRM} = sub { die $expected_error }; alarm $timeout; $res_ref = $c->do_task( task_that_does_not_exist => '', { on_fail => sub { $then = time; $error = $expected_error }, on_complete => sub { die '"on_complete" handler was called unexpectedly'; }, } ); alarm 0; } ## end throws_ok qr/$expected_error/, q(ALRM handler fired as expected); }; done_testing(); Gearman-2.004.015/t/40-prefix.t0000644000175000017500000000615513340014354014531 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server v1.130.2 use Test::More; use Time::HiRes qw/sleep/; use lib '.'; use t::Server (); use t::Worker qw/ new_worker /; my $gts = t::Server->new(); my @job_servers = $gts->job_servers(); @job_servers || plan skip_all => $t::Server::ERROR; use_ok("Gearman::Client"); use_ok("Gearman::Task"); subtest "echo prefix", sub { my @p = qw/ a b /; my ($func, %clients, %workers) = ("echo_prefix"); foreach (@p) { my $prefix = join '_', "prefix", $_; $clients{$_} = new_ok("Gearman::Client", [prefix => $prefix, job_servers => [@job_servers]]); $workers{$_} = new_worker( job_servers => [@job_servers], prefix => $prefix, func => { $func => sub { join " from ", $_[0]->arg, $prefix; } } ); } ## end foreach (@p) # basic do_task test foreach (@p) { is( ${ $clients{$_}->do_task("echo_prefix", "beep test") }, join('_', "beep test from prefix", $_), join(' ', "basic do_task() - prefix", $_) ); is( ${ $clients{$_}->do_task( Gearman::Task->new("echo_prefix", \('beep test')) ) }, join('_', "beep test from prefix", $_), join(' ', "Gearman::Task do_task() - prefix", $_) ); } ## end foreach (@p) my %out; my %tasks = map { $_ => $clients{$_}->new_task_set() } @p; for my $k (keys %tasks) { $out{$k} = ''; $tasks{$k}->add_task( 'echo_prefix' => "$k", { on_complete => sub { $out{$k} .= ${ $_[0] } } } ); } ## end for my $k (keys %tasks) $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 subtest "dispatch background", sub { my ($func, $prefix) = qw/ echo_sleep prefix_a /; my $client = new_ok("Gearman::Client", [prefix => $prefix, job_servers => [@job_servers]]); my $worker = new_worker( job_servers => [@job_servers], prefix => $prefix, func => { $func => sub { my ($job) = @_; $job->set_status(1, 1); ## allow some time to read the status sleep 2; join " from ", $_[0]->arg, $prefix; } } ); my $bg_task = new_ok("Gearman::Task", [$func, \("sleep prefix test")]); ok(my $handle = $client->dispatch_background($bg_task), "dispatch_background returns a handle"); # 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->get_status($handle); } until ($status->percent && $status->percent == 1) or $n == 20; is($status->percent, 1, "Background task completed using prefix"); }; done_testing(); Gearman-2.004.015/t/08-jobstatus.t0000644000175000017500000000156013340014354015251 0ustar palikpalikuse strict; use warnings; use Test::More; my ($mn) = qw/ Gearman::JobStatus /; use_ok($mn); can_ok( $mn, qw/ known percent progress running / ); subtest "known", sub { is(new_ok($mn, [])->known(), undef); is(new_ok($mn, [1])->known(), 1); }; subtest "running", sub { is(new_ok($mn, [])->running(), undef); is(new_ok($mn, [undef, 1])->running(), 1); }; subtest "progress/percent", sub { my $js = new_ok($mn, []); is($js->progress(), undef); is($js->percent(), undef); my @x = (int(rand(2)), int(rand(1)) + 1); $js = new_ok($mn, [undef, undef, @x]); my $p = $js->progress(); is(@{$p}, @x); is($p->[0], $x[0]); is($p->[1], $x[1]); is($js->percent(), $x[0] / $x[1]); $x[1] = 0; is(new_ok($mn, [undef, undef, @x])->percent(), undef); }; done_testing(); Gearman-2.004.015/t/11-unit.t0000644000175000017500000000443213340014354014205 0ustar palikpalikuse strict; use warnings; use Test::More; use Test::Exception; use IO::Socket::IP; use Perl::OSType qw/ is_os_type /; my $mn = "Gearman::Util"; use_ok($mn); no strict "refs"; my @chr = ('a' .. 'z', 'A' .. 'Z', 0 .. 9); ok(my %cmd = %{"$mn\:\:cmd"}); is(keys(%cmd), 31); foreach my $n (keys %cmd) { my $t = $cmd{$n}->[1]; my $a = join '', map { @chr[rand @chr] } 0 .. int(rand(20)) + 1; is(&{"$mn\:\:cmd_name"}($n), $t, "$mn\:\:cmd($n) = $t"); is( &{"$mn\:\:pack_req_command"}($t), join('', "\0REQ", pack("NN", $n, 0), ''), "$mn\:\:pack_req_command}($t)" ); is( &{"$mn\:\:pack_res_command"}($t), join('', "\0RES", pack("NN", $n, 0), ''), "$mn\:\:pack_res_command}($t)" ); is( &{"$mn\:\:pack_req_command"}($t, $a), join('', "\0REQ", pack("NN", $n, length($a)), $a), "$mn\:\:pack_req_command}($t, $a)" ); is( &{"$mn\:\:pack_res_command"}($t, $a), join('', "\0RES", pack("NN", $n, length($a)), $a), "$mn\:\:pack_res_command}($t)" ); } ## end foreach my $n (keys %cmd) throws_ok(sub { &{"$mn\:\:pack_req_command"}() }, qr/Bogus type arg of/); throws_ok(sub { &{"$mn\:\:pack_req_command"}('x') }, qr/Bogus type arg of/); throws_ok(sub { &{"$mn\:\:pack_res_command"}() }, qr/Bogus type arg of/); throws_ok(sub { &{"$mn\:\:pack_res_command"}('x') }, qr/Bogus type arg of/); #TODO read_res_packet # use Socket qw/ # IPPROTO_TCP # TCP_NODELAY # SOL_SOCKET # PF_INET # SOCK_STREAM # /; # subtest "read_res_packet", sub { # my $s = IO::Socket::INET->new( # # PeerAddr => "localhost:4730", # # Timeout => 1 # ); # # $s->autoflush(1); # # setsockopt($s, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; # is(&{"$mn\:\:read_res_packet"}($s, \my $e), undef); # is($e, "eof"); # }; subtest "read_text_status", sub { is(&{"$mn\:\:read_text_status"}(IO::Socket::IP->new(), \my $e), undef); is($e, "can't read from unconnected socket"); }; subtest "send_req", sub { is(&{"$mn\:\:send_req"}(IO::Socket::IP->new(), \"foo"), 0); }; subtest "wait_for_readability", sub { is_os_type("Windows") && plan skip_all => "Windows test in TODO"; is(&{"$mn\:\:wait_for_readability"}(2, 3), 0); }; done_testing(); Gearman-2.004.015/t/13-fail.t0000644000175000017500000000624013340014354014142 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 use Test::More; use lib '.'; use t::Server (); use t::Worker qw/ new_worker /; my $gts = t::Server->new(); my $job_server = $gts->job_servers(); $job_server || plan skip_all => $t::Server::ERROR; use_ok("Gearman::Client"); my $client = new_ok( "Gearman::Client", [ exceptions => 1, job_servers => [$job_server] ] ); ## Test some failure conditions: ## Normal failure (worker returns undef or dies within eval). subtest "wokrker process fails", sub { plan tests => 7; my $func = "fail"; my @workers = map(new_worker( job_servers => [$job_server], func => { $func => sub {} } ), (0 .. int(rand(1) + 1))); is( $client->do_task( $func, undef, { on_fail => sub { pass "on fail callback" }, } ), undef, "Job that failed naturally returned undef" ); ## Test retry_count. my $retried = 0; is( $client->do_task( $func => '', { on_retry => sub { $retried++ }, on_fail => sub { pass "on fail callback" }, retry_count => 3, } ), undef, "Failure response is still failure, even after retrying" ); is($retried, 3, "Retried 3 times"); my $ts = $client->new_task_set; my ($completed, $failed) = (0, 0); $ts->add_task( $func => '', { on_complete => sub { $completed = 1 }, on_fail => sub { $failed = 1 }, } ); $ts->wait; is($completed, 0, "on_complete not called"); is($failed, 1, "on_fail called on failed result"); }; subtest "worker process dies", sub { plan skip_all => "subtest fails with gearman v1.1.12"; my $func = "fail_die"; my $worker = new_worker( job_servers => [$job_server], func => { $func => sub { die "test reason" } } ); # the die message is available in the on_fail sub my $msg = undef; my $tasks = $client->new_task_set; $tasks->add_task( $func, undef, { on_exception => sub { $msg = shift }, on_fail => sub { fail(explain(@_)) }, } ); $tasks->wait; like( $msg, qr/test reason/, "the die message is available in the on_fail sub" ); }; ## Worker process exits. subtest "worker process exits", sub { plan skip_all => "TODO supported only by Gearman::Server"; my $func = "fail_exit"; my @workers = map(new_worker( job_servers => [$job_server], func => { $func => sub { exit 255 } } ), (0 .. int(rand(1) + 1))); is( $client->do_task( $func, undef, { on_fail => sub { warn "on fail" }, on_complete => sub { warn "on success" }, on_status => sub { warn "on status" } } ), undef, "Job that failed via exit returned undef" ); }; done_testing(); Gearman-2.004.015/t/10-job.t0000644000175000017500000000113613340014354013775 0ustar palikpalikuse strict; use warnings; use Test::More; use Test::Exception; my ($mn) = qw/ Gearman::Job /; use_ok($mn); can_ok( $mn, qw/ set_status argref arg handle / ); my %arg = ( func => "foo", argref => \rand(10), handle => "H:127.0.0.1:123", js => "127.0.0.1:4730", jss => "sock" ); my $j = new_ok($mn, [%arg]); is($j->handle(), $arg{handle}); is($j->argref(), $arg{argref}); is($j->arg(), ${ $arg{argref} }); is($j->{jss}, $arg{jss}); is($j->{js}, $arg{js}); dies_ok { $j->set_status(qw/a b/) }; done_testing(); Gearman-2.004.015/t/12-sum.t0000644000175000017500000000473413340014354014040 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 use List::Util qw/ sum /; use Storable qw/ freeze thaw /; use Test::Exception; use Test::More; use lib '.'; use t::Server (); use t::Worker qw/ new_worker /; my $gts = t::Server->new(); my @job_servers = $gts->job_servers(int(rand(1) + 1)); @job_servers || plan skip_all => $t::Server::ERROR; plan tests => 4; use_ok("Gearman::Client"); my $client = new_ok("Gearman::Client", [exceptions => 1, job_servers => [@job_servers]]); my $func = "sum"; my $cb = sub { my $sum = 0; $sum += $_ for @{ thaw($_[0]->arg) }; return $sum; }; my @workers = map(new_worker(job_servers => [@job_servers], func => { $func, $cb }), (0 .. int(rand(1) + 1))); subtest "taskset 1", sub { plan tests => 7; throws_ok { $client->do_task(sum => []) } qr/Function argument must be scalar or scalarref/, 'do_task does not accept arrayref argument'; my @a = _rl(); my $sum = sum(@a); my $out = $client->do_task( sum => freeze([@a]), { on_fail => sub { fail(explain(@_)) }, on_complete => sub { pass "on complete hook" } } ); is($$out, $sum, "do_task returned $sum for sum"); undef($out); isa_ok my $ts = $client->new_task_set, "Gearman::Taskset"; my $failed = 0; ok my $handle = $ts->add_task( sum => freeze([@a]), { on_complete => sub { $out = ${ $_[0] } }, on_fail => sub { $failed = 1 } } ), "add task"; note "wait"; $ts->wait; is($out, $sum, "add_task/wait returned $sum for sum"); is($failed, 0, 'on_fail not called on a successful result'); }; subtest "taskset 2", sub { plan tests => 5; isa_ok my $ts = $client->new_task_set, "Gearman::Taskset"; my @a = _rl(); my $sa = sum(@a); my @sums; ok $ts->add_task( sum => freeze([@a]), { on_complete => sub { $sums[0] = ${ $_[0] } }, } ), "add task"; my @b = _rl(); my $sb = sum(@b); ok $ts->add_task( sum => freeze([@b]), { on_complete => sub { $sums[1] = ${ $_[0] } }, on_fail => sub { fail(explain(@_)) } } ), "add task"; $ts->wait; is($sums[0], $sa, "First task completed (sum is $sa)"); is($sums[1], $sb, "Second task completed (sum is $sb)"); }; done_testing(); sub _rl { return map { int(rand(100)) } (0 .. int(rand(10) + 1)); } Gearman-2.004.015/t/20-send-work-command.t0000644000175000017500000000436213340014354016555 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 use Proc::Guard; use Test::Exception; use Test::More; use Storable qw/ freeze thaw /; # because no Gearman::Server do not support protocol commands WORK_DATA and WORK_WARNING $ENV{AUTHOR_TESTING} || plan skip_all => 'without $ENV{AUTHOR_TESTING}'; use lib '.'; use t::Server (); my $gts = t::Server->new(); my @job_servers = $gts->job_servers(int(rand(1) + 1)); @job_servers || plan skip_all => $t::Server::ERROR; use_ok("Gearman::Client"); use_ok("Gearman::Worker"); my $func = "sum"; my @a = map { int(rand(100)) } (0 .. int(rand(10) + 5)); foreach my $method (qw/data warning/) { my $str = join('_', "work", $method); subtest $str, sub { plan tests => 3; my $client = new_ok("Gearman::Client", [exceptions => 1, job_servers => [@job_servers]]); my $worker = worker( join('_', "send", $str), job_servers => [@job_servers], debug => $ENV{DEBUG} ); my ($i, $r) = (0, 0); my $res = $client->do_task( $func => freeze([@a]), { join('_', "on", $method) => sub { my ($ref) = @_; $r += $a[$i]; $i++; }, on_exception => sub { fail("exception") } }, ); is(scalar(@a), $i, "on_$method count"); is(${$res}, $r, "$func result"); }; } ## end foreach my $method (qw/data warning/) done_testing(); sub worker { my ($send_method, %args) = @_; my $w = Gearman::Worker->new(%args); my $cb = sub { my ($job) = @_; my $sum = 0; my @i = @{ thaw($job->arg) }; foreach (@i) { $sum += $_; $w->$send_method($job, $sum); } return $sum; }; $w->register_function($func, $cb); my $pg = Proc::Guard->new( code => sub { $w->work( on_fail => sub { fail join ' ', "on fail", @_; }, stop_if => sub { my ($idle) = @_; return $idle; } ); } ); return $pg; } ## end sub worker Gearman-2.004.015/t/15-priority.t0000644000175000017500000000522613340014354015115 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server v1.130.2 use List::Util; use Test::More; use lib '.'; use t::Server (); use t::Worker qw/ new_worker /; my $gts = t::Server->new(); my @job_servers = $gts->job_servers(); @job_servers || plan skip_all => $t::Server::ERROR; use_ok("Gearman::Client"); my $client = new_ok("Gearman::Client", [exceptions => 1, job_servers => [@job_servers]]); ## 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. subtest "hight priority", sub { my $tasks = $client->new_task_set; my $out = ''; $tasks->add_task( echo_ws => 1, { on_complete => sub { $out .= ${ $_[0] } }, on_fail => sub { fail(explain(@_)) }, } ); $tasks->add_task( echo_ws => 2, { on_complete => sub { $out .= ${ $_[0] } }, on_fail => sub { fail(explain(@_)) }, } ); $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] } }, on_fail => sub { fail(explain(@_)) }, } ); $tasks->add_task( echo_ws => 4, { on_complete => sub { $out .= ${ $_[0] } }, on_fail => sub { fail(explain(@_)) }, } ); $tasks->add_task( echo_ws => 5, { on_complete => sub { $out .= ${ $_[0] } }, on_fail => sub { fail(explain(@_)) }, } ); $tasks->add_task( echo_ws => 6, { on_complete => sub { $out .= ${ $_[0] } }, on_fail => sub { fail(explain(@_)) }, } ); note "start workers"; my $pg = new_worker( job_servers => [@job_servers], func => { echo_ws => sub { select undef, undef, undef, 0.25; $_[0]->arg eq 'x' ? undef : $_[0]->arg; } } ); note "worker pid:", $pg->pid; note "wait"; $tasks->wait; like($out, qr/p.+6/, 'High priority tasks executed in priority order.'); }; done_testing(); Gearman-2.004.015/t/25-work-finish-command.t0000644000175000017500000000626513340014354017115 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.1.15 use Proc::Guard; use Test::Exception; use Test::More; use List::Util qw/ sum /; use Storable qw/ freeze thaw /; use lib '.'; use t::Server (); my $gts = t::Server->new(); my @job_servers = $gts->job_servers(int(rand(1) + 1)); @job_servers || plan skip_all => $t::Server::ERROR; plan tests => 6; use_ok("Gearman::Client"); use_ok("Gearman::Worker"); my $func = "sum"; my @a = map { int(rand(100)) } (0 .. int(rand(10) + 5)); my $arg = freeze([@a]); my $client = new_ok("Gearman::Client", [exceptions => 1, job_servers => [@job_servers]]); subtest "work complete", sub { plan tests => 3; ok(my $worker = worker_complete(job_servers => [@job_servers]), "worker"); ok my $res = $client->do_task( $func => $arg, { on_exception => sub { fail("exception") } }, ), "do task"; is(${$res}, sum(@a), "result"); }; subtest "work fail", sub { # Gearman::Server does not support protocol commands WORK_WARNING $ENV{AUTHOR_TESTING} || plan skip_all => 'without $ENV{AUTHOR_TESTING}'; plan tests => 3; ok(my $worker = worker_fail(job_servers => [@job_servers]), "worker"); my $res = $client->do_task( $func => $arg, { on_fail => sub { is(shift, "jshandle fail", "on fail callback"); }, on_exception => sub { fail("exception") } }, ); is($res, undef, "no result"); }; subtest "work exception", sub { plan tests => 3; ok(my $worker = worker_exception(job_servers => [@job_servers]), "worker"); my $res = $client->do_task( $func => $arg, { on_exception => sub { is(shift, "PID $$ job exception", "on exception callback"); }, on_fail => sub { fail("exception") } }, ); is($res, undef, "no result"); }; done_testing(); sub worker_complete { my (%args) = @_; my $w = Gearman::Worker->new(%args); my $cb = sub { my ($job) = @_; my @i = @{ thaw($job->arg) }; $w->send_work_complete($job, sum(@i)); return; }; $w->register_function($func, $cb); return _work($w); } ## end sub worker_complete sub worker_fail { my (%args) = @_; my $w = Gearman::Worker->new(%args); my $cb = sub { my ($job) = @_; $w->send_work_fail($job, join(' ', "PID", getppid(), "job fail")); return; }; $w->register_function($func, $cb); return _work($w); } ## end sub worker_fail sub worker_exception { my (%args) = @_; my $w = Gearman::Worker->new(%args); my $cb = sub { my ($job) = @_; $w->send_work_exception($job, join(' ', "PID", getppid(), "job exception")); return; }; $w->register_function($func, $cb); return _work($w); } ## end sub worker_exception sub _work { my $w = shift; my $pg = Proc::Guard->new( code => sub { $w->work( stop_if => sub { my ($idle) = @_; return $idle; } ); } ); return $pg; } ## end sub _work Gearman-2.004.015/t/09-connect.t0000644000175000017500000000653513340014354014674 0ustar palikpalikuse strict; use warnings; use Gearman::Client; use IO::Socket::IP; use Test::More; use Time::HiRes; $ENV{AUTHOR_TESTING} || plan skip_all => 'without $ENV{AUTHOR_TESTING}'; my @paddr = qw/ 192.0.2.1:1 192.0.2.2:1 /; foreach my $pa (@paddr) { my $start_time = [Time::HiRes::gettimeofday]; my $sock = IO::Socket::IP->new(PeerAddr => $pa, Timeout => 2); my $delta = Time::HiRes::tv_interval($start_time); if ($sock) { plan skip_all => "Somehow we connected to the TEST-NET block. This should be impossible."; exit 0; } elsif ($delta < 1 || $delta > 3) { plan skip_all => "Socket timeouts aren't behaving, we can't trust this test in that scenario."; exit 0; } } ## end foreach my $pa (@paddr) plan tests => 11; # Testing exponential backoff # doesn't connect my $client = new_ok("Gearman::Client", [exceptions => 1, job_servers => $paddr[0]]); # 1 second backoff (1 ** 2) time_between( .9, 1.1, sub { $client->do_task(anything => '') }, "Fresh server list, slow failure" ); time_between( undef, .1, sub { $client->do_task(anything => '') }, "Backoff for 1s, fast failure" ); sleep 2; # 4 second backoff (2 ** 2) time_between( .9, 1.1, sub { $client->do_task(anything => '') }, "Backoff cleared, slow failure" ); time_between( undef, .1, sub { $client->do_task(anything => '') }, "Backoff for 4s, fast failure (1/2)" ); sleep 2; time_between( undef, .1, sub { $client->do_task(anything => '') }, "Backoff for 4s, fast failure (2/2)" ); sleep 2; time_between( .9, 1.1, sub { $client->do_task(anything => '') }, "Backoff cleared, slow failure" ); # Now we reset the server list again and see if we have a slow backoff again. $client->job_servers($paddr[1]); # doesn't connect # Fresh server list, backoff will be 1 second (1 ** 2) after the first failure. time_between( .9, 1.1, sub { $client->do_task(anything => '') }, "Changed server list, slow failure" ); time_between( undef, .1, sub { $client->do_task(anything => '') }, "Backoff for 1s, fast failure" ); sleep 2; # Now we've cleared the timeout (1 second), mis-connect again, and test to see if we back off for 4 seconds (2 ** 2). time_between( .9, 1.1, sub { $client->do_task(anything => '') }, "Backoff cleared, slow failure" ); time_between( undef, .1, sub { $client->do_task(anything => '') }, "Backoff again, fast failure" ); sub time_between { my $low = shift; my $high = shift; my $cv = shift; my $message = shift; my $starttime = [Time::HiRes::gettimeofday]; $cv->(); my $delta = Time::HiRes::tv_interval($starttime); my $fullmessage; if (defined $low) { if (defined $high) { $fullmessage = "Timed between $low and $high: $message"; } else { $fullmessage = "Timed longer than $low: $message"; } } ## end if (defined $low) else { $fullmessage = "Timed shorter than $high: $message"; } if (defined $low && $low > $delta) { fail(join ' ', $fullmessage, "l: $low", $delta); return; } if (defined $high && $high < $delta) { fail(join ' ', $fullmessage, "h: $high", $delta); return; } pass($fullmessage); } ## end sub time_between Gearman-2.004.015/t/05-taskset.t0000644000175000017500000002201013340014354014677 0ustar palikpalikuse strict; use warnings; use IO::Socket::IP; use Test::More; use Test::Exception; use lib '.'; use t::Server (); plan tests => 17; my @js; my ($cn, $mn) = qw/ Gearman::Client Gearman::Taskset /; use_ok($mn); use_ok($cn); can_ok( $mn, qw/ add_task add_hook run_hook cancel client wait _get_loaned_sock _get_default_sock _get_hashed_sock _wait_for_packet _ip_port _fail_jshandle process_packet / ); my $c = new_ok($cn, [job_servers => [@js]]); my $ts = new_ok($mn, [$c]); subtest "new", sub { plan tests => 9; is($ts->client, $c, "client"); is($ts->{cancelled}, 0, "cancelled"); is($ts->{default_sockaddr}, undef, "default_sockaddr"); is($ts->{default_sock}, undef, "default_sock"); is_deeply($ts->{hooks}, {}, "hooks"); is_deeply($ts->{loaned_sock}, {}, "loaned_sock"); is_deeply($ts->{need_handle}, [], "need_handle"); is_deeply($ts->{waiting}, {}, "waiting"); throws_ok { $mn->new('a') } qr/^provided client argument is not a $cn reference/, "caught die off on client argument check"; }; subtest "hook", sub { plan tests => 4; my $cb = sub { 2 * shift }; my $h = "ahook"; ok($ts->add_hook($h, $cb), "add_hook($h, ..)"); is($ts->{hooks}->{$h}, $cb, "$h is a cb"); $ts->run_hook($h, 2, "run_hook($h)"); ok($ts->add_hook($h), "add_hook($h, undef)"); is($ts->{hooks}->{$h}, undef, "$h undef"); }; subtest "cancel", sub { plan tests => 8; my $ts = new_ok($mn, [$cn->new(job_servers => [@js])]); is($ts->{cancelled}, 0); my $s = IO::Socket::IP->new(); $ts->{default_sock} = $s; $ts->{loaned_sock}->{x} = $s; $ts->cancel(); is($ts->client, undef, "client"); is($ts->{cancelled}, 1, "cancelled"); is($ts->{default_sock}, undef, "default_sock"); is_deeply($ts->{loaned_sock}, {}, "loaned_sock"); is_deeply($ts->{need_handle}, [], "need_handle"); is_deeply($ts->{waiting}, {}, "waiting"); }; subtest "socket", sub { plan tests => 6; SKIP: { my $job_server = t::Server->new()->job_servers(); $job_server || skip $t::Server::ERROR, 6; my $ts = new_ok($mn, [$cn->new(job_servers => [$job_server])]); my @js = @{ $ts->client()->job_servers() }; for (my $i = 0; $i < scalar(@js); $i++) { ok(my $ls = $ts->_get_loaned_sock($js[$i]), "_get_loaned_sock($js[$i])"); isa_ok($ls, "IO::Socket::IP"); is($ts->_get_hashed_sock($i), $ls, "_get_hashed_sock($i) = _get_loaned_sock($js[$i])"); } ## end for (my $i = 0; $i < scalar...) ok($ts->_get_default_sock(), "_get_default_sock"); ok($ts->_ip_port($ts->_get_default_sock()), "_ip_port"); } ## end SKIP: }; subtest "task", sub { plan tests => 9; my $f = "foo"; my $t = Gearman::Task->new( $f, undef, { on_fail => sub { die "dies on fail" } } ); my $c = $cn->new(job_servers => []); my $ts = new_ok($mn, [$c]); is($ts->add_task($f), undef, "add_task($f) returns undef"); throws_ok { $ts->add_task($t) } qr/dies on fail/, "caught exception by add task with on_fail callback"; throws_ok { $ts->_fail_jshandle() } qr/called without shandle/, "caught _fail_jshandle() without shandle"; throws_ok { $ts->_fail_jshandle(qw/x y/) } qr/unknown handle/, "caught _fail_jshandle() unknown shandle"; dies_ok { $ts->_wait_for_packet() } "_wait_for_packet() dies"; dies_ok { $ts->add_task() } "add_task() dies"; SKIP: { my @job_servers = t::Server->new()->job_servers(int(rand(2) + 1)); @job_servers || skip $t::Server::ERROR, 2; $ts->client->job_servers([@job_servers]); ok($ts->add_task($f), "add_task($f)"); is_deeply $ts->{need_handle}, []; } ## end SKIP: }; my $f = "foo"; my $h = "H:localhost:12345"; subtest "process_packet(job_created)", sub { plan tests => 7; my $sock = $ts->_get_default_sock(); ok( my $task = $ts->client()->_get_task_from_args( $f, undef, { on_fail => sub { my ($m) = shift; is($m, "jshandle fail", "on fail message"); } } ), "task" ); $ts->{need_handle} = []; $ts->{client} = new_ok($cn, [job_servers => [@js]]); my $type = "job_created"; my $r = { type => $type, blobref => \$h }; # job_created throws_ok { $ts->process_packet($r, $sock) } qr/unexpected $type/, "$type exception"; $ts->{need_handle} = [$task]; $ts->{waiting}{$h} = [$task]; ok($ts->process_packet($r, $sock), "process_packet"); is(scalar(@{ $ts->{need_handle} }), 0, "need_handle is empty"); is($ts->{waiting}{$h}, undef, "no waiting{$h}"); }; subtest "process_packet(work_complete)", sub { plan tests => 6; my $type = "work_complete"; my $r = { type => $type, blobref => \$h }; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/Bogus $type from server/, "caught bogus $type"; $r->{blobref} = \join "\0", $h, "12345"; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/task_list is empty on $type/, "caught task list is empty"; ok( my $task = $ts->client()->_get_task_from_args( $f, undef, { on_complete => sub { my ($blob) = shift; is(${$blob}, "12345", "on complete"); } } ), "task" ); $ts->{waiting}{$h} = [$task]; ok($ts->process_packet($r), "process_packet"); is($ts->{waiting}{$h}, undef, "no waiting{$h}"); }; subtest "process_packet(work_data)", sub { plan tests => 6; my $type = "work_data"; my $r = { type => $type, blobref => \$h }; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/Bogus $type from server/, "caught bogus $type"; $r->{blobref} = \join "\0", $h, "abc"; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/task_list is empty on $type/, "caught task list is empty"; ok( my $task = $ts->client()->_get_task_from_args( $f, undef, { on_data => sub { my ($blob) = shift; is(${$blob}, "abc", "on data"); } } ), "task" ); $ts->{waiting}{$h} = [$task]; ok($ts->process_packet($r), "process_packet"); is(scalar(@{ $ts->{waiting}{$h} }), 1, "waiting{$h}"); }; subtest "process_packet(work_exception)", sub { plan tests => 5; my $type = "work_exception"; my $r = { type => $type, blobref => \$h }; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/Bogus $type from server/, "caught bogus $type"; ok( my $task = $ts->client()->_get_task_from_args( $f, undef, { on_exception => sub { my ($blob) = shift; is($blob, "abc", "on exception"); } } ), "task" ); $r->{blobref} = \join "\0", ${ $r->{blobref} }, "abc"; $ts->{waiting}{$h} = [$task]; ok($ts->process_packet($r), "process_packet"); is($ts->{waiting}{$h}, undef, "waiting{$h}"); }; subtest "process_packet(work_fail)", sub { plan tests => 4; ok( my $task = $ts->client()->_get_task_from_args( $f, undef, { on_fail => sub { my ($m) = shift; is($m, "jshandle fail", "on fail message"); } } ), "task" ); my $type = "work_fail"; my $r = { type => $type, blobref => \$h }; $ts->{waiting}{$h} = [$task]; ok($ts->process_packet($r), "process_packet"); is($ts->{waiting}{$h}, undef, "no waiting{$h}"); }; subtest "process_packet(work_status)", sub { plan tests => 6; my $type = "work_status"; my $r = { type => $type, blobref => \join "\0", $h, 3, 5 }; $ts->{waiting}{$h} = []; throws_ok { $ts->process_packet($r) } qr/Got $type for unknown handle/, "caught unknown handle"; ok( my $task = $ts->client()->_get_task_from_args( $f, undef, { on_status => sub { my ($nu, $de) = @_; is($nu, 3); is($de, 5); } } ), "task" ); $ts->{waiting}{$h} = [$task]; ok($ts->process_packet($r), "process_packet"); is(scalar(@{ $ts->{waiting}{$h} }), 1, "waiting{$h}"); }; subtest "process_packet(unimplemented type)", sub { plan tests => 1; my $type = $f; my $r = { type => $type, blobref => \"x" }; throws_ok { $ts->process_packet($r) } qr/Unimplemented packet type: $f/, "caught unimplemented packet type"; }; done_testing(); Gearman-2.004.015/t/14-sleep.t0000644000175000017500000001016013340014354014334 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server v1.130.2 use Test::More; use Test::Timer; use lib '.'; use t::Server (); use t::Worker qw/ new_worker /; my $gts = t::Server->new(); my @job_servers = $gts->job_servers(); @job_servers || plan skip_all => $t::Server::ERROR; my %cb = ( sleep => sub { sleep $_[0]->arg; return 1; }, sleep_three => [ 3, sub { my ($sleep, $return) = $_[0]->arg =~ m/^(\d+)(?::(.+))?$/; sleep $sleep; return $return; } ], ); my @workers = map(new_worker(job_servers => [@job_servers], func => {%cb}), (0 .. int(rand(1) + 1))); use_ok("Gearman::Client"); my $client = new_ok("Gearman::Client", [exceptions => 1, job_servers => [@job_servers]]); ## Test sleeping less than the timeout subtest "sleep tree", sub { my $opt = { on_fail => sub { fail(explain(@_)) } }; is(${ $client->do_task("sleep_three", "1:less", $opt) }, "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", $opt) }, "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. subtest "taskset a", sub { 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; }; #TODO there is some magic time_ok influence on following sleeping subtest, which fails if timeout ok ## Worker process times out (takes longer than timeout seconds). subtest "timeout task", sub { plan skip_all => "doen't work properly with some gearmand"; my $to = 3; time_ok(sub { $client->do_task("sleep", 5, { timeout => $to }) }, $to, "Job that timed out after $to seconds returns failure"); }; #TODO review this subtest. It fails in both on_complete # ## Check to make sure there are no hashing glitches with an explicit ## 'uniq' field. Both should fail. subtest "timeout worker", sub { plan skip_all => "doen't work properly with some gearmand"; 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!") }, } ); note "sleep 5"; sleep 5; note "slept 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!") }, } ); note "wait"; $tasks->wait; }; done_testing(); Gearman-2.004.015/t/17-status.t0000644000175000017500000000533413340014354014561 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server v1.130.2 use Test::More; use lib '.'; use t::Server (); use t::Worker qw/ new_worker /; my $gts = t::Server->new(); my @job_servers = $gts->job_servers(); @job_servers || plan skip_all => $t::Server::ERROR; my $func = "sleep"; my $worker = new_worker( job_servers => [@job_servers], func => { $func => sub { sleep $_[0]->arg; return 1; } } ); use_ok("Gearman::Client"); my $client = new_ok("Gearman::Client", [job_servers => [@job_servers]]); subtest "job server status", sub { # sleep before status check sleep 1; my $js_status = $client->get_job_server_status(); foreach (@{ $client->job_servers() }) { my $js_str = $client->_js_str($_); isnt($js_status->{$js_str}->{$func}->{capable}, 0, "Correct capable jobs for $func"); is($js_status->{$js_str}->{$func}->{running}, 0, "Correct running jobs for $func"); is($js_status->{$js_str}->{$func}->{queued}, 0, "Correct queued jobs for $func"); } ## end foreach (@{ $client->job_servers...}) }; subtest "job server jobs", sub { plan skip_all => "'jobs' command supported only by Gearman::Server"; my $tasks = $client->new_task_set; $tasks->add_task( $func, 1, { on_fail => sub { fail(explain(@_)) }, } ); my $js_jobs = $client->get_job_server_jobs(); is(scalar keys %$js_jobs, 1, "Correct number of running jobs"); my $host = (keys %$js_jobs)[0]; is($js_jobs->{$host}->{$func}->{key}, '', "Correct key for running job"); isnt($js_jobs->{$host}->{$func}->{address}, undef, "Correct address for running job"); is($js_jobs->{$host}->{$func}->{listeners}, 1, "Correct listeners for running job"); $tasks->wait; }; subtest "job server clients", sub { plan skip_all => "'clients' command supported only by Gearman::Server"; my $tasks = $client->new_task_set; $tasks->add_task( $func, 1, { on_fail => sub { fail(explain(@_)) }, } ); my $js_clients = $client->get_job_server_clients(); foreach my $js (keys %$js_clients) { foreach my $client (keys %{ $js_clients->{$js} }) { next unless scalar keys %{ $js_clients->{$js}->{$client} }; is($js_clients->{$js}->{$client}->{$func}->{key}, '', "Correct key for running job via client"); isnt($js_clients->{$js}->{$client}->{$func}->{address}, undef, "Correct address for running job via client"); } ## end foreach my $client (keys %{...}) } ## end foreach my $js (keys %$js_clients) $tasks->wait; }; done_testing(); Gearman-2.004.015/t/06-response-parser.t0000644000175000017500000000145713340014354016366 0ustar palikpalikuse strict; use warnings; use Test::More; use Test::Exception; my ($mn, $s) = qw/ Gearman::ResponseParser foo /; use_ok($mn); my $m = new_ok($mn, [source => $s]); throws_ok { $mn->new(source => $s, $s => 1, bla => 1) } qr/^unsupported arguments/, "caught die of on arguments check"; can_ok( $m, qw/ eof on_error on_packet parse_data parse_sock reset source / ); foreach (qw/eof on_packet on_error/) { throws_ok { $m->$_ } qr/^SUBCLASSES SHOULD OVERRIDE THIS/, "caught die off in $_"; } is($m->source, $s, "source"); subtest "reset", sub { $m->{$_} = $s for qw/ header pkt /; $m->reset; is($m->{header}, '', "header"); is($m->{pkt}, undef, "pkt"); }; done_testing(); Gearman-2.004.015/t/65-responseparser.t0000644000175000017500000000375613340014354016322 0ustar palikpalikuse 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-2.004.015/t/Worker.pm0000644000175000017500000000146113340014347014432 0ustar palikpalikpackage t::Worker; use strict; use warnings; use base qw/Exporter/; use Gearman::Worker; use Proc::Guard; our @EXPORT = qw/ new_worker /; sub new_worker { my (%args) = @_; defined($args{func}) || die "no func in passed arguments"; my %func = %{ delete $args{func} }; my $w = Gearman::Worker->new(%args); while (my ($f, $v) = each(%func)) { $w->register_function($f, ref($v) eq "ARRAY" ? @{$v} : $v); } my $pg = Proc::Guard->new( code => sub { while (1) { $w->work( stop_if => sub { my ($idle, $last_job_time) = @_; return $idle; } ); } ## end while (1) } ); return $pg; } ## end sub new_worker 1; Gearman-2.004.015/t/07-response-parser-taskset.t0000644000175000017500000000121613340014354020034 0ustar palikpalikuse strict; use warnings; use Test::More; use Test::Exception; my ($mn, $tsn, $cn, $s) = qw/ Gearman::ResponseParser::Taskset Gearman::Taskset Gearman::Client foo /; use_ok($tsn); use_ok($cn); use_ok($mn); isa_ok($mn, "Gearman::ResponseParser"); can_ok( $mn, qw/ on_packet on_error / ); my $ts = new_ok($tsn, [new_ok($cn)]); my $m = new_ok($mn, [source => $s, taskset => $ts]); throws_ok { $m->on_error($s) } qr/^ERROR: $s/, "caught die off in on_error"; throws_ok { $mn->new(source => $s, taskset => $s) } qr/is not a Gearman::Taskset reference/, "caught die of on taskset check"; done_testing(); Gearman-2.004.015/t/01-object.t0000644000175000017500000001222713340014354014474 0ustar palikpalikuse strict; use warnings; use Test::More; use Test::Exception; use IO::Socket::SSL (); my $mn = "Gearman::Objects"; use_ok($mn); can_ok( $mn, qw/ _js _js_str _property _sock_cache canonicalize_job_servers debug func job_servers prefix prefix_separator set_job_servers sock_nodelay socket / ); subtest "job servers", sub { plan tests => 19; { # scalar my $host = "foo"; my $c = new_ok( $mn, [job_servers => $host], "Gearman::Objects->new(job_servers => $host)" ); is(1, $c->{js_count}, "js_count=1"); ok(my @js = $c->job_servers(), "job_servers"); is(scalar(@js), 1, "job_servers count"); is($js[0], join(':', $host, 4730), "$host:4730"); is(@{ $c->canonicalize_job_servers($host) }[0], $js[0], "job_servers=$host"); throws_ok { $c->job_servers(sub { }); } qr/unsupported job server value of type/, "unsupported job server value"; } { # hash reference my $j = { host => "foo", port => 123 }; my $c = new_ok( $mn, [job_servers => $j], "Gearman::Objects->new(job_servers => hash reference)" ); is($c->{js_count}, 1, "js_count=1"); ok(my @js = $c->job_servers(), "job_servers"); is(scalar(@js), 1, "job_servers count"); is(@{ $c->canonicalize_job_servers($j) }[0], $js[0], "job_servers"); } { # mix scalar and hash reference my @servers = ( qw/ foo:12345 bar:54321 /, { host => "abc", "port" => 123 } ); my $c = new_ok($mn, [job_servers => [@servers]],); is(scalar(@servers), $c->{js_count}, "js_count=" . scalar(@servers)); ok(my @js = $c->job_servers, "job_servers"); isa_ok($js[$#servers], "HASH"); for (my $i = 0; $i <= $#servers; $i++) { is(@{ $c->canonicalize_job_servers($servers[$i]) }[0], $js[$i], "canonicalize_job_servers($servers[$i])"); } } }; subtest "debug", sub { plan tests => 6; my $c = new_ok($mn, [debug => 1]); is($c->debug(), 1); is($c->debug(0), 0); $c = new_ok($mn); is($c->debug(), undef); is($c->debug(1), 1); }; subtest "prefix func", sub { plan tests => 3; my ($p, $f) = qw/foo bar/; subtest "no prefix", sub { my $c = new_ok($mn); is($c->prefix(), undef); is($c->func($f), $f); is($c->prefix($p), $p); is($c->func($f), join("\t", $c->prefix(), $f)); }; subtest "prefix", sub { my $c = new_ok($mn, [prefix => $p]); is($c->prefix(), $p); is($c->func($f), join("\t", $c->prefix(), $f)); is($c->prefix(undef), undef); is($c->func($f), $f); }; subtest "prefix separator", sub { my $separator = '#'; my $c = new_ok($mn, [prefix => $p, prefix_separator => $separator]); is($c->prefix(), $p); is($c->prefix_separator(), $separator); is($c->func($f), join($separator, $c->prefix(), $f)); is($c->prefix_separator(undef), "\t"); is($c->func($f), join("\t", $c->prefix(), $f)); is($c->prefix(undef), undef); is($c->func($f), $f); }; }; subtest "socket", sub { plan tests => 6; my $host = "google.com"; my %p = ( 443 => "SSL", 80 => "IP" ); while (my ($p, $s) = each(%p)) { my $c = new_ok($mn); my $to = int(rand(5)) + 1; my $js = { use_ssl => $p == 443, socket_cb => sub { my ($hr) = @_; $hr->{Timeout} = $to; }, host => $host, port => $p }; my $sock = $c->socket($js); SKIP: { $sock || skip "failed connect to $host:$js->{port}: $!", 2; isa_ok($sock, "IO::Socket::$s"); SKIP: { $sock->connected() || skip "no connection to $host:$js->{port}", 1; is($sock->timeout, $to, join ' ', $s, "socket callback"); } } ## end SKIP: } ## end while (my ($p, $s) = each...) }; subtest "sock cache", sub { plan tests => 10; my $c = new_ok($mn); isa_ok($c->{sock_cache}, "HASH"); is(keys(%{ $c->{sock_cache} }), 0); my ($k, $v) = qw/x y/; # nothing in cache is($c->_sock_cache($k), undef); # set cache x = y is($c->_sock_cache($k, $v), $v); is(keys(%{ $c->{sock_cache} }), 1); # delete x is($c->_sock_cache($k, $v, 1), $v); is(keys(%{ $c->{sock_cache} }), 0); $k = { host => $k, port => 123 }; is($c->_sock_cache($k, $v), $v); is(keys(%{ $c->{sock_cache} }), 1); }; subtest "js stringify", sub { plan tests => 5; my $c = new_ok($mn); my ($h, $p) = ("foo", int(rand(10) + 1000)); my ($js_str, $js) = (join(':', $h, $p), { host => $h, port => $p }); is($c->_js_str($js), $js_str); is($c->_js_str($js_str), $js_str); ok($c->job_servers($js)); is($c->_js($js_str), $js); }; done_testing(); Gearman-2.004.015/t/16-background.t0000644000175000017500000000300013340014354015340 0ustar palikpalikuse strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server v1.130.2 use Test::More; use lib '.'; use t::Server (); use t::Worker qw/ new_worker /; my $gts = t::Server->new(); my @job_servers = $gts->job_servers(); @job_servers || plan skip_all => $t::Server::ERROR; use_ok("Gearman::Client"); my $client = new_ok("Gearman::Client", [exceptions => 1, job_servers => [@job_servers]]); my $func = "long"; my $worker = new_worker( job_servers => [@job_servers], func => { $func => sub { my ($job) = @_; $job->set_status(50, 100); sleep 2; $job->set_status(100, 100); sleep 2; return $job->arg; } } ); ## Test dispatch_background and get_status. subtest "dispatch background", sub { my $handle = $client->dispatch_background( $func => undef, { on_complete => sub { note "complete", ${ $_[0] } }, on_fail => sub { fail(explain(@_)) }, } ); # wait for job to start being processed: sleep 1; ok($handle, 'Got a handle back from dispatching background job'); ok(my $status = $client->get_status($handle), "get_status"); 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); note $status->percent; } until $status->percent == 1; }; done_testing(); Gearman-2.004.015/t/00-use.t0000644000175000017500000000100013340014503014000 0ustar palikpalikuse strict; use warnings; use version (); use Test::More; my @mn = qw/ Gearman::Client Gearman::Job Gearman::JobStatus Gearman::Objects Gearman::ResponseParser Gearman::Task Gearman::Taskset Gearman::Util Gearman::Worker /; my $v = version->declare("2.004.015"); foreach my $n (@mn) { use_ok($n); my $_v = eval '$' . $n . '::VERSION'; # diag("Testing $n $v, Perl $], $^X"); is($_v, $v, "$n version is $v"); } ## end foreach my $n (@mn) done_testing; Gearman-2.004.015/TODO0000644000175000017500000000021313061602165013043 0ustar palikpalik* 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-2.004.015/META.json0000664000175000017500000000370613340015301013776 0ustar palikpalik{ "abstract" : "Client and worker libraries for gearman job dispatch dispatch. Server is in separate package.", "author" : [ "Brad Fitzpatrick " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Gearman", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "File::Which" : "0", "IO::Socket::IP" : "0", "IO::Socket::SSL" : "0", "Perl::OSType" : "0", "Proc::Guard" : "0.07", "Storable" : "0", "Test::Exception" : "0", "Test::More" : "0", "Test::TCP" : "2.17", "Test::Timer" : "0", "version" : "0.77" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "IO::Select" : "0", "IO::Socket::IP" : "0", "IO::Socket::SSL" : "0", "List::MoreUtils" : "0", "POSIX" : "0", "Scalar::Util" : "0", "Socket" : "0", "Storable" : "0", "String::CRC32" : "0", "Time::HiRes" : "0", "fields" : "0", "perl" : "5.008001", "version" : "0.77" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/p-alik/perl-Gearman/issues" }, "repository" : { "type" : "git", "url" : "https://github.com/p-alik/perl-Gearman.git", "web" : "https://github.com/p-alik/perl-Gearman" } }, "version" : "v2.4.15" } Gearman-2.004.015/CHANGES0000644000175000017500000003123113340014503013343 0ustar palikpalik2.004.015 2018-08-24 16:41:00 Europe/Berlin add documentation of client's undocumented options - https://github.com/p-alik/perl-Gearman/issues/40 add example explains usage of work sub's callbacks. - https://github.com/p-alik/perl-Gearman/issues/41 2.004.014 2018-03-13 19:28:00 Europe/Berlin - prevent recursion warnings https://github.com/p-alik/perl-Gearman/issues/38 2.004.013 2018-02-05 16:45:00 Europe/Berlin - bug fixing: Gearman::Util::read_res_packet https://github.com/p-alik/perl-Gearman/issues/37 2.004.012 2018-01-04 11:03:00 Europe/Berlin - bug fixing timestamp taskset wait shows unaltered timestamp on fail https://github.com/p-alik/perl-Gearman/issues/35 2.004.011 2017-12-22 16:05:00 Europe/Berlin - bug fixing client doesn't on_fail on timeout https://github.com/p-alik/perl-Gearman/issues/33 - peculiar handling of ssl-sockets in taskset->wait to avoid freezing https://github.com/p-alik/perl-Gearman/issues/32 2.004.010 2017-11-19 14:46:00 Europe/Berlin - bug fixing worker high CPU usage in idle state https://github.com/p-alik/perl-Gearman/issues/28 - switch to blocking to continue fetching partial read https://github.com/p-alik/perl-Gearman/pull/30 - pod notes with regard to usage of UTF-8 https://github.com/p-alik/perl-Gearman/issues/27 2.004.009 2017-10-08 21:04:00 Europe/Berlin - bug fixing Worker->work: register functions on reconnect. see: https://github.com/p-alik/perl-Gearman/issues/23 - Gearman::Client->do_task invokes Gearman::Task on_complete hook, if it is defined - add documentation of Gearman::Client exceptions property 2.004.008 2017-06-13 13:35:00 Europe/Berlin - bug fixing: double worker registration https://github.com/p-alik/perl-Gearman/issues/21 - tests start gearmand with --log-file option. Default /dev/stderr 2.004.007 2017-05-30 10:51:00 Europe/Berlin - bug fix: stringify job server in - get_job_server_status - get_job_server_clients - get_job_server_jobs 2.004.006 2017-05-25 18:39:00 Europe/Berlin - bug fixing: Taskset->add_task support for large data - ssl tests large task data and large work result 2.004.005 2017-05-19 13:11:00 Europe/Berlin - new worker method send_work_exception - send_work_fail does not support message parameter 2.004.004 2017-05-09 07:53:00 Europe/Berlin - refactoring: Taskset carefully loops over loaned_sock 2.004.003 2017-04-11 22:24:00 Europe/Berlin - Client and Worker could set SSL ca_file parameter - Taskset.pm refactoring: replace fileno handling by IO::Select 2.004.002 2017-04-11 11:01:00 Europe/Berlin - do not force Client and Worker to set useless SSL ca_certs parameter 2.004.001 2017-04-11 14:38:00 Europe/Berlin - Gearman::Client and Gearman::Worker could set prefix separator - It would be recommended to replace default prefix separator to insure gearmand persistent queue recovery. 2.003.002 2017-03-26 22:01:00 Europe/Berlin - tests are perl 5.25 ready (use lib .) -- GEARMAN_WORKER_USE_STDIO test only with AUTHOR_TESTING 2.003.001 2017-03-13 21:47:00 Europe/Berlin -- test compatibility for gearmand and Gearman::Server 2.003_002 2017-03-02 14:45:00 Europe/Berlin -- restore Gearman::Client::Async support. #10 -- try to bug fix ssl callback testing 2.003_001 2017-02-18 18:37:00 Europe/Berlin -- worker: -- remove THROW_EXCEPTIONS defination in BEGIN block -- add support of protocol commands WORK_DATA and WORK_WARNING -- new methods: -- send_work_data -- send_work_warning -- send_work_complete -- send_work_fail -- _get_js_sock: no execution of object _on_connect if callback is defined -- fixing client do_task: do not overwrite on_fail callback -- Gearman::Task support of low priority -- remove Ref::Util dependency 2.002.004 2016-12-05 09:02:16 Europe/Berlin -- requires Ref::Util >= 0.020; see cpan tester report 848fbc3e-b94f-11e6-8baf-a6caeafb6ca6 -- Makefile.PL updates LICENSE: perl min perl version 5.8.1 -- fixing worker GEARMAN_WORKER_USE_STDIO env test 2.002.003 2016-12-04 22:13:00 Europe/Berlin -- add DISTNAME into Makefile.PL to get back to the old distribution name 2.002.002 2016-12-03 12:10:00 Europe/Berlin -- skip worker stop_if test if no gearmand 2.002.001 2016-12-02 22:01:00 Europe/Berlin (TRIAL RELEASE) -- job_servers entries could be a hash references or string -- bug fixing Gearman::Util::send_req() SSL frame limitation (esabol) 2.001.001 2016-10-13 10:45:00 Europe/Berlin (TRIAL RELEASE) -- support for SSL connection to gearmand -- support IPv6 -- tests refactoring 1.130.004 (2016-08-06) -- add Gearman::ResponseParser pod -- add Gearman::ResposeParser::Taskset pod -- rename Gearman::Taskset->_process_packet to process_packet -- issue 116744 Utility pod 1.130.003 (2016-08-05) -- check OS in Test::Gearman and don't use "which" on Windows -- replace 'use Errno qw(EAGAIN)' by 'POSIX qw(:errno_h)' see: http://www.cpantesters.org/cpan/report/d801a704-5975-11e6-9451-9b92aab8e0c0 1.130.002 (2016-08-03) -- skip worker _get_js_sock test without gearmand 1.130.001 (2016-08-02) -- refactoring of Gearman::Util::read_res_packet: no goto/redo -- test suite refactoring -- solved issue 85191 Programming error prevents Gearman::Worker::work() from connecting to servers -- solved issue 59185 document Gearman::Client::get_status -- solved issue 56508 using $task->fail("reason goes here") in Gearman::Taskset 1.12.009 (2016-06-04) -- run t/30-maxqueue.t and t/40-prefix.t only with AUTHOR_TESTING -- s/::Object/::Objects/ 1.12.008 (2016-06-03) -- rename Gearman::Base back to Geamrman::Object because Gearman-Client-Async depends on it 1.12.007 (2016-05-20) -- more tests only with AUTHOR_TESTING 1.12.006 (2016-05-19) -- tests refactoring -- execute some tests only if AUTHOR_TESTING env is defined 1.12.005 (2016-05-06) -- rm META.* 1.12.004 (2016-05-06) -- solved issue 5324ce04-0bae-11e6-a317-839d20bbf307 there was a bug in test script 1.12.003 (2016-05-01) -- tested with perl5-22-1 to improve cpan tester resport 5324ce04-0bae-11e6-a317-839d20bbf307 -- fields moved from Gearman::Objects to proper modules -- rm obsolete Gearman::Objects -- use warnings (except redefine) -- perltidy applied to all modules 1.12.002 (2014-12-19) -- attempt to fix bugs: 89037, 100594, 101012 -- cpan tester report 586f5968-8489-11e4-adb9-802de0bfc7aa is - ugly - fixed too -- refactoring: Client/Worker base class added -- dynamic tests by using environment variable GEARMAN_SERVERS 1.12 (2014-12-14) -- Repoint HACKING file. -- Make a jobserver connection use the command timeout during exception negotiation. -- Make $taskset->add_task use the command timeout to not hang during job submission. -- Add a client option 'command_timeout' to indicate how long we should wait before considering a gearman command to have failed. This not the same as a job timeout, and only affects commands that should generally not block apart from the roundtrip on the network. -- When a connection to a gearman server fails, start counting how many failures we've had and do an exponential backoff (1s, 4s, 9s, 16s...) to a maximum of 90 seconds (default) that we treat the server as 'gone' quickly. -- Change dispatch_background to share code paths with other dispatching, this will make background jobs now be hashed to a particular server (rather than handed to a random server) 1.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-2.004.015/lib/0000755000175000017500000000000013340015301013113 5ustar palikpalikGearman-2.004.015/lib/Gearman/0000755000175000017500000000000013340015301014465 5ustar palikpalikGearman-2.004.015/lib/Gearman/ResponseParser/0000755000175000017500000000000013340015301017440 5ustar palikpalikGearman-2.004.015/lib/Gearman/ResponseParser/Taskset.pm0000644000175000017500000000210613340014503021416 0ustar palikpalikpackage Gearman::ResponseParser::Taskset; use version (); $Gearman::ResponseParser::Taskset::VERSION = version->declare("2.004.015"); use strict; use warnings; use base "Gearman::ResponseParser"; use Carp (); use Scalar::Util (); =head1 NAME Gearman::ResponseParser::Taskset - gearmand response parser implementation =head1 DESCRIPTION derived from L =head1 METHODS =cut sub new { my ($class, %opts) = @_; my $ts = delete $opts{taskset}; (Scalar::Util::blessed($ts) && $ts->isa("Gearman::Taskset")) || Carp::croak "provided taskset argument is not a Gearman::Taskset reference"; my $self = $class->SUPER::new(%opts); $self->{_taskset} = $ts; return $self; } ## end sub new =head2 on_packet($packet, $parser) provide C<$packet> to L process_packet =cut sub on_packet { my ($self, $packet, $parser) = @_; $self->{_taskset}->process_packet($packet, $parser->source); } =head2 on_error($msg) die C<$msg> =cut sub on_error { my ($self, $errmsg) = @_; die "ERROR: $errmsg\n"; } 1; Gearman-2.004.015/lib/Gearman/ResponseParser.pm0000644000175000017500000001016213340014503020001 0ustar palikpalikpackage Gearman::ResponseParser; use version (); $Gearman::ResponseParser::VERSION = version->declare("2.004.015"); use strict; use warnings; use Gearman::Util (); =head1 NAME Gearman::ResponseParser - gearmand abstract response parser implementation =head1 DESCRIPTION I is an abstract base class. See: L Subclasses should call this first, then add their own data in underscore members =head1 METHODS =cut # Gearman::ResponseParser::Danga (for Gearman::Client::Danga, the async version) sub new { my $class = shift; my %opts = @_; my $src = delete $opts{'source'}; die "unsupported arguments '@{[keys %opts]}'" if %opts; my $self = bless { # the source object/socket that is primarily feeding this. source => $src, }, $class; $self->reset; return $self; } ## end sub new =head2 source() B source. The source is object/socket =cut sub source { my $self = shift; return $self->{source}; } =head2 on_packet($packet, $parser) subclasses should override this =cut sub on_packet { my ($self, $packet, $parser) = @_; die "SUBCLASSES SHOULD OVERRIDE THIS"; } =head2 on_error($msg, $parser) subclasses should override this =cut sub on_error { my ($self, $errmsg, $parser) = @_; # NOTE: this interface will evolve. die "SUBCLASSES SHOULD OVERRIDE THIS"; } ## end sub on_error =head2 reset() =cut sub reset { my $self = shift; $self->{header} = ''; $self->{pkt} = undef; } =head2 parse_data($data) don't override: FUTURE OPTIMIZATION: let caller say "you can own this scalarref", and then we can keep it on the initial setting of $self->{data} and avoid copying into our own. overkill for now. =cut 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; } ## end unless ($hdr_len == 12) # 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; } } ## end while (my $lendata = length...) if (defined($self->{pkt}) && length(${ $self->{pkt}{blobref} }) == $self->{pkt}{len}) { $self->on_packet($self->{pkt}, $self); $self->reset; } ## end if (defined($self->{pkt...})) } ## end sub parse_data =head2 eof() don't override =cut sub eof { my $self = shift; $self->on_error("EOF"); # ERROR if in middle of packet } ## end sub eof =head2 parse_sock($sock) don't override C<$sock> is readable, we should sysread it and feed it to L =cut sub parse_sock { my ($self, $sock) = @_; my $res = Gearman::Util::read_res_packet($sock, \my $err); if ($err) { $self->on_error("read_error: ${$err}"); return; } $self->{pkt} = $res; if (defined($self->{pkt}) && length(${ $self->{pkt}{blobref} }) == $self->{pkt}{len}) { $self->on_packet($self->{pkt}, $self); $self->reset; } ## end if (defined($self->{pkt...})) } ## end sub parse_sock 1; Gearman-2.004.015/lib/Gearman/Task.pm0000644000175000017500000003014613340014503015734 0ustar palikpalikpackage Gearman::Task; use version; $Gearman::Task::VERSION = version->declare("2.004.015"); use strict; use warnings; =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). The reason could be passed to this callback as an argument. 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 on_warning 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 B. Use C<< priority => high >> instead. Boolean, whether this job should take priority over other jobs already enqueued. =item priority valid value: =over =item high =item normal (defaul) =item low =back =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 =cut use Carp (); use Gearman::Util (); use Scalar::Util (); use String::CRC32 (); use Storable (); use fields ( # from client: 'func', 'argref', # opts from client: 'uniq', 'on_complete', 'on_data', 'on_fail', 'on_exception', 'on_warning', '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', 'background', # from server: 'handle', # maintained by this module: 'retries_done', 'is_finished', 'taskset', # jobserver socket. # shared by other tasks in the same taskset, # but not w/ tasks in other tasksets using # the same Gearman::Client 'jssock', # hookname -> coderef 'hooks', 'priority', ); # constructor, given: ($func, $argref, $opts); sub new { my $self = shift; unless (ref $self) { $self = fields::new($self); } $self->{func} = shift or Carp::croak("No function given"); $self->{argref} = shift || do { my $empty = ""; \$empty; }; (ref $self->{argref} eq "SCALAR") || Carp::croak("Argref not a scalar reference"); my $opts = shift || {}; $self->{$_} = delete $opts->{$_} for qw/ background high_priority on_complete on_data on_exception on_fail on_retry on_status on_warning retry_count timeout try_timeout uniq /; $self->_priority(delete $opts->{priority}); $self->{retry_count} ||= 0; # bool: if success or fail has been called yet on this. $self->{is_finished} = 0; if (%{$opts}) { Carp::croak("Unknown option(s): " . join(", ", sort keys %$opts)); } $self->{retries_done} = 0; return $self; } ## end sub new #=head1 METHODS # #=head2 run_hook($name) # #run a hook callback if defined # #=cut sub run_hook { my ($self, $name) = (shift, shift); ($name && $self->{hooks}->{$name}) || return; eval { $self->{hooks}->{$name}->(@_) }; warn "Gearman::Task hook '$name' threw error: $@\n" if $@; } ## end sub run_hook #=head2 add_hook($name, $cb) # #add a hook # #=cut sub add_hook { my ($self, $name) = (shift, shift); $name || return; if (@_) { $self->{hooks}->{$name} = shift; } else { delete $self->{hooks}->{$name}; } } ## end sub add_hook #=head2 is_finished() # #B bool: whether or not task is totally done (on_failure or #on_complete callback has been called) # #=cut sub is_finished { return shift->{is_finished}; } #=head2 taskset() # #getter # #=head2 taskset($ts) # #setter # #B Gearman::Taskset # #=cut sub taskset { my $self = shift; # getter return $self->{taskset} unless @_; # setter my $ts = shift; (Scalar::Util::blessed($ts) && $ts->isa("Gearman::Taskset")) || Carp::croak("argument is not an instance of Gearman::Taskset"); $self->{taskset} = $ts; if (my $hash_num = $self->hash()) { $self->{jssock} = $ts->_get_hashed_sock($hash_num); } else { $self->{jssock} = $ts->_get_default_sock; } return $self->{taskset}; } ## end sub taskset #=head2 hash() # #B undef on non-uniq packet, or the hash value (0-32767) if uniq # #=cut sub hash { my $self = shift; my $merge_on = $self->{uniq} && $self->{uniq} eq "-" ? $self->{argref} : \$self->{uniq}; if (${$merge_on}) { return (String::CRC32::crc32(${$merge_on}) >> 16) & 0x7fff; } else { return; } } ## end sub hash #=head2 pack_submit_packet([$client]) # #B Gearman::Util::pack_req_command(mode, func, uniq, argref) # #=cut sub pack_submit_packet { my ($self, $client) = @_; # $client should be optional for sake of Gearman::Client::Async # see https://github.com/p-alik/perl-Gearman/issues/10 my $func = $client ? $client->func($self->func) : $self->func; return Gearman::Util::pack_req_command( $self->mode, join( "\0", $func || '', $self->{uniq} || '', ${ $self->{argref} } || '' ) ); } ## end sub pack_submit_packet #=head2 fail($reason) # #=cut sub fail { my ($self, $reason) = @_; return if $self->{is_finished}; # try to retry, if we can if ($self->{retries_done} < $self->{retry_count}) { $self->{retries_done}++; $self->{on_retry}->($self->{retries_done}) if $self->{on_retry}; $self->handle(undef); return $self->{taskset}->add_task($self); } ## end if ($self->{retries_done...}) $self->final_fail($reason); } ## end sub fail #=head2 final_fail($reason) # #if C<< !is_finished >> runs the hooks # #=over # #=item # #on_fail # #=item # #on_post_hooks # #=back # #=cut sub final_fail { my ($self, $reason) = @_; return if $self->{is_finished}; $self->{is_finished} = $reason || 1; $self->run_hook('final_fail', $self); $self->{on_fail}->($reason) if $self->{on_fail}; $self->{on_post_hooks}->() if $self->{on_post_hooks}; $self->wipe; return; } ## end sub final_fail #=head2 exception($exc_ref) # #$exc_ref may be a Storable serialized value # #run on_exception if defined # #=cut sub exception { my ($self, $exc_ref) = @_; #FIXME the only on_exception callback get dereferenced value # could it be changed without damage? my $exception = Storable::thaw($$exc_ref); $self->{on_exception}->($$exception) if $self->{on_exception}; return; } ## end sub exception #=head2 complete($result) # #C<$result> a reference profided to on_complete cb # #=cut sub complete { my ($self, $result_ref) = @_; return if $self->{is_finished}; $self->{is_finished} = 'complete'; $self->run_hook('complete', $self); $self->{on_complete}->($result_ref) if $self->{on_complete}; $self->{on_post_hooks}->() if $self->{on_post_hooks}; $self->wipe; } ## end sub complete #=head2 status() # #=cut sub status { my $self = shift; return if $self->{is_finished}; return unless $self->{on_status}; my ($nu, $de) = @_; $self->{on_status}->($nu, $de); } ## end sub status #=head2 data() # #invokes C callback if worker sends work_data notification. # #=cut sub data { my $self = shift; return if $self->{is_finished}; my $result_ref = shift; $self->{on_data}->($result_ref) if $self->{on_data}; } ## end sub data #=head2 warning($message) # #invokes C callback if worker sends work_warning notification. # #=cut sub warning { my $self = shift; $self->{is_finished} && return; $self->{on_warning} || return; my $msg = shift; $self->{on_warning}->($msg); } ## end sub warning #=head2 handle() # #getter # #=head2 handle($handle) # #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 # #=cut sub handle { my $self = shift; if (@_) { $self->{handle} = shift; } return $self->{handle}; } ## end sub handle # Gearman::Client::Async is the only consumer of set_on_post_hooks sub set_on_post_hooks { my ($self, $code) = @_; $self->{on_post_hooks} = $code; } #=head2 wipe() # #cleanup # #=over # #=item # #on_post_hooks # #=item # #on_complete # #=item # #on_fail # #=item # #on_retry # #=item # #on_status # #=item # #hooks # #=back # #=cut sub wipe { my $self = shift; my @h = qw/ on_post_hooks on_complete on_fail on_retry on_status hooks /; foreach my $f (@h) { $self->{$f} = undef; } } ## end sub wipe #=head2 func() # #=cut sub func { my $self = shift; return $self->{func}; } #=head2 timeout() # #getter # #=head2 timeout($t) # #setter # #B timeout # #=cut sub timeout { my $self = shift; if (@_) { $self->{timeout} = shift; } return $self->{timeout}; } ## end sub timeout #=head2 mode() # #B mode in depends of background and priority # #=cut sub mode { my $self = shift; my $mode = "submit_job"; if ($self->_priority() ne "normal") { $mode .= "_" . $self->_priority(); } if ($self->{background}) { $mode .= "_bg"; } return $mode; } ## end sub mode #=head2 _priority($priority) # #set/get priority # #valid C<$priority> value # #=over # #=item # #high # #=item # #normal (default) # #=item # #low # #=back # #=cut sub _priority { my ($self, $priority) = @_; if ($self->{high_priority}) { warn <<'HERE'; Gearman::Task key high_priority is deprecated. Use priority => "high" instead HERE $self->{priority} = "high"; delete($self->{high_priority}); } ## end if ($self->{high_priority...}) if ($priority) { $priority =~ /^(high|normal|low)$/ || Carp::croak "unsupported priority value"; $self->{priority} = $priority; } $self->{priority} ||= "normal"; return $self->{priority}; } ## end sub _priority 1; __END__ Gearman-2.004.015/lib/Gearman/Util.pm0000644000175000017500000002302513340014503015745 0ustar palikpalikpackage Gearman::Util; use version (); $Gearman::Util::VERSION = version->declare("2.004.015"); use strict; use warnings; # for sake of _read_sock no warnings "recursion"; # man errno # Resource temporarily unavailable # (may be the same value as EWOULDBLOCK) (POSIX.1) use IO::Select; use POSIX qw(:errno_h); use Scalar::Util qw(); use Time::HiRes qw(); =head1 NAME Gearman::Util - Utility functions for gearman distributed job system =head1 METHODS =cut sub DEBUG () {0} # 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: --- 4 => ['I', "pre_sleep"], # from W: --- 6 => ['O', "noop"], # J->W --- 7 => ['I', "submit_job"], # C->J FUNC[0]UNIQ[0]ARGS 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 16 => ['I', "echo_req"], # ?->J TEXT 17 => ['O', "echo_res"], # J->? TEXT 18 => ['I', "submit_job_bg"], # C->J " " " " " 19 => ['O', "error"], # J->? ERRCODE[0]ERR_TEXT 20 => ['O', "status_res"], # C->J: HANDLE[0]KNOWN[0]RUNNING[0]NUM[0]DENOM 21 => ['I', "submit_job_high"], # C->J FUNC[0]UNIQ[0]ARGS 22 => ['I', "set_client_id"], # W->J: [RANDOM_STRING_NO_WHITESPACE] 23 => ['I', "can_do_timeout"], # from W: FUNC[0]TIMEOUT # 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 --- 25 => ['IO', "work_exception"], # W->J/C: HANDLE[0]EXCEPTION 26 => ['I', "option_req"], # C->J: [OPT] 27 => ['O', "option_res"], # J->C: [OPT] 28 => ['IO', "work_data"], # W->J/C: HANDLE[0]RES 29 => ['IO', "work_warning"], # W->J/C: HANDLE[0]RES 32 => ['I', "submit_job_high_bg"], # C->J FUNC[0]UNIQ[0]ARGS 33 => ['I', "submit_job_low"], # C->J FUNC[0]UNIQ[0]ARGS 34 => ['I', "submit_job_low_bg"], # C->J FUNC[0]UNIQ[0]ARGS ); our %num; # name -> num while (my ($num, $ary) = each %cmd) { die if $num{ $ary->[1] }; $num{ $ary->[1] } = $num; } =head2 cmd_name($num) B cmd =cut sub cmd_name { my $num = shift; my $c = $cmd{$num}; return $c ? $c->[1] : undef; } =head2 pack_req_command($key, $arg) B request string =cut sub pack_req_command { return _pack_command("REQ", @_); } =head2 pack_res_command($cmd, $arg) B response string =cut sub pack_res_command { return _pack_command("RES", @_); } =head2 read_res_packet($sock, $err_ref, $timeout) B undef on closed socket or malformed packet =cut sub read_res_packet { warn " Entering read_res_packet" if DEBUG; my $sock = shift; my $err_ref = shift; my $timeout = shift; my $time_start = Time::HiRes::time(); unless (Scalar::Util::blessed($sock)) { # for the sake of Gearman::Client::Async # see https://github.com/p-alik/perl-Gearman/issues/37 (ref($sock) eq "GLOB") || die "provided value is not a blessed object"; ($$sock && $$sock eq '*Gearman::Worker::$sock') || die "provided value is not a GLOB of type Gearman::Worker::\$sock"; } ## end unless (Scalar::Util::blessed...) my $err = sub { my $code = shift; Scalar::Util::blessed($sock) && $sock->close() if $sock->connected; $$err_ref = $code if ref $err_ref; return undef; }; $sock->blocking(0); my $is = IO::Select->new($sock); my $readlen = 12; my $offset = 0; my $buf = ''; my $using_ssl = $sock->isa("IO::Socket::SSL"); my ($magic, $type, $len); warn " Starting up event loop\n" if DEBUG; while (1) { if ($using_ssl && $sock->pending()) { warn " We have @{[ $sock->pending() ]} bytes...\n" if DEBUG; } else { my $time_remaining = undef; if (defined $timeout) { warn " We have a timeout of $timeout\n" if DEBUG; $time_remaining = $time_start + $timeout - Time::HiRes::time(); return $err->("timeout") if $time_remaining < 0; } $is->can_read($time_remaining) || next; } ## end else [ if ($using_ssl && $sock...)] warn " Entering read loop\n" if DEBUG; my ($ok, $err_code) = _read_sock($sock, \$buf, \$readlen, \$offset); if (!defined($ok)) { next; } elsif ($ok == 0) { return $err->($err_code); } if (!defined $type) { next unless length($buf) >= 12; my $header = substr($buf, 0, 12, ''); ($magic, $type, $len) = unpack("a4NN", $header); return $err->("malformed_magic: '$magic'") unless $magic eq "\0RES"; my $starting = length($buf); $readlen = $len - $starting; $offset = $starting; if ($readlen) { my ($ok, $err_code) = _read_sock($sock, \$buf, \$readlen, \$offset); if (!defined($ok)) { next; } elsif ($ok == 0) { return $err->($err_code); } } ## end if ($readlen) } ## end if (!defined $type) $type = $cmd{$type}; return $err->("bogus_command") unless $type; return $err->("bogus_command_type") unless index($type->[0], "O") != -1; warn " Fully formed res packet, returning; type=$type->[1] len=$len\n" if DEBUG; $sock->blocking(1); return { type => $type->[1], len => $len, blobref => \$buf, }; } ## end while (1) } ## end sub read_res_packet sub _read_sock { my ($sock, $buf_ref, $readlen_ref, $offset_ref) = @_; local $!; my $rv = sysread($sock, $$buf_ref, $$readlen_ref, $$offset_ref); unless ($rv) { warn " Read error: $!\n" if DEBUG; $! == EAGAIN && return; } return (0, "read_error") unless defined $rv; return (0, "eof") unless $rv; unless ($rv >= $$readlen_ref) { warn " Partial read of $rv bytes, at offset $$offset_ref, readlen was $$readlen_ref\n" if DEBUG; $$offset_ref += $rv; $$readlen_ref -= $rv; $sock->blocking(1); my $ret = _read_sock($sock, $buf_ref, $readlen_ref, $offset_ref); $sock->blocking(0); return $ret; } ## end unless ($rv >= $$readlen_ref) warn " Finished reading\n" if DEBUG; return (1); } ## end sub _read_sock =head2 read_text_status($sock, $err_ref) =cut sub read_text_status { my $sock = shift; my $err_ref = shift; my $err = sub { my $code = shift; $sock->close() if $sock->connected; $$err_ref = $code if ref $err_ref; return undef; }; $sock->connected || return $err->("can't read from unconnected socket"); my @lines; my $complete = 0; while (my $line = <$sock>) { chomp $line; return $err->($1) if $line =~ /^ERR (\w+) /; if ($line eq '.') { $complete++; last; } push @lines, $line; } ## end while (my $line = <$sock>) return $err->("eof") unless $complete; return @lines; } ## end sub read_text_status =head2 send_req($sock, $reqref) =cut sub send_req { my ($sock, $reqref) = @_; return 0 unless $sock; my $data = ${$reqref}; (my $total_len) = (my $len) = length($data); my ($num_zero_writes, $offset) = (0, 0); local $SIG{PIPE} = "IGNORE"; while ($len && ($num_zero_writes < 5)) { my $written = $sock->syswrite($data, $len, $offset); if (!defined $written) { warn "send_req: syswrite error: $!" if DEBUG; return 0; } elsif ($written > 0) { $len -= $written; $offset += $written; } else { $num_zero_writes++; } } ## end while ($len && ($num_zero_writes...)) return ($total_len > 0 && $offset == $total_len); } ## end sub send_req =head2 wait_for_readability($fileno, $timeout) given a file descriptor number and a timeout, wait for that descriptor to become readable B 0 or 1 on if it did or not =cut 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; } ## end sub wait_for_readability # # _pack_command($prefix, $key, $arg) # sub _pack_command { my ($prefix, $key, $arg) = @_; ($key && $num{$key}) || die sprintf("Bogus type arg of '%s'", $key || ''); $arg ||= ''; my $len = length($arg); return "\0$prefix" . pack("NN", $num{$key}, $len) . $arg; } ## end sub _pack_command 1; Gearman-2.004.015/lib/Gearman/JobStatus.pm0000644000175000017500000000175413340014503016753 0ustar palikpalikpackage Gearman::JobStatus; use version (); $Gearman::JobStatus::VERSION = version->declare("2.004.015"); use strict; use warnings; =head1 NAME Gearman::JobStatus - represents a job status in gearman distributed job system =head1 DESCRIPTION L get_status($handle) returns I for a given handle =head1 METHODS =cut sub new { my ($class, $known, $running, $nu, $de) = @_; $nu = '' unless defined($nu) && length($nu); $de = '' unless defined($de) && length($de); return bless [$known, $running, $nu, $de], $class; } ## end sub new =head2 known() =cut sub known { shift->[0]; } =head2 running() =cut sub running { shift->[1]; } =head2 progress() =cut sub progress { my $self = shift; return $self->[2] ne '' ? [$self->[2], $self->[3]] : undef; } =head2 percent() =cut sub percent { my $self = shift; return ($self->[2] ne '' && $self->[3]) ? ($self->[2] / $self->[3]) : undef; } ## end sub percent 1; Gearman-2.004.015/lib/Gearman/Taskset.pm0000644000175000017500000003777313340014503016465 0ustar palikpalikpackage Gearman::Taskset; use version (); $Gearman::Taskset::VERSION = version->declare("2.004.015"); use strict; use warnings; =head1 NAME Gearman::Taskset - a taskset in Gearman, from the point of view of a L =head1 SYNOPSIS use Gearman::Client; my $client = Gearman::Client->new; # waiting on a set of tasks in parallel my $ts = $client->new_task_set; $ts->add_task( "add" => "1+2", {...}); $ts->wait(); =head1 DESCRIPTION Gearman::Taskset is a L's representation of tasks queue =head1 METHODS =cut use fields ( qw/ waiting client need_handle default_sock default_sockaddr loaned_sock cancelled hooks / ); use Carp (); use Gearman::Util (); use Gearman::ResponseParser::Taskset; use IO::Select; # i thought about weakening taskset's client, but might be too weak. use Scalar::Util (); use Socket (); use Storable (); use Time::HiRes (); =head2 new($client) =cut sub new { my ($self, $client) = @_; (Scalar::Util::blessed($client) && $client->isa("Gearman::Client")) || Carp::croak "provided client argument is not a Gearman::Client reference"; unless (ref $self) { $self = fields::new($self); } # { handle => [Task, ...] } $self->{waiting} = {}; $self->{need_handle} = []; $self->{client} = $client; # { hostport => socket } $self->{loaned_sock} = {}; # bool, if taskset has been cancelled mid-processing $self->{cancelled} = 0; # { hookname => coderef } $self->{hooks} = {}; # default socket (non-merged requests) $self->{default_sock} = undef; # $self->client()->_js_str($self->{default_sock}); $self->{default_sockaddr} = undef; return $self; } ## end sub new sub DESTROY { my $self = shift; # During global cleanup this may be called out of order, and the client my not exist in the taskset. return unless $self->client; if ($self->{default_sock}) { $self->client->_sock_cache($self->{default_sockaddr}, $self->{default_sock}); } keys %{ $self->{loaned_sock} }; while (my ($hp, $sock) = each %{ $self->{loaned_sock} }) { $self->client->_sock_cache($hp, $sock); } } ## end sub DESTROY #=head2 run_hook($name) # #run a hook callback if defined # #=cut sub run_hook { my ($self, $name) = (shift, shift); ($name && $self->{hooks}->{$name}) || return; eval { $self->{hooks}->{$name}->(@_) }; warn "Gearman::Taskset hook '$name' threw error: $@\n" if $@; } ## end sub run_hook #=head2 add_hook($name, [$cb]) # #add a hook # #=cut sub add_hook { my ($self, $name, $cb) = @_; $name || return; if ($cb) { $self->{hooks}->{$name} = $cb; } else { delete $self->{hooks}->{$name}; } } ## end sub add_hook #=head2 client () # #B L # #=cut # 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 { return shift->{client}; } #=head2 cancel() # #Close sockets, cleanup internals. # #=cut sub cancel { my $self = shift; $self->{cancelled} = 1; if ($self->{default_sock}) { close($self->{default_sock}); $self->{default_sock} = undef; } foreach my $sock (values %{ $self->{loaned_sock} }) { $sock->close; } $self->{client} = undef; $self->{loaned_sock} = {}; $self->{need_handle} = []; $self->{waiting} = {}; } ## end sub cancel # # _get_loaned_sock($js) # sub _get_loaned_sock { my ($self, $js) = @_; my $js_str = $self->client()->_js_str($js); if (my $sock = $self->{loaned_sock}{$js_str}) { return $sock if $sock->connected; delete $self->{loaned_sock}{$js_str}; } my $sock = $self->client()->_get_js_sock($js); return $self->{loaned_sock}{$js_str} = $sock; } ## end sub _get_loaned_sock =head2 wait(%opts) 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. =cut sub wait { my ($self, %opts) = @_; my ($timeout, $given_timeout_s); if (exists $opts{timeout}) { $timeout = delete $opts{timeout}; if (defined $timeout) { ## keep the given timeout value for the failure reason # Handles issue #35 # https://github.com/p-alik/perl-Gearman/issues/35 $given_timeout_s = $timeout; $timeout += Time::HiRes::time(); } } Carp::carp "Unknown options: " . join(',', keys %opts) . " passed to Taskset->wait." if keys %opts; # fd -> Gearman::ResponseParser object my %parser; my $cb = sub { my ($fd) = shift; my $parser = $parser{$fd} ||= Gearman::ResponseParser::Taskset->new( source => $fd, taskset => $self ); eval { $parser->parse_sock($fd); 1; } or do { # TODO this should remove the fd from the list, and reassign any tasks to other jobserver, or bail. # We're not in an accessible place here, so if all job servers fail we must die to prevent hanging. Carp::croak("Job server failure: $@"); } ## end do }; my $io = IO::Select->new($self->{default_sock}, values %{ $self->{loaned_sock} }); my $pending_sock; foreach ($io->handles) { (ref($_) eq "IO::Socket::SSL" && $_->pending()) || next; $pending_sock = $_; last; } if ($pending_sock) { return $cb->($pending_sock); } while (!$self->{cancelled} && keys %{ $self->{waiting} }) { my $time_left = $timeout ? $timeout - Time::HiRes::time() : 0.5; my $nfound = select($io->bits(), undef, undef, $time_left); if ($timeout && $time_left <= 0) { ## Attempt to fix # https://github.com/p-alik/perl-Gearman/issues/33 # Mark all tasks of that taskset failed. # Get all waiting tasks and call their "fail" method one by one # with the failure reason. for (values %{ $self->{waiting} }) { for (@$_) { my $func = $_->func; ## use the given timeout here # Handles issue #35 # https://github.com/p-alik/perl-Gearman/issues/35 $_->fail("Task $func elapsed timeout [${given_timeout_s}s]"); } } ## end for (values %{ $self->{...}}) $self->cancel; return; } ## end if ($timeout && $time_left...) next if !$nfound; foreach my $fd ($io->can_read()) { $cb->($fd); } } ## end while (!$self->{cancelled...}) } ## end sub wait =head2 add_task(Gearman::Task) =head2 add_task($func, <$scalar | $scalarref>, <$uniq | $opts_hr> Adds a task to the taskset. Three different calling conventions are available. C<$opts_hr> see L =cut sub add_task { my $self = shift; my $task = $self->client()->_get_task_from_args(@_); $task->taskset($self); $self->run_hook('add_task', $self, $task); my $jssock = $task->{jssock}; return $task->fail("undefined jssock") unless ($jssock); my $req = $task->pack_submit_packet($self->client); Gearman::Util::send_req($jssock, \$req) || Carp::croak "Error sending data to job server"; push @{ $self->{need_handle} }, $task; while (@{ $self->{need_handle} }) { my $rv = $self->_wait_for_packet($jssock, $self->client()->{command_timeout}); if (!$rv) { # ditch it, it failed. # this will resubmit it if it failed. shift @{ $self->{need_handle} }; return $task->fail( join(' ', "no rv on waiting for packet", defined($rv) ? $rv : $!) ); } ## end if (!$rv) } ## end while (@{ $self->{need_handle...}}) return $task->handle; } ## end sub add_task # # _get_default_sock() # used in Gearman::Task->taskset only # sub _get_default_sock { my $self = shift; return $self->{default_sock} if $self->{default_sock}; my $getter = sub { my $js = shift; return $self->{loaned_sock}{$js} || $self->client()->_get_js_sock($js); }; my ($js, $jss) = $self->client()->_get_random_js_sock($getter); return unless $jss; my $js_str = $self->client()->_js_str($js); $self->{loaned_sock}{$js_str} ||= $jss; $self->{default_sock} = $jss; $self->{default_sockaddr} = $js_str; return $jss; } ## end sub _get_default_sock # # _get_hashed_sock($hv) # # only used in Gearman::Task->taskset only # # return a socket sub _get_hashed_sock { my $self = shift; my $hv = shift; my ($js_count, @job_servers) = ($self->client()->{js_count}, $self->client()->job_servers()); my $sock; for (my $off = 0; $off < $js_count; $off++) { my $idx = ($hv + $off) % ($js_count); $sock = $self->_get_loaned_sock($job_servers[$idx]); last; } return $sock; } ## end sub _get_hashed_sock # # _wait_for_packet($sock, $timeout) # # $sock socket to singularly read from # # returns boolean when given a sock to wait on. # otherwise, return value is undefined. sub _wait_for_packet { my ($self, $sock, $timeout) = @_; my $res = Gearman::Util::read_res_packet($sock, \my $err, $timeout); $err && Carp::croak("reading response packet failed: $err"); return $res ? $self->process_packet($res, $sock) : 0; } ## end sub _wait_for_packet # # _is_port($sock) # # return hostport || ipport # sub _ip_port { my ($self, $sock) = @_; $sock || return; my $pn = getpeername($sock); $pn || return; # look for a hostport in loaned_sock my $hostport; my @k = keys %{ $self->{loaned_sock} }; while (!$hostport && (my $hp = shift @k)) { my $s = $self->{loaned_sock}->{$hp}; $s || next; if ($sock == $s) { $hostport = $hp; # last; } } ## end while (!$hostport && (my ...)) # hopefully it solves client->get_status mismatch $hostport && return $hostport; my $fam = Socket::sockaddr_family($pn); my ($port, $iaddr) = ($fam == Socket::AF_INET6) ? Socket::sockaddr_in6($pn) : Socket::sockaddr_in($pn); my $addr = Socket::inet_ntop($fam, $iaddr); return join ':', $addr, $port; } ## end sub _ip_port # # _fail_jshandle($shandle, $type, [$message]) # # note the failure of a task given by its jobserver-specific handle # sub _fail_jshandle { my ($self, $shandle, $type, $msg) = @_; $shandle or Carp::croak "_fail_jshandle() called without shandle parameter"; my $task_list = $self->{waiting}{$shandle} or Carp::croak "Got $type for unknown handle: $shandle"; my $task = shift @{$task_list}; (Scalar::Util::blessed($task) && $task->isa("Gearman::Task")) || Carp::croak "task_list is empty on $type for handle $shandle\n"; $task->fail($msg || "jshandle fail"); delete $self->{waiting}{$shandle} unless @{$task_list}; } ## end sub _fail_jshandle #=head2 process_packet($res, $sock) # # process response packet # #=cut sub process_packet { my ($self, $res, $sock) = @_; my $qr = qr/(.+?)\0/; my %assert = ( task => sub { my ($task, $msg) = @_; (Scalar::Util::blessed($task) && $task->isa("Gearman::Task")) || Carp::croak $msg; } ); my %type = ( job_created => sub { my ($blob) = shift; my $task = shift @{ $self->{need_handle} }; $assert{task} ->($task, "Got an unexpected job_created notification"); my $shandle = $blob; my $ipport = $self->_ip_port($sock); # did sock become disconnected in the meantime? if (!$ipport) { $self->_fail_jshandle($shandle, "job_created"); return 1; } $task->handle("$ipport//$shandle"); return 1 if $task->{background}; push @{ $self->{waiting}{$shandle} ||= [] }, $task; return 1; }, work_complete => sub { my ($blob) = shift; ($blob =~ /^$qr/) or Carp::croak "Bogus work_complete from server"; $blob =~ s/^$qr//; my $shandle = $1; my $task_list = $self->{waiting}{$shandle}; my $task = shift @{$task_list}; $assert{task}->( $task, "task_list is empty on work_complete for handle $shandle" ); $task->complete(\$blob); delete $self->{waiting}{$shandle} unless @{$task_list}; return 1; }, work_data => sub { my ($blob) = shift; $blob =~ s/^(.+?)\0// or Carp::croak "Bogus work_data from server"; my $shandle = $1; my $task_list = $self->{waiting}{$shandle}; my $task = $task_list->[0]; $assert{task}->($task, "task_list is empty on work_data for handle $shandle"); $task->data(\$blob); return 1; }, work_warning => sub { my ($blob) = shift; $blob =~ s/^(.+?)\0// or Carp::croak "Bogus work_warning from server"; my $shandle = $1; my $task_list = $self->{waiting}{$shandle}; my $task = $task_list->[0]; $assert{task}->( $task, "task_list is empty on work_warning for handle $shandle" ); $task->warning(\$blob); return 1; }, work_exception => sub { my ($blob) = shift; ($blob =~ /^$qr/) or Carp::croak "Bogus work_exception from server"; $blob =~ s/^$qr//; my $shandle = $1; my $task_list = $self->{waiting}{$shandle}; my $task = shift @{$task_list}; $assert{task}->( $task, "task_list is empty on work_exception for handle $shandle" ); #FIXME we have to freeze $blob because Task->exception expected it in this form. # The only reason I see to do it so, is Worker->work implementation. With Gearman::Server it uses nfreeze for exception value. $task->exception(\Storable::freeze(\$blob)); delete $self->{waiting}{$shandle} unless @{$task_list}; return 1; }, work_fail => sub { $self->_fail_jshandle(shift, "work_fail"); return 1; }, work_status => sub { my ($blob) = shift; my ($shandle, $nu, $de) = split(/\0/, $blob); my $task_list = $self->{waiting}{$shandle}; ref($task_list) eq "ARRAY" && scalar(@{$task_list}) or Carp::croak "Got work_status for unknown handle: $shandle"; # 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 $task (@{$task_list}) { $task->status($nu, $de); } return 1; }, ); defined($type{ $res->{type} }) || Carp::croak "Unimplemented packet type: $res->{type} [${$res->{blobref}}]"; return $type{ $res->{type} }->(${ $res->{blobref} }); } ## end sub process_packet 1; Gearman-2.004.015/lib/Gearman/Objects.pm0000644000175000017500000001351713340014503016426 0ustar palikpalikpackage Gearman::Objects; use version (); $Gearman::Objects::VERSION = version->declare("2.004.015"); use strict; use warnings; =head1 NAME Gearman::Objects - a parent class for L and L =head1 METHODS =cut use constant DEFAULT_PORT => 4730; use Carp (); use IO::Socket::IP (); use IO::Socket::SSL (); use Socket (); use List::MoreUtils qw/ first_index /; use fields qw/ debug job_servers js_count prefix prefix_separator sock_cache /; sub new { my $self = shift; my (%opts) = @_; unless (ref $self) { $self = fields::new($self); } $self->{job_servers} = []; $self->{js_count} = 0; $opts{job_servers} && $self->set_job_servers($opts{job_servers}); $self->debug($opts{debug}); $self->prefix($opts{prefix}); $self->prefix_separator($opts{prefix_separator}); $self->{sock_cache} = {}; return $self; } ## end sub new =head2 job_servers([$job_servers]) Initialize the list of job servers. C<$job_servers>should be array or array reference of hash references or stringified job servers. If the port number is not provided, C<4730> is used as the default. For example: C<< $client->job_servers('127.0.0.1', { host => "192.168.1.100", port => 4730 }); >> B C<[job_servers]> =cut sub job_servers { my ($self) = shift; (@_) && $self->set_job_servers(@_); return wantarray ? @{ $self->{job_servers} } : $self->{job_servers}; } ## end sub job_servers =head2 set_job_servers($js) set job_servers attribute by canonicalized C<$js> =cut sub set_job_servers { my $self = shift; my $list = $self->canonicalize_job_servers(@_); $self->{js_count} = scalar @{$list}; return $self->{job_servers} = $list; } ## end sub set_job_servers =head2 canonicalize_job_servers($js) C<$js> a string, hash reference or array reference of aforementioned. Hash reference should contain at least host key. All keys: host, port (4730 on default), use_ssl, ca_file, cert_file, key_file, socket_cb B [canonicalized list] =cut sub canonicalize_job_servers { my ($self) = shift; my $ref = ref($_[0]); my @in = $ref && $ref eq "ARRAY" ? @{ $_[0] } : @_; my $out = []; foreach my $i (@in) { my $ref = ref($i); if ($ref) { $ref eq "HASH" || Carp::croak "unsupported job server value of type ", ref($i); $i->{port} ||= Gearman::Objects::DEFAULT_PORT; } elsif ($i !~ /:/) { $i .= ':' . Gearman::Objects::DEFAULT_PORT; } push @{$out}, $i; } ## end foreach my $i (@in) return $out; } ## end sub canonicalize_job_servers sub debug { return shift->_property("debug", @_); } =head2 func($func) B C<< join $prefix_separator, $prefix, $func >> =cut sub func { my ($self, $func) = @_; my $prefix = $self->prefix; return defined($prefix) ? join($self->prefix_separator, $prefix, $func) : $func; } ## end sub func =head2 prefix([$prefix]) get/set the namespace / prefix for the function names. =cut sub prefix { return shift->_property("prefix", @_); } =head2 prefix_separator([$separator]) getter/setter default: "\t" I =cut sub prefix_separator { my ($self) = shift; my $r = $self->_property("prefix_separator", scalar(@_) ? $_[0] : ()); return $r ? $r : $self->_property("prefix_separator", "\t"); } =head2 socket($js, [$timeout]) depends on C prepare L or L =over =item C<$host_port> peer address =item C<$timeout> default: 1 =back B depends on C IO::Socket::(IP|SSL) on success =cut sub socket { my ($self, $js, $t) = @_; unless (ref($js)) { my ($h, $p) = ($js =~ /^(.*):(\d+)$/); $js = { host => $h, port => $p }; } my %opts = ( PeerPort => $js->{port}, PeerHost => $js->{host}, Timeout => $t || 1 ); my $sc = "IO::Socket::IP"; if ($js->{use_ssl}) { $sc = "IO::Socket::SSL"; for (qw/ ca_file cert_file key_file /) { $js->{$_} || next; $opts{ join('_', "SSL", $_) } = $js->{$_}; } } ## end if ($js->{use_ssl}) $js->{socket_cb} && $js->{socket_cb}->(\%opts); my $s = $sc->new(%opts); unless ($s) { $self->debug() && Carp::carp("connection failed error='$@'", $js->{use_ssl} ? ", ssl_error='$IO::Socket::SSL::SSL_ERROR'" : ""); } ## end unless ($s) return $s; } ## end sub socket =head2 sock_nodelay($sock) set TCP_NODELAY on $sock, die on failure =cut sub sock_nodelay { my ($self, $sock) = @_; setsockopt($sock, Socket::IPPROTO_TCP, Socket::TCP_NODELAY, pack("l", 1)) or Carp::croak "setsockopt: $!"; } # _sock_cache($js, [$sock, $delete]) # # B $sock || undef # sub _sock_cache { my ($self, $js, $sock, $delete) = @_; my $hp = $self->_js_str($js); if ($sock) { $self->{sock_cache}->{$hp} = $sock; } return $delete ? delete($self->{sock_cache}->{$hp}) : $self->{sock_cache}->{$hp}; } ## end sub _sock_cache # # _property($name, [$value]) # set/get sub _property { my $self = shift; my $name = shift; $name || return; if (@_) { $self->{$name} = shift; } return $self->{$name}; } ## end sub _property # #_js_str($js) # # return host:port sub _js_str { my ($self, $js) = @_; return ref($js) eq "HASH" ? join(':', @{$js}{qw/host port/}) : $js; } # # _js($js_str) # # return job_servers item || undef # sub _js { my ($self, $js_str) = @_; my @s = $self->job_servers(); my $i = first_index { $js_str eq $self->_js_str($_) } @s; return ($i == -1 || $i > $#s) ? undef : $s[$i]; } ## end sub _js 1; Gearman-2.004.015/lib/Gearman/Job.pm0000644000175000017500000000276013340014503015545 0ustar palikpalikpackage Gearman::Job; use version (); $Gearman::Job::VERSION = version->declare("2.004.015"); use strict; use warnings; use Gearman::Util (); use Carp (); =head1 NAME Gearman::Job - Job in gearman distributed job system =head1 DESCRIPTION I is the object that's handed to the worker subrefs =head1 METHODS =cut use fields ( 'func', 'argref', 'handle', # job server's socket 'jss', # job server 'js', ); sub new { my ($self, %arg) = @_; unless (ref $self) { $self = fields::new($self); } while(my ($k, $v) = each(%arg)) { $self->{$k} = $v; } return $self; } ## end sub new =head2 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. =cut sub set_status { my $self = shift; my ($nu, $de) = @_; my $req = Gearman::Util::pack_req_command("work_status", join("\0", $self->{handle}, $nu, $de)); Carp::croak "work_status write failed" unless Gearman::Util::send_req($self->{jss}, \$req); return 1; } ## end sub set_status =head2 argref() =cut sub argref { return shift->{argref}; } =head2 arg() B the scalar argument that the client sent to the job server. =cut sub arg { return ${ shift->{argref} }; } =head2 handle() B handle =cut sub handle { return shift->{handle}; } 1; Gearman-2.004.015/lib/Gearman/Worker.pm0000644000175000017500000005516213340014503016310 0ustar palikpalikpackage Gearman::Worker; use version; $Gearman::Worker::VERSION = version->declare("2.004.015"); use strict; use warnings; use base "Gearman::Objects"; =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', { host => '10.0.0.1', port => 4730, socket_cb => sub {...}, use_ssl => 1, ca_file => ..., cert_file => ..., key_file => ..., } ); $worker->register_function($funcname => sub { ... } ); $worker->work( on_start => sub { my ($jobhandle) = @_; ... }, on_complete => sub { my ($jobhandle, $result) = @_; ... }, on_fail => sub { my ($jobhandle, $err) = @_; .. }, stop_if => sub { my ($is_idle, $last_job_time) = @_; # stop idle worker return $is_idle; }, ); =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: I is derived from L =over 4 =item * job_servers List of job servers. Value should be an array reference, hash reference or scalar. 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. =item * client_id Unique worker identifier for C. =back =head2 $worker-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 concatenation of the prefix and the function name. =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 L documentation for a sample client sending the I job. =head1 NOTE If you intend to send or receive UTF-8 data over SSL connections, beware that there is no UTF-8 support in the underlying L. L describes proper workarounds. =head1 METHODS =cut use Carp (); use Gearman::Util (); use Gearman::Job; use Storable (); use fields ( '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 identifier 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.. ); sub new { my ($class, %opts) = @_; my $self = $class; $self = fields::new($class) unless ref $self; if ($ENV{GEARMAN_WORKER_USE_STDIO}) { if ($opts{job_servers}) { warn join ' ', __PACKAGE__, 'ignores job_servers if $ENV{GEARMAN_WORKER_USE_STDIO} is set'; # delete job_servers to insure Gearman::Objects # does not treat correspondent object property delete($opts{job_servers}); } ## end if ($opts{job_servers}) } ## end if ($ENV{GEARMAN_WORKER_USE_STDIO...}) $self->SUPER::new(%opts); $self->{last_connect_fail} = {}; $self->{down_since} = {}; $self->{can} = {}; $self->{timeouts} = {}; $self->{client_id} = $opts{client_id} || join('', map { chr(int(rand(26)) + 97) } (1 .. 30)); 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->_set_client_id($sock); } ## end if ($ENV{GEARMAN_WORKER_USE_STDIO...}) return $self; } ## end sub new =head2 reset_abilities This tells all the job servers that this worker can no longer do any tasks. B true if C request successfully transmitted to C =cut sub reset_abilities { my $self = shift; my $req = _rc("reset_abilities"); $self->{can} = {}; $self->{timeouts} = {}; return $self->_register_all($req); } ## end sub reset_abilities =head2 work(%opts) This endlessly loops. It takes an applicable job, if available, does the job, and then waits for the next one. You can pass "stop_if", "on_start", "on_complete" and "on_fail" callbacks in I<%opts>. See L =cut my %job_done; sub work { my ($self, %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 = _rc("grab_job"); my $presleep_req = _rc("pre_sleep"); my $last_job_time; my $on_connect = sub { return _send($_[0], \$presleep_req); }; my %js_map = map { $self->_js_str($_) => $_ } $self->job_servers; # "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 } keys(%js_map); # ( 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)); for (my $i = 0; $i < $js_count; $i++) { my $js_index = ($i + $js_offset) % $js_count; my $js_str = $jobby_js[$js_index]; my $js = $js_map{$js_str}; my $jss = $self->_get_js_sock( $js, on_connect => $on_connect, register_on_reconnect => 1 ) 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 (_send($jss, \$grab_req)) { if ($!{EPIPE} && $self->{parent_pipe}) { # our parent process died, so let's just quit # gracefully. exit(0); } ## end if ($!{EPIPE} && $self...) $self->_uncache_sock($js, "grab_job_timeout"); delete $last_update_time{$js_str}; next; } ## end unless (_send($jss, \$grab_req...)) # 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_str}; next; } ## end unless (Gearman::Util::wait_for_readability...) 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_str}; next; } } while ($res->{type} eq "noop"); if ($res->{type} eq "no_job") { unless (_send($jss, \$presleep_req)) { delete $last_update_time{$js_str}; $self->_uncache_sock($js, "write_presleep_error"); } $last_update_time{$js_str} = time; next; } ## end if ($res->{type} eq "no_job") unless ($res->{type} eq "job_assign") { my $msg = "unexpected packet type: $res->{type}"; if ($res->{type} eq "error") { $msg .= " [${$res->{blobref}}]\n"; $msg =~ s/\0/ -- /g; } die $msg; } ## end unless ($res->{type} eq "job_assign") ${ $res->{blobref} } =~ s/^(.+?)\0(.+?)\0// or die "regexp on job_assign failed"; my ($handle, $ability) = ($1, $2); my $job = Gearman::Job->new( func => $ability, argref => $res->{blobref}, handle => $handle, jss => $jss, js => $js ); my $jobhandle = join("//", $js_str, $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_str} = $last_job_time = time(); if ($err) { my $exception_req = _rc("work_exception", _join0($handle, Storable::nfreeze(\$err))); unless (_send($jss, \$exception_req)) { $self->_uncache_sock($js, "write_res_error"); next; } } ## end if ($err) if (!defined $job_done{ $job->handle }) { if (defined $ret) { $self->send_work_complete($job, $ret); } else { $self->send_work_fail($job); } } ## end if (!defined $job_done...) my $done = delete $job_done{ $job->handle }; if ($done->{command} eq "work_complete") { $complete_cb->($jobhandle, $ret) if $complete_cb; } else { $fail_cb->($jobhandle, $err) if $fail_cb; } unless ($done->{result}) { $self->_uncache_sock($js, "write_res_error"); next; } $active_js{$js_str} = 1; } ## end for (my $i = 0; $i < $js_count...) my @jss; foreach my $js_str (keys(%js_map)) { my $jss = $self->_get_js_sock( $js_map{$js_str}, on_connect => $on_connect, register_on_reconnect => 1 ) or next; push @jss, [$js_str, $jss]; } ## end foreach my $js_str (keys(%js_map...)) my $wake_vec = ''; foreach my $j (@jss) { (undef, my $_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_str, $jss) = @{$j}; my $fd = $jss->fileno; $active_js{$js_str} = 1 if vec($wout, $fd, 1); } ## end foreach my $j (@jss) } ## end if ($nready) my $is_idle = scalar(keys %active_js) > 0 ? 0 : 1; return if $stop_if->($is_idle, $last_job_time); my $update_since = time - (15 + rand 60); while (my ($js_str, $last_update) = each %last_update_time) { $active_js{$js_str} = 1 if $last_update < $update_since; } } ## end while (1) } ## end sub work =head2 $worker->register_function($funcname, $subref) =head2 $worker->register_function($funcname, $timeout, $subref) Registers the function C<$funcname> as being provided by the worker C<$worker>, and advertises these capabilities to all of the job servers defined in this worker. C<$subref> must be a subroutine reference that will be invoked when the worker receives a request for this function. It will be passed a L object representing the job that has been received by the worker. C<$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. B true if C<$funcname> registration successfully transmitted to C =cut sub register_function { my $self = shift; my $func = shift; $func || return; my $timeout; if (ref($_[0]) ne 'CODE') { $timeout = shift; } my $subref = shift; my $ability = $self->func($func); $self->{can}{$ability} = $subref; if (defined $timeout) { $self->{timeouts}{$ability} = $timeout; } my @job_servers = $self->job_servers(); @job_servers || return; my $done = 0; foreach my $js (@job_servers) { $self->_register_function($ability, $js) && $done++; } return $done == scalar @job_servers; } ## end sub register_function =head2 unregister_function($funcname) send cant_do C<$funcname> request to L B true if CANT_DO C<$funcname> request successfully transmitted to C =cut sub unregister_function { my ($self, $func) = @_; my $ability = $self->func($func); delete $self->{can}{$ability}; my $req = _rc("cant_do", $ability); return $self->_register_all($req); } ## end sub unregister_function =head2 job_servers(@servers) Override L method to skip job server initialization if working with L. Calling this method will do nothing in a worker that is running as a child process of a gearman server. =cut sub job_servers { my $self = shift; $ENV{GEARMAN_WORKER_USE_STDIO} && return $self->{job_servers}; return $self->SUPER::job_servers(@_); } ## end sub job_servers =head2 send_work_complete($job, $v) notify the server (and listening clients) that job completed successfully =cut sub send_work_complete { return shift->_finish_job_request("work_complete", @_); } =head2 send_work_data($job, $data) Use this method to update the client with data from a running job. =cut sub send_work_data { my ($self, $job, $data) = @_; return $self->_job_request("work_data", $job, ref($data) ? ${$data} : $data); } =head2 send_work_warning($job, $message) Use this method to send a warning C<$message> to the server (and any listening clients) with regard to the running C. =cut sub send_work_warning { my ($self, $job, $msg) = @_; return $self->_job_request("work_warning", $job, $msg); } =head2 send_work_exception($job, $exception) Use this method to notify the server (and any listening clients) that the C failed with the given C<$exception>. If you are using L, you have to set parameter exceptions properly to get worker exception notifications. =cut sub send_work_exception { my ($self) = shift; return $self->_finish_job_request("work_exception", @_); } =head2 send_work_fail($job) Use this method to notify the server (and any listening clients) that the job failed. =cut sub send_work_fail { return shift->_finish_job_request("work_fail", shift); } =head2 send_work_status($job, $numerator, $denominator) Use this method to send periodically to the server status update for long running jobs to update the percentage complete. =cut sub send_work_status { my ($self, $job, $numerator, $denominator) = @_; return $self->_job_request("work_status", $job, $numerator, $denominator); } # _finish_job_request($cmd, $job, [$v]) # # send some data or message to the client for finished job # $cmd = work_complete || work_fail # sub _finish_job_request { my ($self, $cmd, $job, $v) = @_; my $res = $self->_job_request($cmd, $job, ref($v) ? ${$v} : $v); # set job done flag because work method check it $job_done{ $job->handle } = { command => $cmd, result => $res }; return $res; } ## end sub _finish_job_request # _job_request($cmd, $job, [$v]) # # send some data to the client for the running job # sub _job_request { my ($self, $cmd, $job, $v) = @_; my $req = _rc($cmd, $v ? _join0($job->handle, $v) : $job->handle); return _send($job->{jss}, \$req); } ## end sub _job_request # # _register_all($req) # sub _register_all { my ($self, $req) = @_; my @job_servers = $self->job_servers(); my $done = 0; foreach my $js (@job_servers) { my $jss = $self->_get_js_sock($js); ($jss && $req) || next; unless (_send($jss, \$req)) { $self->_uncache_sock($js, "$req request failed"); next; } $done++; } ## end foreach my $js (@job_servers) return $done == scalar @job_servers; } ## end sub _register_all # # _get_js_sock($js, %opts) # sub _get_js_sock { my ($self, $js, %opts) = @_; $js || return; my $js_str = $self->_js_str($js); my $on_connect = delete $opts{on_connect}; # Someday should warn when called with extra opts. warn "getting job server socket: $js_str" 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($js)) { return $sock if getpeername($sock); $self->_uncache_sock($js, "getpeername failed"); } my $now = time; my $down_since = $self->{down_since}{$js_str}; if ($down_since) { my $down_for = $now - $down_since; warn "$js_str down for $down_for" if $self->debug; my $retry_period = $down_for > 60 ? 30 : (int($down_for / 2) + 1); if ($self->{last_connect_fail}{$js_str} > $now - $retry_period) { return; } } ## end if ($down_since) warn "connecting to '$js_str'" if $self->debug; my $sock = $self->socket($js, 1); unless ($sock) { $self->{down_since}{$js_str} ||= $now; $self->{last_connect_fail}{$js_str} = $now; return; } ## end unless ($sock) $sock->autoflush(1); $self->sock_nodelay($sock); delete $self->{last_connect_fail}{$js_str}; delete $self->{down_since}{$js_str}; if ($opts{register_on_reconnect}) { my @fail = (); foreach (keys %{ $self->{can} }) { $self->_register_function($_, $js, $sock) || push @fail, $_; } if (@fail) { $self->_uncache_sock($js, join ' ', "failed registration of", @fail); return; } } ## end if ($opts{register_on_reconnect...}) $self->_sock_cache($js, $sock); if ($on_connect && !$on_connect->($sock)) { $self->_uncache_sock($js, "on connect callback failed"); return; } return $sock; } ## end sub _get_js_sock =head2 _uncache_sock($js, $reason) close TCP connection =cut sub _uncache_sock { my ($self, $js, $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}; $self->debug && warn join ' ', "close connection to", $self->_js_str($js), $reason || ''; # normal case, we just close this TCP connection and we'll reconnect later. # delete cached sock $self->_sock_cache($js, undef, 1); } ## end sub _uncache_sock # # _set_client_id($sock) # sub _set_client_id { my ($self, $sock) = @_; my $req = _rc("set_client_id", $self->{client_id}); return _send($sock, \$req); } # # _set_ability($sock, $ability, [$timeout]) # sub _set_ability { my ($self, $sock, $ability, $timeout) = @_; my $req; if (defined $timeout) { $req = _rc("can_do_timeout", _join0($ability, $timeout)); } else { $req = _rc("can_do", $ability); } return _send($sock, \$req); } ## end sub _set_ability # # _register_function($ability, $js, [$sock]) # set client id # can do # sub _register_function { my ($self, $ability, $js, $sock) = @_; $sock ||= $self->_get_js_sock($js); $sock || return; unless ($self->_set_client_id($sock)) { $self->_uncache_sock($js, "set client id request failed"); return; } unless ($self->_set_ability($sock, $ability, $self->{timeouts}{$ability})) { $self->_uncache_sock($js, "can do request failed"); return; } return 1; } ## end sub _register_function # # _send($jss, $req_ref) # # send C<$req> to C<$jss> # *_send = \&Gearman::Util::send_req; # # _rc($cmd, [@val]) # *_rc = \&Gearman::Util::pack_req_command; # # _join0(@v) # sub _join0 { return join("\0", @_); } 1; __END__ =head1 WORKERS AS CHILD PROCESSES Gearman workers can be 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 L 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. Gearman-2.004.015/lib/Gearman/Client.pm0000644000175000017500000003535313340014503016255 0ustar palikpalikpackage Gearman::Client; use version (); $Gearman::Client::VERSION = version->declare("2.004.015"); use strict; use warnings; =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', { host => '10.0.0.1', port => 4730, socket_cb => sub {...}, use_ssl => 1, ca_file => ..., cert_file => ..., key_file => ..., } ); # running a single task my $result_ref = $client->do_task("add", "1+2", { on_fail => sub {...}, on_complete => sub {...} }); 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. I is derived from L =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 exceptions If true, the client sends an L request for each connection to the job server. This causes job server to forward WORK_EXCEPTION packets to the client. =item job_servers List of job servers. Value should be an array reference, hash reference or scalar. Calls L to set I =item prefix Calls I (see L) to set the prefix / namespace. =item command_timeout Maximum time a gearman command should take to get a result (not a job timeout) default: 30 seconds =item backoff_max Max number of failed connection attempts before an job server will be temporary disabled default: 90 =back =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 L documentation for the worker for the I function. =head1 NOTE If you intend using UTF-8 data with SSL based connection, beware there is no UTF-8 support in underlying L. L describes proper workarounds. =cut use base 'Gearman::Objects'; use fields ( 'sock_info', # hostport -> hashref 'hooks', # hookname -> coderef 'exceptions', 'backoff_max', # maximum time a gearman command should take to get a result (not a job timeout) 'command_timeout', ); use Carp; use Gearman::Task; use Gearman::Taskset; use Gearman::JobStatus; use Time::HiRes; sub new { my ($self, %opts) = @_; unless (ref $self) { $self = fields::new($self); } $self->SUPER::new(%opts); $self->{hooks} = {}; $self->{exceptions} = 0; $self->{backoff_max} = 90; $self->{command_timeout} = 30; $self->{exceptions} = delete $opts{exceptions} if exists $opts{exceptions}; $self->{backoff_max} = $opts{backoff_max} if defined $opts{backoff_max}; $self->{command_timeout} = $opts{command_timeout} if defined $opts{command_timeout}; return $self; } ## end sub new =head1 METHODS =head2 new_task_set() Creates and returns a new L object. =cut sub new_task_set { my $self = shift; my $taskset = Gearman::Taskset->new($self); $self->run_hook('new_task_set', $self, $taskset); return $taskset; } ## end sub new_task_set # # _job_server_status_command($command, $each_line_sub) # $command e.g. "status\n". # $each_line_sub A sub to be called on each line of response; # takes $hostport and the $line as args. # sub _job_server_status_command { my ($self, $command, $each_line_sub) = (shift, shift, shift); my $list = scalar(@_) ? $self->canonicalize_job_servers(@_) : $self->job_servers(); my %js_map = map { $self->_js_str($_) => 1 } $self->job_servers(); foreach my $js (@{$list}) { defined($js_map{ $self->_js_str($js) }) || next; my $sock = $self->_get_js_sock($js) or next; my $rv = $sock->write($command); my $err; my @lines = Gearman::Util::read_text_status($sock, \$err); if ($err) { $self->debug() && warn $err; next; } foreach my $l (@lines) { $each_line_sub->($js, $l); } $self->_sock_cache($js, $sock); } ## end foreach my $js (@{$list}) } ## end sub _job_server_status_command =head2 get_job_server_status() B C<< {job_server => {job => {capable, queued, running}}} >> =cut sub get_job_server_status { my $self = shift; my $js_status = {}; $self->_job_server_status_command( "status\n", sub { my ($js, $line) = @_; unless ($line =~ /^(\S+)\s+(\d+)\s+(\d+)\s+(\d+)$/) { return; } my ($job, $queued, $running, $capable) = ($1, $2, $3, $4); $js_status->{ $self->_js_str($js) }->{$job} = { queued => $queued, running => $running, capable => $capable, }; }, @_ ); return $js_status; } ## end sub get_job_server_status =head2 get_job_server_jobs() supported only by L B C<< {job-server => {job => {address, listeners, key}}} >> =cut sub get_job_server_jobs { my $self = shift; my $js_jobs = {}; $self->_job_server_status_command( "jobs\n", sub { my ($js, $line) = @_; # Yes, the unique key is sometimes omitted. return unless $line =~ /^(\S+)\s+(\S*)\s+(\S+)\s+(\d+)$/; my ($job, $key, $address, $listeners) = ($1, $2, $3, $4); $js_jobs->{ $self->_js_str($js) }->{$job} = { key => $key, address => $address, listeners => $listeners, }; }, @_ ); return $js_jobs; } ## end sub get_job_server_jobs =head2 get_job_server_clients() supported only by L =cut sub get_job_server_clients { my $self = shift; my $js_clients = {}; my $client; $self->_job_server_status_command( "clients\n", sub { my ($js, $line) = @_; my $js_str = $self->_js_str($js); if ($line =~ /^(\S+)$/) { $client = $1; $js_clients->{$js_str}->{$client} ||= {}; } elsif ($client && $line =~ /^\s+(\S+)\s+(\S*)\s+(\S+)$/) { my ($job, $key, $address) = ($1, $2, $3); $js_clients->{$js_str}->{$client}->{$job} = { key => $key, address => $address, }; } ## end elsif ($client && $line =~...) }, @_ ); return $js_clients; } ## end sub get_job_server_clients # # _get_task_from_args # sub _get_task_from_args { my $self = shift; my $task; if (ref $_[0]) { $task = shift; $task->isa("Gearman::Task") || Carp::croak("Argument isn't a Gearman::Task"); } else { my $func = shift; my $arg_p = shift; my $opts = shift; 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); } ## end else [ if (ref $_[0]) ] return $task; } ## end sub _get_task_from_args =head2 do_task($task) =head2 do_task($funcname, $arg, \%options) Dispatches a task and waits on the results. May either provide a L object, or the 3 arguments that the L constructor takes. B scalarref of WORK_COMPLETE result, or undef on failure. =cut sub do_task { my $self = shift; my $task = $self->_get_task_from_args(@_); my ($ret, $sub) = (undef, $task->{on_complete}); $task->{on_complete} = sub { ($ret) = @_; $sub && $sub->(@_); }; my $ts = $self->new_task_set; $ts->add_task($task); $ts->wait(timeout => $task->timeout); return $ret; } ## end sub do_task =head2 dispatch_background($func, $arg_p, $options_hr) =head2 dispatch_background($task) Dispatches a C and doesn't wait for the result. Return value is an opaque scalar that can be used to refer to the task with L. B L C B