Gearman-1.130.004/000755 001751 001751 00000000000 12751342315 013641 5ustar00palikpalik000000 000000 Gearman-1.130.004/lib/000755 001751 001751 00000000000 12751342315 014407 5ustar00palikpalik000000 000000 Gearman-1.130.004/README000644 001751 001751 00000001511 12747735711 014532 0ustar00palikpalik000000 000000 Gearman client, task and worker implementation for perl Gearman::Client - Client for gearman distributed job system Gearman::Task - a task in Gearman, from the point of view of a client Gearman::Worker - Worker for gearman distributed job system INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Log::Log4perl::Appender::Elasticsearch perldoc Log::Log4perl::Appender::Elasticsearch::Bulk perldoc Gearman::Client perldoc Gearman::Task perldoc Gearman::Worker LICENSE AND COPYRIGHT Copyright 2006-2007 Six Apart, Ltd. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Gearman-1.130.004/t/000755 001751 001751 00000000000 12751342315 014104 5ustar00palikpalik000000 000000 Gearman-1.130.004/META.json000644 001751 001751 00000003155 12751342315 015266 0ustar00palikpalik000000 000000 { "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 6.98, CPAN::Meta::Converter version 2.150005", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Gearman", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "IO::Socket::INET" : "0", "Perl::OSType" : "0", "Storable" : "0", "Test::Exception" : "0", "Test::More" : "0", "Test::Timer" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "IO::Handle" : "0", "IO::Socket::INET" : "0", "POSIX" : "0", "Scalar::Util" : "0", "Socket" : "0", "Storable" : "1", "String::CRC32" : "0", "Time::HiRes" : "0", "fields" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/p-alik/perl-Gearman.git", "web" : "https://github.com/p-alik/perl-Gearman" } }, "version" : "v1.130.4", "x_serialization_backend" : "JSON::PP version 2.27203" } Gearman-1.130.004/MANIFEST000644 001751 001751 00000001514 12751342315 014773 0ustar00palikpalik000000 000000 CHANGES lib/Gearman/Client.pm lib/Gearman/Job.pm lib/Gearman/JobStatus.pm lib/Gearman/Objects.pm lib/Gearman/ResponseParser.pm lib/Gearman/ResponseParser/Taskset.pm lib/Gearman/Task.pm lib/Gearman/Taskset.pm lib/Gearman/Util.pm lib/Gearman/Worker.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP This list of files t/00-use.t t/01-object.t t/02-client.t t/03-worker.t t/04-task.t t/05-taskset.t t/06-response-parser.t t/07-response-parser-taskset.t t/08-jobstatus.t t/09-connect.t t/10-all.t t/11-job.t t/12-util.t t/20-leaktest.t t/30-maxqueue.t t/40-prefix.t t/50-wait_timeout.t t/60-stop-if.t t/65-responseparser.t t/worker.pl t/lib/Test/Gearman.pm README TODO META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Gearman-1.130.004/MANIFEST.SKIP000644 001751 001751 00000000647 12731256165 015553 0ustar00palikpalik000000 000000 # Avoid version control files. \bRCS\b \bCVS\b ,v$ \B\.svn\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib$ # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# # Avoid debian directory, and rpm specfiles. \bdebian\b \.spec$ # Don't put the shipit file in distros ^\.shipit$ build.pl Gearman-1.130.004/Makefile.PL000644 001751 001751 00000002523 12751072357 015623 0ustar00palikpalik000000 000000 use 5.008; use strict; use warnings; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => "Gearman", AUTHOR => 'Brad Fitzpatrick ', ABSTRACT => "Client and worker libraries for gearman job dispatch dispatch. Server is in separate package.", VERSION_FROM => "lib/Gearman/Client.pm", BUILD_REQUIRES => { "IO::Socket::INET" => 0, "Perl::OSType" => 0, "Storable" => 0, "Test::Exception" => 0, "Test::More" => 0, "Test::Timer" => 0, }, PREREQ_PM => { "Carp" => 0, "POSIX" => 0, "IO::Handle" => 0, "IO::Socket::INET" => 0, "Scalar::Util" => 0, "Socket" => 0, "Storable" => 1, "String::CRC32" => 0, "Time::HiRes" => 0, # Usually core now "fields" => 0, }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'https://github.com/p-alik/perl-Gearman.git', web => 'https://github.com/p-alik/perl-Gearman', }, }, }, ); 1; Gearman-1.130.004/CHANGES000644 001751 001751 00000017657 12751341160 014651 0ustar00palikpalik000000 000000 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-1.130.004/META.yml000644 001751 001751 00000001650 12751342315 015114 0ustar00palikpalik000000 000000 --- abstract: 'Client and worker libraries for gearman job dispatch dispatch. Server is in separate package.' author: - 'Brad Fitzpatrick ' build_requires: IO::Socket::INET: '0' Perl::OSType: '0' Storable: '0' Test::Exception: '0' Test::More: '0' Test::Timer: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.150005' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Gearman no_index: directory: - t - inc requires: Carp: '0' IO::Handle: '0' IO::Socket::INET: '0' POSIX: '0' Scalar::Util: '0' Socket: '0' Storable: '1' String::CRC32: '0' Time::HiRes: '0' fields: '0' resources: repository: https://github.com/p-alik/perl-Gearman.git version: v1.130.4 x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Gearman-1.130.004/TODO000644 001751 001751 00000000213 12731256165 014332 0ustar00palikpalik000000 000000 * deal with jobservers timing out (going off net) in the middle of workers doing work and submitting a job, status, grabbing a job, etc Gearman-1.130.004/t/07-response-parser-taskset.t000644 001751 001751 00000001216 12751340667 021331 0ustar00palikpalik000000 000000 use 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-1.130.004/t/lib/000755 001751 001751 00000000000 12751342315 014652 5ustar00palikpalik000000 000000 Gearman-1.130.004/t/50-wait_timeout.t000644 001751 001751 00000004475 12751340667 017247 0ustar00palikpalik000000 000000 use strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server use FindBin qw/$Bin/; use Gearman::Client; use Test::More; use Test::Timer; use lib "$Bin/lib"; use Test::Gearman; my $tg = Test::Gearman->new( ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); $tg->start_servers() || plan skip_all => "Can't find server to test with"; ($tg->check_server_connection(@{ $tg->job_servers }[0])) || plan skip_all => "connection check $_ failed"; plan tests => 3; $tg->start_worker(); my $client = new_ok("Gearman::Client", [job_servers => $tg->job_servers()]); subtest "wait with timeout", sub { 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("long", $iter, $opt), "add_task('long', $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 "long args", sub { my $tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); my $arg = 'x' x (5 * 1024 * 1024); $tasks->add_task( "long", \$arg, { on_complete => sub { my $rr = shift; if (length($$rr) != length($arg)) { fail( "Large job failed size check: got " . length($$rr) . ", want " . length($arg)); } ## end if (length($$rr) != length...) elsif ($$rr ne $arg) { fail("Large job failed content check"); } else { pass("Large job succeeded"); } }, on_fail => sub { fail("Large job failed"); }, } ); my $to = 10; time_ok(sub { $tasks->wait(timeout => $to) }, $to, "timeout"); }; Gearman-1.130.004/t/05-taskset.t000644 001751 001751 00000013121 12751340667 016177 0ustar00palikpalik000000 000000 use strict; use warnings; use FindBin qw/ $Bin /; use IO::Socket::INET; use Test::More; use Test::Exception; use lib "$Bin/lib"; use Test::Gearman; my $tg = Test::Gearman->new( count => 3, ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); my @js = $tg->start_servers() ? @{ $tg->job_servers } : (); my $mn = "Gearman::Taskset"; use_ok($mn); use_ok("Gearman::Client"); 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("Gearman::Client", [job_servers => [@js]]); my $ts = new_ok($mn, [$c]); is($ts->{cancelled}, 0); is(ref($ts->{hooks}), "HASH"); is(ref($ts->{loaned_sock}), "HASH"); is(ref($ts->{need_handle}), "ARRAY"); is(ref($ts->{waiting}), "HASH"); is($ts->client, $c, "client"); throws_ok { $mn->new('a') } qr/^provided client argument is not a Gearman::Client reference/, "caught die off on client argument check"; subtest "hook", sub { my $cb = sub { 2 * shift }; my $h = "ahook"; ok($ts->add_hook($h, $cb)); is($ts->{hooks}->{$h}, $cb); $ts->run_hook($h, 2); ok($ts->add_hook($h)); is($ts->{hooks}->{$h}, undef); }; subtest "cancel", sub { is($ts->{cancelled}, 0); # just in order to test close in cancel sub $ts->{default_sock} = IO::Socket::INET->new(); $ts->{loaned_sock}->{x} = IO::Socket::INET->new(); $ts->cancel(); is($ts->{cancelled}, 1); is($ts->{default_sock}, undef); is(keys(%{ $ts->{waiting} }), 0); is(@{ $ts->{need_handle} }, 0); is($ts->{client}, undef); delete $ts->{loaned_sock}->{x}; }; subtest "socket", sub { $ts->{client} = new_ok("Gearman::Client"); is($ts->_get_hashed_sock(0), undef); $ts->{client} = new_ok("Gearman::Client", [job_servers => [@js]]); 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::INET"); is($ts->_get_hashed_sock($i), $ls, "_get_hashed_sock($i) = _get_loaned_sock($js[$i])"); } ## end for (my $i = 0; $i < scalar...) if (scalar(@js)) { ok($ts->_get_default_sock(), "_get_default_sock"); ok($ts->_ip_port($ts->_get_default_sock())); } else { # undef is($ts->_get_default_sock(), undef, "_get_default_sock"); is($ts->_ip_port($ts->_get_default_sock()), undef); } }; subtest "task", sub { throws_ok { $ts->_fail_jshandle() } qr/called without shandle/, "caught _fail_jshandle() without shandle"; throws_ok { $ts->_fail_jshandle('x') } 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"; my $f = "foo"; $ts->{need_handle} = []; $ts->{client} = new_ok("Gearman::Client", [job_servers => [@js]]); if (!@js) { is($ts->add_task($f), undef, "add_task($f) returns undef"); } else { ok($ts->add_task($f), "add_task($f) returns handle"); is(scalar(@{ $ts->{need_handle} }), 0); #TODO timeout test is($ts->_wait_for_packet($ts->_get_default_sock(), 1), 0, "_wait_for_packet"); } ## end else [ if (!@js) ] # is($ts->add_task(qw/a b/), undef, "add_task returns undef"); }; subtest "process_packet", sub { my $f = "foo"; my $h = "H:localhost:12345"; $ts->{need_handle} = []; $ts->{client} = new_ok("Gearman::Client", [job_servers => [@js]]); my $r = { type => "job_created", blobref => \$h }; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/unexpected job_created/, "job_created exception"; $ts->{need_handle} = [$ts->client()->_get_task_from_args($f)]; dies_ok { $ts->process_packet($r, $ts->_get_default_sock()) } "process_packet dies"; $r->{type} = "work_fail"; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/work_fail for unknown handle/, "caught process_packet({type => work_fail})"; $r->{type} = "work_complete"; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/Bogus work_complete from server/, "caught process_packet({type => work_complete})"; $r->{blobref} = \join "\0", $h, "abc"; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/got work_complete for unknown handle/, "caught process_packet({type => work_complete}) unknown handle"; $r = { type => "work_exception", blobref => \$h }; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/Bogus work_exception from server/, "caught process_packet({type => work_exception})"; $r->{blobref} = \join "\0", ${ $r->{blobref} }, "abc"; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/got work_exception for unknown handle/, "caught process_packet({type => work_exception}) unknown handle"; $r = { type => "work_status", blobref => \$h }; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/got work_status for unknown handle/, "caught process_packet({type => work_status}) unknown handle"; $r->{type} = $f; throws_ok { $ts->process_packet($r, $ts->_get_default_sock()) } qr/unimplemented packet type/, "caught process_packet({type => $f }) unknown handle"; }; done_testing(); Gearman-1.130.004/t/worker.pl000755 001751 001751 00000004253 12747735711 015774 0ustar00palikpalik000000 000000 #!/usr/bin/env perl use strict; use warnings; use lib 'lib'; use Gearman::Worker; use Storable qw(thaw nfreeze); use Getopt::Long qw( GetOptions ); GetOptions( 's|servers=s' => \(my $servers), 'n=i' => \(my $notifypid), 'p=s' => \(my $prefix), ); die "usage: $0 -s " unless $servers; my @servers = split /,/, $servers; my $worker = Gearman::Worker->new($prefix ? (prefix => $prefix) : ()); $worker->job_servers(@servers); $worker->register_function( sum => sub { my $sum = 0; $sum += $_ for @{ thaw($_[0]->arg) }; $sum; } ); $worker->register_function(fail => sub {undef}); $worker->register_function(fail_die => sub { die 'test reason' }); $worker->register_function(fail_exit => sub { exit 255 }); $worker->register_function(sleep => sub { sleep $_[0]->arg }); $worker->register_function( sleep_three => 3 => sub { my ($sleep, $return) = $_[0]->arg =~ m/^(\d+)(?::(.+))?$/; sleep $sleep; return $return; } ); $worker->register_function( echo_ws => sub { select undef, undef, undef, 0.25; $_[0]->arg eq 'x' ? undef : $_[0]->arg; } ); $worker->register_function( echo_prefix => sub { join " from ", $_[0]->arg, $prefix; } ); $worker->register_function( echo_sleep => sub { my ($job) = @_; $job->set_status(1, 1); sleep 2; ## allow some time to read the status join " from ", $_[0]->arg, $prefix; } ); $worker->register_function( long => sub { my ($job) = @_; $job->set_status(50, 100); sleep 2; $job->set_status(100, 100); sleep 2; return $job->arg; } ); my $nsig; $nsig = kill 'USR1', $notifypid if $notifypid; my $work_exit = 0; $worker->register_function( work_exit => sub { $work_exit = 1; } ); my ($is_idle, $last_job_time); $worker->register_function( check_stop_if => sub { return nfreeze([$is_idle, $last_job_time]); } ); my $stop_if = sub { ($is_idle, $last_job_time) = @_; if ($work_exit) { $work_exit = 0; return 1; } return 0; }; $worker->work(stop_if => $stop_if) while (1); Gearman-1.130.004/t/30-maxqueue.t000644 001751 001751 00000003456 12751340667 016363 0ustar00palikpalik000000 000000 use strict; use warnings; use FindBin qw/ $Bin /; use Gearman::Client; use Storable qw( freeze ); use Test::More; use lib "$Bin/lib"; use Test::Gearman; # NOK tested with gearman v1.0.6 # OK Gearman::Server plan skip_all => "MAXQUEUE test is in TODO"; # This is testing the MAXQUEUE feature of gearmand. There's no direct # support for it in Gearman::Worker yet, so we connect directly to # gearmand to configure it for the test. my $tg = Test::Gearman->new( ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); $tg->start_servers() || plan skip_all => "Can't find server to test with"; foreach (@{ $tg->job_servers }) { unless ($tg->check_server_connection($_)) { plan skip_all => "connection check $_ failed"; last; } } ## end foreach (@{ $tg->job_servers...}) plan tests => 9; ok( my $sock = IO::Socket::INET->new( PeerAddr => @{ $tg->job_servers }[0], ), "connect to jobserver" ); my $cn = "long"; ok($sock->write("MAXQUEUE $cn 1\n"), "write MAXQUEUE ..."); ok(my $input = $sock->getline(), "getline"); ok($input =~ m/^OK\b/i, "match OK"); ok(my $pid = $tg->start_worker(), "start worker"); my $client = new_ok("Gearman::Client", [job_servers => $tg->job_servers]); my $tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); my $failed = 0; my $completed = 0; foreach my $iter (1 .. 5) { my $handle = $tasks->add_task( $cn, $iter, { on_complete => sub { $completed++ }, on_fail => sub { $failed++ } } ); } ## end foreach my $iter (1 .. 5) $tasks->wait; # One in the queue, plus one that may start immediately ok($completed == 2 || $completed == 1, 'number of success'); # All the rest ok($failed == 3 || $failed == 4, 'number of failure'); warn join " ", $failed, $completed; Gearman-1.130.004/t/09-connect.t000644 001751 001751 00000006477 12751340667 016176 0ustar00palikpalik000000 000000 use strict; use warnings; use Gearman::Client; use IO::Socket::INET; use Test::More; use Time::HiRes; plan skip_all => "$0 fails sometimes"; 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::INET->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-1.130.004/t/60-stop-if.t000644 001751 001751 00000004637 12751340667 016117 0ustar00palikpalik000000 000000 use strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server use FindBin qw/ $Bin /; use Gearman::Client; use Storable qw(thaw); use Test::More; use lib "$Bin/lib"; use Test::Gearman; my $tg = Test::Gearman->new( ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); $tg->start_servers() || plan skip_all => "Can't find server to test with"; ($tg->check_server_connection(@{ $tg->job_servers }[0])) || plan skip_all => "connection check $_ failed"; plan tests => 5; my $client = new_ok("Gearman::Client", [job_servers => $tg->job_servers()]); $tg->start_worker(); subtest "stop if subtest 1", sub { # If we start up too fast, then the worker hasn't gone 'idle' yet. sleep 1; my $result = $client->do_task('check_stop_if'); my ($is_idle, $last_job_time) = @{ thaw($$result) }; is($is_idle, 0, "We shouldn't be idle yet"); is($last_job_time, undef, "No job should have been processed yet"); }; subtest "stop if subtest 2", sub { my $result = $client->do_task('check_stop_if'); my ($is_idle, $last_job_time) = @{ thaw($$result) }; is($is_idle, 0, "We still shouldn't be idle yet"); isnt($last_job_time, undef, "We should have processed a job now"); my $time_diff = time() - $last_job_time; # On a really slow system this test could fail, maybe. ok($time_diff < 3, "That last job should have been within the last 3 seconds"); }; subtest "stop if subtest 3", sub { note "Sleeping for 5 seconds"; sleep 5; my $result = $client->do_task('check_stop_if'); my ($is_idle, $last_job_time) = @{ thaw($$result) }; is($is_idle, 0, "We still shouldn't be idle yet"); isnt($last_job_time, undef, "We should have processed a job now"); my $time_diff = time() - $last_job_time; # On a really slow system this test could fail, maybe. ok($time_diff > 3, "That last job should have been more than 3 seconds ago"); ok($time_diff < 8, "That last job should have been less than 8 seconds ago"); }; subtest "stop if subtest 4", sub { $client->do_task('work_exit'); # make sure the worker has time to shut down and isn't still in the 'run' loop sleep 2; my $result = $client->do_task('check_stop_if'); my ($is_idle, $last_job_time) = @{ thaw($$result) }; is($is_idle, 0, "We shouldn't be idle yet"); is($last_job_time, undef, "No job should have been processed yet"); }; Gearman-1.130.004/t/06-response-parser.t000644 001751 001751 00000001457 12751340667 017663 0ustar00palikpalik000000 000000 use 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-1.130.004/t/20-leaktest.t000644 001751 001751 00000003746 12751340667 016346 0ustar00palikpalik000000 000000 use strict; use warnings; our $Bin; use FindBin qw( $Bin ); use Gearman::Client; use Storable qw( freeze ); use Test::More; use IO::Socket::INET; use POSIX qw( :sys_wait_h ); use List::Util qw(first); use lib "$Bin/lib"; use Test::Gearman; plan skip_all => "$0 in TODO"; if (!eval "use Devel::Gladiator; 1;") { plan skip_all => "This test requires Devel::Gladiator"; exit 0; } my $tg = Test::Gearman->new( ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); $tg->is_perl_daemon() || plan skip_all => "test cases supported only by Gearman::Server"; $tg->start_servers() || plan skip_all => "Can't find server to test with"; ($tg->check_server_connection(@{ $tg->job_servers }[0])) || plan skip_all => "connection check $_ failed"; plan tests => 7; my $client = new_ok("Gearman::Client", [job_servers => $tg->job_servers()]); my $tasks = $client->new_task_set; ok( my $handle = $tasks->add_task( dummy => 'xxxx', { on_complete => sub { die "shouldn't complete"; }, on_fail => sub { warn "Failed...\n"; } } ), "got handle" ); ok(my $sock = IO::Socket::INET->new(PeerAddr => @{ $tg->job_servers }[0]), "got raw connection"); my $num = sub { my $what = shift; my $n = 0; print $sock "gladiator all\r\n"; while (<$sock>) { print $_; last if /^\./; /(\d+)\s$what/ or next; $n = $1; } return $n; }; is($num->("Gearman::Server::Client"), 2, "2 clients connected (debug and caller)"); my $num_inets = $num->("IO::Socket::INET"); # a server change made this change from 3 to 4... so accept either. just make # sure it decreases by one later... ok($num_inets == 3 || $num_inets == 4, "3 or 4 sockets (clients + listen) (got $num_inets)"); $tasks->cancel; sleep(0.10); my $num_inets2 = $num->("IO::Socket::INET"); is($num_inets2, $num_inets - 1, "2 sockets (client + listen)"); is($num->("Gearman::Server::Client"), 1, "1 client connected (debug)"); Gearman-1.130.004/t/12-util.t000644 001751 001751 00000004401 12751340667 015475 0ustar00palikpalik000000 000000 use strict; use warnings; use Test::More; use Test::Exception; use IO::Socket::INET; 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), 27); 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::INET->new(), \my $e), undef); is($e, "eof"); }; subtest "send_req", sub { is(&{"$mn\:\:send_req"}(IO::Socket::INET->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-1.130.004/t/40-prefix.t000644 001751 001751 00000005703 12751340667 016024 0ustar00palikpalik000000 000000 use strict; use warnings; # OK gearmand v1.0.6 # NOK Gearman::Server # use FindBin qw/$Bin/; use Gearman::Client; use Storable qw/freeze/; use Test::More; use Time::HiRes qw/sleep/; use lib "$Bin/lib"; use Test::Gearman; my $tg = Test::Gearman->new( count => 3, ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); $tg->start_servers() || plan skip_all => "Can't find server to test with"; foreach (@{ $tg->job_servers }) { unless ($tg->check_server_connection($_)) { plan skip_all => "connection check $_ failed"; last; } } ## end foreach (@{ $tg->job_servers...}) plan tests => 5; my @worker_pids; foreach (qw/a b/) { my $pid = $tg->start_worker({ prefix => join('_', "prefix", $_) }); $pid || die "coundn't start worker"; push @worker_pids, $pid; } my $client_a = new_ok("Gearman::Client", [prefix => "prefix_a", job_servers => $tg->job_servers]); my $client_b = new_ok("Gearman::Client", [prefix => "prefix_b", job_servers => $tg->job_servers]); # basic do_task test subtest "basic do task", sub { is( ${ $client_a->do_task('echo_prefix', 'beep test') }, 'beep test from prefix_a', 'basic do_task() - prefix a' ); is( ${ $client_b->do_task('echo_prefix', 'beep test') }, 'beep test from prefix_b', 'basic do_task() - prefix b' ); is( ${ $client_a->do_task( Gearman::Task->new('echo_prefix', \('beep test')) ) }, 'beep test from prefix_a', 'Gearman::Task do_task() - prefix a' ); is( ${ $client_b->do_task( Gearman::Task->new('echo_prefix', \('beep test')) ) }, 'beep test from prefix_b', 'Gearman::Task do_task() - prefix b' ); }; subtest "echo prefix", sub { my %out; my %tasks = ( a => $client_a->new_task_set, b => $client_b->new_task_set, ); 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 $bg_task = new_ok("Gearman::Task", ['echo_sleep', \('sleep prefix test')]); ok(my $handle = $client_a->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_a->get_status($handle); } until $status->percent == 1 or $n == 20; is($status->percent, 1, "Background task completed using prefix"); }; Gearman-1.130.004/t/65-responseparser.t000644 001751 001751 00000003756 12751340667 017617 0ustar00palikpalik000000 000000 use strict; use warnings; use Test::More tests => 9; use Gearman::Client; our $last_packet = undef; our @packets; my $parser = Gearman::ResponseParser::Test->new(); test_packet("\0RES\0\0\0\x0a\0\0\0\x01!", { len => 1, blobref => \"!", #" type => 'no_job', }); test_packet("\0RES\0\0\0\x0a\0\0\0\0", { len => 0, blobref => \"", #" type => 'no_job', }); ## multiple packets my $pkt = "\0RES\0\0\0\x0a\0\0\0\0"; test_multi_packet("$pkt$pkt", { len => 0, blobref => \"", #" type => 'no_job', }, { len => 0, blobref => \"", #" type => 'no_job', }); # Message split into two packets test_packet("\0RE", undef); test_packet("S\0\0\0\x0a\0\0\0\0", { len => 0, blobref => \"", #" type => 'no_job', }); # Message with payload split into two packets test_packet("\0RES\0\0\0\x0a\0\0\0\x02a", undef); test_packet("b", { len => 2, blobref => \"ab", #" type => 'no_job', }); # Two packets, with the first containing a full message # and a partial message, and the second containing the # remainder of the partial message. test_packet("\0RES\0\0\0\x0a\0\0\0\x02ab\0RES\0\0\0\x0a\0\0\0\x02b", { len => 2, blobref => \"ab", #" type => 'no_job', }); test_packet("a", { len => 2, blobref => \"ba", #" type => 'no_job', }); sub test_packet { my ($data, $expected) = @_; my $test_name = "Parsing ".enc($data); $last_packet = undef; $parser->parse_data(\$data); is_deeply($last_packet, $expected, $test_name); } sub test_multi_packet { my ($data, @expected) = @_; my $test_name = "Parsing ".enc($data); @packets = (); $parser->parse_data(\$data); is_deeply(\@packets, \@expected, $test_name); } sub enc { my $data = $_[0]; $data =~ s/([\W])/"%" . uc(sprintf("%2.2x",ord($1)))/eg; return $data; } package Gearman::ResponseParser::Test; use Gearman::ResponseParser; use base qw(Gearman::ResponseParser); sub on_packet { $main::last_packet = $_[1]; push @main::packets, $_[1]; } Gearman-1.130.004/t/11-job.t000644 001751 001751 00000000727 12751340667 015300 0ustar00palikpalik000000 000000 use 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 = qw/ foo 2 123.321.1.1:123 bar /; $arg[1] = \$arg[1]; my $j = new_ok($mn, [@arg]); is($j->handle(), $arg[2]); is($j->argref(), $arg[1]); is($j->arg(), ${ $arg[1] }); dies_ok { $j->set_status(qw/a b/) }; done_testing(); Gearman-1.130.004/t/02-client.t000644 001751 001751 00000003720 12751340667 016000 0ustar00palikpalik000000 000000 use strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server use FindBin qw/ $Bin /; use Test::More; use Test::Exception; use lib "$Bin/lib"; use Test::Gearman; my $tg = Test::Gearman->new( count => 3, ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); my $mn = "Gearman::Client"; my @js = $tg->start_servers() ? @{ $tg->job_servers } : (); use_ok($mn); can_ok( $mn, qw/ _get_js_sock _get_random_js_sock _get_task_from_args _job_server_status_command _option_request _put_js_sock 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 / ); my $c = new_ok($mn, [job_servers => [@js]]); 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}, scalar(@js), "js_count"); is(keys(%{ $c->{hooks} }), 0, join "->", $mn, "{hooks}"); is(keys(%{ $c->{sock_cache} }), 0, join "->", $mn, "{sock_cache}"); foreach ($c->job_servers()) { ok(my $s = $c->_get_js_sock($_), "_get_js_sock($_)"); isa_ok($s, "IO::Socket::INET"); } my ($tn, $args, $timeout) = qw/ foo bar 2 /; subtest "new_task_set", sub { 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 "_get_random_js_sock", sub { if (@{ $c->job_servers() }) { ok(my @r = $c->_get_random_js_sock()); note explain @r; } else { is($c->_get_random_js_sock(), undef); } }; done_testing(); Gearman-1.130.004/t/04-task.t000644 001751 001751 00000007141 12751340667 015467 0ustar00palikpalik000000 000000 use strict; use warnings; use Storable; use Test::More; use Test::Exception; use_ok("Gearman::Client"); use_ok("Gearman::Taskset"); my $mn = "Gearman::Task"; use_ok($mn); can_ok( $mn, qw/ add_hook complete exception fail final_fail func handle hash is_finished mode pack_submit_packet run_hook set_on_post_hooks status taskset timeout 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, high_priority => 1, 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 "mode", sub { $t->{background} = undef; $t->{high_priority} = 0; is($t->mode, "submit_job", "submit_job"); $t->{high_priority} = 1; is($t->mode, "submit_job_high", "submit_job_high"); is($t->{background} = 1, 1, "background"); is($t->mode, "submit_job_high_bg", "submit_job_high_bg"); $t->{high_priority} = 0; is($t->mode, "submit_job_bg", "submit_job_bg"); ok($t->pack_submit_packet(new_ok("Gearman::Client", [prefix => $f])), "pack_submit_packet"); }; my @h = qw/ on_post_hooks on_complete on_fail on_retry on_status hooks /; subtest "wipe", sub { $t->{$_} = 1 for @h; $t->wipe(); is($t->{$_}, undef, $_) for @h; }; subtest "hook", sub { 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 { 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 { $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 { my $exc = Storable::freeze(\$f); $t->{on_exception} = sub { is(shift, $f) }; is($t->exception(\$exc), undef); pass("x"); }; subtest "complete", sub { $t->{is_finished} = undef; $t->{on_complete} = sub { is(shift, $f) }; $t->complete($f); is($t->{is_finished}, "complete"); }; subtest "status", sub { $t->{is_finished} = undef; $t->{on_status} = sub { is(shift, $f), is(shift, $arg) }; $t->status($f, $arg); }; subtest "handle", sub { ok($t->handle($f)); is($t->{handle}, $f); }; done_testing(); Gearman-1.130.004/t/08-jobstatus.t000644 001751 001751 00000001560 12751340667 016546 0ustar00palikpalik000000 000000 use 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-1.130.004/t/00-use.t000644 001751 001751 00000000760 12751340667 015315 0ustar00palikpalik000000 000000 use 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 = qv("1.130.004"); 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-1.130.004/t/10-all.t000644 001751 001751 00000027412 12751340667 015275 0ustar00palikpalik000000 000000 use strict; use warnings; # OK gearmand v1.0.6 # NOK Gearman::Server use FindBin qw/ $Bin /; use Gearman::Client; use List::Util; use Storable qw( freeze ); use Test::More; use Test::Exception; use Test::Timer; use lib "$Bin/lib"; use Test::Gearman; my $tg = Test::Gearman->new( count => 3, ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); $tg->start_servers() || plan skip_all => "Can't find server to test with"; foreach (@{ $tg->job_servers }) { unless ($tg->check_server_connection($_)) { plan skip_all => "connection check $_ failed"; last; } } ## end foreach (@{ $tg->job_servers...}) my $client = new_ok("Gearman::Client", [exceptions => 1, job_servers => $tg->job_servers]); ## Start two workers, look for job servers my @worker_pids; for (0 .. 1) { my $pid = $tg->start_worker(); $pid || die "coundn't start worker"; push @worker_pids, $pid; } subtest "taskset 1", sub { throws_ok { $client->do_task(sum => []) } qr/Function argument must be scalar or scalarref/, 'do_task does not accept arrayref argument'; my $out = $client->do_task(sum => freeze([3, 5])); is($$out, 8, 'do_task returned 8 for sum'); my $tasks = $client->new_task_set; isa_ok($tasks, 'Gearman::Taskset'); my $sum; my $failed = 0; my $completed = 0; my $handle = $tasks->add_task( sum => freeze([3, 5]), { on_complete => sub { $sum = ${ $_[0] } }, on_fail => sub { $failed = 1 } } ); $tasks->wait; is($sum, 8, 'add_task/wait returned 8 for sum'); is($failed, 0, 'on_fail not called on a successful result'); }; ## Now try a task set with 2 tasks, and make sure they are both completed. subtest "taskset 2", sub { my $tasks = $client->new_task_set; my @sums; $tasks->add_task( sum => freeze([1, 1]), { on_complete => sub { $sums[0] = ${ $_[0] } }, } ); $tasks->add_task( sum => freeze([2, 2]), { on_complete => sub { $sums[1] = ${ $_[0] } }, } ); $tasks->wait; is($sums[0], 2, 'First task completed (sum is 2)'); is($sums[1], 4, 'Second task completed (sum is 4)'); }; ## Test some failure conditions: ## Normal failure (worker returns undef or dies within eval). subtest "failures", sub { is($client->do_task('fail'), undef, 'Job that failed naturally returned undef'); # the die message is available in the on_fail sub my $msg = undef; my $tasks = $client->new_task_set; $tasks->add_task('fail_die', undef, { on_exception => sub { $msg = shift }, }); $tasks->wait; like( $msg, qr/test reason/, 'the die message is available in the on_fail sub' ); $tasks = $client->new_task_set; my ($completed, $failed) = (0, 0); $tasks->add_task( fail => '', { on_complete => sub { $completed = 1 }, on_fail => sub { $failed = 1 }, } ); $tasks->wait; is($completed, 0, 'on_complete not called on failed result'); is($failed, 1, 'on_fail called on failed result'); ## Test retry_count. my $retried = 0; is( $client->do_task( 'fail' => '', { on_retry => sub { $retried++ }, retry_count => 3, } ), undef, 'Failure response is still failure, even after retrying' ); is($retried, 3, 'Retried 3 times'); }; ## Worker process exits. subtest "worker process exits", sub { $tg->is_perl_daemon() || plan skip_all => "supported only by Gearman::Server"; is( $client->do_task( 'fail_exit', 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' ); my $pid = wait(); if (my $npid = $tg->pid_is_dead($pid)) { my $idx = List::Util::first { $worker_pids[$_] eq $pid } 0 .. $#worker_pids; $worker_pids[$idx] = $npid; } }; #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", sub { # my $to = 3; # time_ok(sub { $client->do_task('sleep', 5, { timeout => $to }) }, # $to, "Job that timed out after $to seconds returns failure"); # }; ## Test sleeping less than the timeout subtest "sleeping", sub { is(${ $client->do_task('sleep_three', '1:less') }, 'less', 'We took less time than the worker timeout'); # Do it three more times to check that 'uniq' (implied '-') # works okay. 3 more because we need to go past the timeout. is(${ $client->do_task('sleep_three', '1:one') }, 'one', 'We took less time than the worker timeout, again'); is(${ $client->do_task('sleep_three', '1:two') }, 'two', 'We took less time than the worker timeout, again'); is(${ $client->do_task('sleep_three', '1:three') }, 'three', 'We took less time than the worker timeout, again'); # Now test if we sleep longer than the timeout is($client->do_task('sleep_three', 5), undef, 'We took more time than the worker timeout'); # This task and the next one would be hashed with uniq onto the # previous task, except it failed, so make sure it doesn't happen. is($client->do_task('sleep_three', 5), undef, 'We took more time than the worker timeout, again'); is($client->do_task('sleep_three', 5), undef, 'We took more time than the worker timeout, again, again'); }; ## Check hashing on success, first job sends in 'a' for argument, second job ## should complete and return 'a' to the callback. 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 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 "fail", sub { # my $tasks = $client->new_task_set; # $tasks->add_task( # 'sleep_three', # '10:a', # { # uniq => 'something', # on_complete => sub { fail("This can't happen!") }, # on_fail => sub { pass("We failed properly!") }, # } # ); # sleep 5; # $tasks->add_task( # 'sleep_three', # '10:b', # { # uniq => 'something', # on_complete => sub { fail("This can't happen!") }, # on_fail => sub { pass("We failed properly again!") }, # } # ); # $tasks->wait; # }; ## Test 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 { for (my $i = 1; $i <= $#worker_pids; $i++) { $tg->stop_worker($worker_pids[$i]); } my $tasks = $client->new_task_set; my $out = ''; $tasks->add_task( echo_ws => 1, { on_complete => sub { $out .= ${ $_[0] } } } ); $tasks->add_task( echo_ws => 2, { on_complete => sub { $out .= ${ $_[0] } } } ); $tasks->add_task( echo_ws => 'x', { on_fail => sub { $tasks->add_task( echo_ws => 'p', { on_complete => sub { $out .= ${ $_[0] }; }, high_priority => 1 } ); }, } ); $tasks->add_task( echo_ws => 3, { on_complete => sub { $out .= ${ $_[0] } } } ); $tasks->add_task( echo_ws => 4, { on_complete => sub { $out .= ${ $_[0] } } } ); $tasks->add_task( echo_ws => 5, { on_complete => sub { $out .= ${ $_[0] } } } ); $tasks->add_task( echo_ws => 6, { on_complete => sub { $out .= ${ $_[0] } } } ); $tasks->wait; like($out, qr/p.+6/, 'High priority tasks executed in priority order.'); # We just killed off all but one worker--make sure they get respawned. $tg->respawn_children(); }; subtest "job server status", sub { my $js_status = $client->get_job_server_status(); foreach (@{ $client->job_servers() }) { isnt($js_status->{$_}->{echo_prefix}->{capable}, 0, 'Correct capable jobs for echo_prefix'); is($js_status->{$_}->{echo_prefix}->{running}, 0, 'Correct running jobs for echo_prefix'); is($js_status->{$_}->{echo_prefix}->{queued}, 0, 'Correct queued jobs for echo_prefix'); } ## end foreach (@{ $client->job_servers...}) }; subtest "job server jobs", sub { $tg->is_perl_daemon() || plan skip_all => "'jobs' command supported only by Gearman::Server"; my $tasks = $client->new_task_set; $tasks->add_task('sleep', 1); 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}->{'sleep'}->{key}, '', 'Correct key for running job'); isnt($js_jobs->{$host}->{'sleep'}->{address}, undef, 'Correct address for running job'); is($js_jobs->{$host}->{'sleep'}->{listeners}, 1, 'Correct listeners for running job'); $tasks->wait; }; subtest "job server clients", sub { $tg->is_perl_daemon() || plan skip_all => "'clients' command supported only by Gearman::Server"; my $tasks = $client->new_task_set; $tasks->add_task('sleep', 1); 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}->{'sleep'}->{key}, '', 'Correct key for running job via client'); isnt($js_clients->{$js}->{$client}->{'sleep'}->{address}, undef, 'Correct address for running job via client'); } ## end foreach my $client (keys %{...}) } ## end foreach my $js (keys %$js_clients) $tasks->wait; }; ## Test dispatch_background and get_status. subtest "dispatch background", sub { my $handle = $client->dispatch_background( long => undef, { on_complete => sub { note "complete", ${ $_[0] } }, } ); # wait for job to start being processed: sleep 1; ok($handle, 'Got a handle back from dispatching background job'); my $status = $client->get_status($handle); isa_ok($status, 'Gearman::JobStatus'); ok($status->known, 'Job is known'); ok($status->running, 'Job is still running'); is($status->percent, .5, 'Job is 50 percent complete'); do { sleep 1; $status = $client->get_status($handle); note $status->percent; } until $status->percent == 1; }; done_testing(); Gearman-1.130.004/t/03-worker.t000644 001751 001751 00000006036 12751340667 016037 0ustar00palikpalik000000 000000 use strict; use warnings; # OK gearmand v1.0.6 # OK Gearman::Server use Test::More; use Test::Timer; use IO::Socket::INET; use FindBin qw/ $Bin /; use lib "$Bin/lib"; use Test::Gearman; my $debug = $ENV{DEBUG}; my $tg = Test::Gearman->new( count => 3, ip => "127.0.0.1", daemon => $ENV{GEARMAND_PATH} || undef ); my @js = $tg->start_servers() ? @{ $tg->job_servers } : (); my $mn = "Gearman::Worker"; use_ok($mn); can_ok( $mn, qw/ _get_js_sock _on_connect _register_all _set_ability job_servers register_function reset_abilities uncache_sock unregister_function work / ); subtest "new", sub { my $w = _w(); isa_ok($w, 'Gearman::Objects'); is(ref($w->{sock_cache}), "HASH"); is(ref($w->{last_connect_fail}), "HASH"); is(ref($w->{down_since}), "HASH"); is(ref($w->{can}), "HASH"); is(ref($w->{timeouts}), "HASH"); ok($w->{client_id} =~ /^\p{Lowercase}+$/); }; subtest "register_function", sub { my $w = _w(); my ($tn, $to) = qw/foo 2/; my $cb = sub {1}; ok($w->register_function($tn => $cb), "register_function($tn)"); time_ok( sub { $w->register_function($tn, $to, $cb); }, $to, "register_function($to, cb)" ); }; subtest "reset_abilities", sub { my $w = _w(); $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 { my $w = _w(); time_ok( sub { $w->work(stop_if => sub { pass "work stop if"; }); }, 12, "stop if timeout" ); }; subtest "_get_js_sock", sub { my $w = _w(); is($w->_get_js_sock(), undef); $w->{parent_pipe} = rand(10); my $hp = "127.0.0.1:9050"; is($w->_get_js_sock($hp), $w->{parent_pipe}); delete $w->{parent_pipe}; is($w->_get_js_sock($hp), undef); SKIP: { @{ $w->job_servers() } || skip "no job server available", 3; $hp = $w->job_servers()->[0]; $w->{last_connect_fail}{$hp} = 1; $w->{down_since}{$hp} = 1; isa_ok($w->_get_js_sock($hp, on_connect => sub {1}), "IO::Socket::INET"); is($w->{last_connect_fail}{$hp}, undef); is($w->{down_since}{$hp}, undef); } ## end SKIP: }; subtest "_on_connect-_set_ability", sub { my $w = _w(); my $m = "foo"; is($w->_on_connect(), undef); is($w->_set_ability(), 0); is($w->_set_ability(undef, $m), 0); is($w->_set_ability(undef, $m, 2), 0); my @js = @{ $w->job_servers() }; if (@js) { my $s = IO::Socket::INET->new( PeerAddr => $js[0], Timeout => 1 ); is($w->_on_connect($s), 1); is($w->_set_ability($s, $m), 1); is($w->_set_ability($s, $m, 2), 1); } ## end if (@js) }; done_testing(); sub _w { return new_ok($mn, [job_servers => [@js], debug => $debug]); } Gearman-1.130.004/t/01-object.t000644 001751 001751 00000002516 12751340667 015771 0ustar00palikpalik000000 000000 use strict; use warnings; use Test::More; use_ok('Gearman::Objects'); my @servers = qw/foo:12345 bar:54321/; my $c = new_ok( 'Gearman::Objects', [job_servers => $servers[0]], "Gearman::Objects->new(job_servers => $servers[0])" ); is( @{ $c->job_servers() }[0], @{ $c->canonicalize_job_servers($servers[0]) }[0], "job_servers=$servers[0]" ); is(1, $c->{js_count}, 'js_count=1'); $c = new_ok( 'Gearman::Objects', [job_servers => [@servers]], sprintf("Gearman::Objects->new(job_servers => [%s])", join(', ', @servers)) ); is(scalar(@servers), $c->{js_count}, 'js_count=' . scalar(@servers)); ok(my @js = $c->job_servers); for (my $i = 0; $i <= $#servers; $i++) { is(@{ $c->canonicalize_job_servers($servers[$i]) }[0], $js[$i], "canonicalize_job_servers($servers[$i])"); } is($c->debug(), 0, 'debug()'); is($c->debug(1), 1, 'debug(1)'); is($c->prefix(), undef, 'prefix'); is($c->prefix('foo'), 'foo', 'prefix(foo)'); ok($c->job_servers($servers[0]), "job_servers($servers[0])"); is( @{ $c->job_servers() }[0], @{ $c->canonicalize_job_servers($servers[0]) }[0], 'job_servers' ); ok($c->job_servers([$servers[0]]), "job_servers([$servers[0]])"); is( @{ $c->job_servers() }[0], @{ $c->canonicalize_job_servers($servers[0]) }[0], 'job_servers' ); done_testing(); Gearman-1.130.004/t/lib/Test/000755 001751 001751 00000000000 12751342315 015571 5ustar00palikpalik000000 000000 Gearman-1.130.004/t/lib/Test/Gearman.pm000644 001751 001751 00000012752 12750720053 017506 0ustar00palikpalik000000 000000 package Test::Gearman; use strict; use warnings; use fields qw/ daemon ports ip count _is_perl_daemon _job_servers /; use IO::Socket::INET; use Perl::OSType qw/ is_os_type /; use POSIX qw/ :sys_wait_h /; use FindBin qw/ $Bin /; my %Children; END { foreach (keys %Children) { if ($Children{$_} ne 'W' && $Children{$_} ne 'S') { qx/kill `cat $Children{$_}`/; } else { kill INT => $_; } } ## end foreach (keys %Children) } ## end END sub new { my ($class, %args) = @_; my $self = fields::new($class); $self->{ip} = $args{ip}; $self->{daemon} = $args{daemon}; unless (is_os_type('Windows')) { $self->{daemon} ||= qx/which gearmand/; chomp $self->{daemon}; } if ($self->{daemon}) { $self->{ports} = $self->_free_ports($args{count}); } return $self; } ## end sub new sub is_perl_daemon { my ($self) = @_; $self->{daemon} || return; unless (defined $self->{_is_perl_daemon}) { my $v = qx/$self->{daemon} -V/; $self->{_is_perl_daemon} = ($v && $v =~ /Gearman::Server/); } return $self->{_is_perl_daemon}; } ## end sub is_perl_daemon sub _free_ports { my ($self, $count) = @_; $count ||= 1; my @p; for (1 .. $count) { my $fp = _free_port($self->{ip}); $fp && push @p, $fp; } unless (scalar(@p) == $count) { warn "couldn't find $count free ports"; return; } return [@p]; } ## end sub _free_ports sub _free_port { my ($la, $port) = shift; my ($type, $retry, $sock) = ("tcp", 5); do { unless ($port) { $port = int(rand(20000)) + 30000; } IO::Socket::INET->new( LocalAddr => $la, LocalPort => $port, Proto => $type, ReuseAddr => 1 ) or undef($port); } until ($port || --$retry == 0); return $port; } ## end sub _free_port sub job_servers { return shift->{_job_servers}; } sub start_servers { my ($self) = @_; ($self->{daemon} && $self->{ports}) || return; (-e $self->{daemon}) || return; my $ok = 1; foreach (@{ $self->{ports} }) { my $pid = $self->_start_server($_); unless ($pid) { $ok = 0; last; } push @{ $self->{_job_servers} }, join ':', $self->{ip}, $_; $Children{$pid} = $self->is_perl_daemon() ? 'S' : $self->_pid_file("daemon", $_); } ## end foreach (@{ $self->{ports} ...}) return $ok; } ## end sub start_servers sub _pid_file { my ($self) = shift; return join '/', "/tmp", join('-', @_); } sub _start_server { my ($self, $port) = @_; my $pid; my $daemon = $self->{daemon}; my $pf = $self->_pid_file("daemon", $port); unless ($self->is_perl_daemon()) { my ($verbose, $lf) = (''); if ($ENV{DEBUG}) { $lf = join('.', $pf, "log"); $verbose = "--verbose=INFO"; } else { $lf = "/dev/null"; } $pid = _start_child("$daemon -p $port -d -P $pf --log-file=$lf $verbose", 1); } ## end unless ($self->is_perl_daemon...) else { my $ready = 0; local $SIG{USR1} = sub { $ready = 1; }; $pid = _start_child([$daemon, '-p' => $port, '-n' => $$]); while (!$ready) { select undef, undef, undef, 0.10; } } ## end else return $pid; } ## end sub _start_server sub start_worker { my ($self, $args) = @_; $self->job_servers || die "no running job servers"; unless (ref $args) { $args = {}; } my $worker = "$Bin/worker.pl"; my $servers = join ',', @{ $self->job_servers }; my $ready = 0; my $pid; local $SIG{USR1} = sub { $ready = 1; }; $pid = _start_child( [ $worker, '-s' => $servers, '-n' => $$, ($args->{prefix} ? ('-p' => $args->{prefix}) : ()) ] ); $Children{$pid} = 'W'; while (!$ready) { select undef, undef, undef, 0.10; } return $pid; } ## end sub start_worker sub check_server_connection { my ($self, $pa) = @_; my ($start, $sock, $to) = (time); do { $sock = IO::Socket::INET->new(PeerAddr => $pa); select undef, undef, undef, 0.25; $to = time > $start + 5; } until ($sock || $to); $to && warn "Timeout waiting for peer address $pa"; return (defined($sock) && !$to); } ## end sub check_server_connection sub pid_is_dead { my ($self, $pid) = @_; return if $pid == -1; if (delete $Children{$pid} eq 'W') { ## Right now we can only restart workers. $self->start_worker(); } } ## end sub pid_is_dead sub respawn_children { my ($self) = @_; for my $pid (keys %Children) { $Children{$pid} eq 'W' || next; if (waitpid($pid, WNOHANG) > 0) { $self->pid_is_dead($pid); } } ## end for my $pid (keys %Children) } ## end sub respawn_children sub stop_worker { my ($self, $pid) = @_; ($Children{$pid} && $Children{$pid} eq 'W') || return; kill INT => ($pid); } sub _start_child { my ($cmd, $binary) = @_; my $pid = fork(); die $! unless defined $pid; unless ($pid) { if (!$binary) { exec $^X, '-Iblib/lib', '-Ilib', @$cmd or die $!; } else { exec($cmd) or die $!; } } ## end unless ($pid) $pid; } ## end sub _start_child 1; Gearman-1.130.004/lib/Gearman/000755 001751 001751 00000000000 12751342315 015761 5ustar00palikpalik000000 000000 Gearman-1.130.004/lib/Gearman/ResponseParser.pm000644 001751 001751 00000007733 12751340654 021310 0ustar00palikpalik000000 000000 package Gearman::ResponseParser; use version; $Gearman::ResponseParser::VERSION = qv("1.130.004"); use strict; use warnings; =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 $data; my $rv = sysread($sock, $data, 128 * 1024); if (!defined $rv) { $self->on_error("read_error: $!"); return; } # FIXME: EAGAIN , EWOULDBLOCK if (!$rv) { $self->eof; return; } $self->parse_data(\$data); } ## end sub parse_sock 1; Gearman-1.130.004/lib/Gearman/JobStatus.pm000644 001751 001751 00000002036 12751340654 020242 0ustar00palikpalik000000 000000 package Gearman::JobStatus; use version; $Gearman::JobStatus::VERSION = qv("1.130.004"); 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); # my $self = [$known, $running, $nu, $de]; return bless [$known, $running, $nu, $de], $class; # return $self; } ## 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-1.130.004/lib/Gearman/Job.pm000644 001751 001751 00000003225 12751340654 017037 0ustar00palikpalik000000 000000 package Gearman::Job; use version; $Gearman::Job::VERSION = qv("1.130.004"); use strict; use warnings; #TODO: retries? # 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', 'jss', # job server's socket ); sub new { my ($class, $func, $argref, $handle, $jss) = @_; my $self = $class; $self = fields::new($class) unless ref $self; $self->{func} = $func; $self->{handle} = $handle; $self->{argref} = $argref; $self->{jss} = $jss; return $self; } ## 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 Gearman::Job $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 { my Gearman::Job $self = shift; return $self->{argref}; } =head2 arg() B the scalar argument that the client sent to the job server. =cut sub arg { my Gearman::Job $self = shift; return ${ $self->{argref} }; } =head2 handle() B handle =cut sub handle { my Gearman::Job $self = shift; return $self->{handle}; } Gearman-1.130.004/lib/Gearman/Util.pm000644 001751 001751 00000020036 12751340654 017241 0ustar00palikpalik000000 000000 package Gearman::Util; use version; $Gearman::Util::VERSION = qv("1.130.004"); use strict; use warnings; # man errno # Resource temporarily unavailable # (may be the same value as EWOULDBLOCK) (POSIX.1) use POSIX qw(:errno_h); use Time::HiRes qw(); use IO::Handle; =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] 23 => ['I', "can_do_timeout"], # from W: FUNC[0]TIMEOUT 2 => ['I', "cant_do"], # from W: [FUNC] 3 => ['I', "reset_abilities"], # from W: --- 22 => ['I', "set_client_id"], # W->J: [RANDOM_STRING_NO_WHITESPACE] 4 => ['I', "pre_sleep"], # from W: --- 26 => ['I', "option_req"], # C->J: [OPT] 27 => ['O', "option_res"], # J->C: [OPT] 6 => ['O', "noop"], # J->W --- 7 => ['I', "submit_job"], # C->J FUNC[0]UNIQ[0]ARGS 21 => ['I', "submit_job_high"], # C->J FUNC[0]UNIQ[0]ARGS 18 => ['I', "submit_job_bg"], # C->J " " " " " 32 => ['I', "submit_job_high_bg"], # 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 25 => ['IO', "work_exception"], # W->J/C: HANDLE[0]EXCEPTION 15 => ['I', "get_status"], # C->J: HANDLE 20 => ['O', "status_res"], # C->J: HANDLE[0]KNOWN[0]RUNNING[0]NUM[0]DENOM 16 => ['I', "echo_req"], # ?->J TEXT 17 => ['O', "echo_res"], # J->? TEXT 19 => ['O', "error"], # J->? ERRCODE[0]ERR_TEXT # for worker to declare to the jobserver that this worker is only connected # to one jobserver, so no polls/grabs will take place, and server is free # to push "job_assign" packets back down. 24 => ['I', "all_yours"], # W->J --- ); our %num; # name -> num while (my ($num, $ary) = each %cmd) { die if $num{ $ary->[1] }; $num{ $ary->[1] } = $num; } =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(); my $err = sub { my $code = shift; $sock->close() if $sock->connected; $$err_ref = $code if ref $err_ref; return undef; }; IO::Handle::blocking($sock, 0); my $fileno = fileno($sock); my $rin = ''; vec($rin, $fileno, 1) = 1; my $readlen = 12; my $offset = 0; my $buf = ''; my ($magic, $type, $len); warn " Starting up event loop\n" if DEBUG; while (1) { 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; } warn " Selecting on fd $fileno\n" if DEBUG; my $nfound = select((my $rout = $rin), undef, undef, $time_remaining); warn " Got $nfound fds back from select\n" if DEBUG; next unless vec($rout, $fileno, 1); 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") 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; IO::Handle::blocking($sock, 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; } ## end unless ($rv) 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; return _read_sock($sock, $buf_ref, $readlen_ref, $offset_ref); } ## 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; }; 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 $len = length($$reqref); local $SIG{PIPE} = 'IGNORE'; my $rv = $sock->syswrite($$reqref, $len); return ($rv && $rv == $len) ? 1 : 0; } ## 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-1.130.004/lib/Gearman/Task.pm000644 001751 001751 00000024511 12751340654 017230 0ustar00palikpalik000000 000000 package Gearman::Task; use version; $Gearman::Task::VERSION = qv("1.130.004"); 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 * retry_count Number of times job will be retried if there are failures. Defaults to 0. =item * high_priority Boolean, whether this job should take priority over other jobs already enqueued. =item * timeout Automatically fail, calling your on_fail callback, after this many seconds have elapsed without an on_fail or on_complete being called. Defaults to 0, which means never. Bypasses any retry_count remaining. =item * try_timeout Automatically fail, calling your on_retry callback (or on_fail if out of retries), after this many seconds have elapsed. Defaults to 0, which means never. =back =head1 METHODS =cut use Carp (); use Gearman::Util; use String::CRC32 (); use Storable; use fields ( # from client: 'func', 'argref', # opts from client: 'uniq', 'on_complete', 'on_fail', 'on_exception', 'on_retry', 'on_status', 'on_post_hooks', # used internally, # when other hooks are done running, # prior to cleanup 'retry_count', 'timeout', 'try_timeout', 'high_priority', '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', ); # constructor, given: ($func, $argref, $opts); sub new { my $class = shift; my $self = $class; $self = fields::new($class) unless ref $self; $self->{func} = shift or Carp::croak("No function given"); $self->{argref} = shift || do { my $empty = ""; \$empty; }; Carp::croak("Argref not a scalar reference") unless ref $self->{argref} eq "SCALAR"; my $opts = shift || {}; $self->{$_} = delete $opts->{$_} for qw/ background high_priority on_complete on_exception on_fail on_retry on_status retry_count timeout try_timeout uniq /; $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 =head2 run_hook($name) run a hook callback if defined =cut sub run_hook { my Gearman::Task $self = shift; my $name = 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 Gearman::Task $self = shift; my $name = shift || 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 { my Gearman::Task $task = $_[0]; return $task->{is_finished}; } =head2 taskset() getter =head2 taskset($ts) setter B Gearman::Taskset =cut sub taskset { my Gearman::Task $task = shift; # getter return $task->{taskset} unless @_; # setter my $ts = shift; ref($ts) eq "Gearman::Taskset" || Carp::croak("argument is not an instance of Gearman::Taskset"); $task->{taskset} = $ts; if (my $hash_num = $task->hash()) { $task->{jssock} = $ts->_get_hashed_sock($hash_num); } else { $task->{jssock} = $ts->_get_default_sock; } return $task->{taskset}; } ## end sub taskset =head2 hash() B undef on non-uniq packet, or the hash value (0-32767) if uniq =cut sub hash { my Gearman::Task $task = shift; my $merge_on = $task->{uniq} && $task->{uniq} eq "-" ? $task->{argref} : \$task->{uniq}; if (${$merge_on}) { return (String::CRC32::crc32(${$merge_on}) >> 16) & 0x7fff; } else { return undef; } } ## end sub hash =head2 pack_submit_packet($client) B Gearman::Util::pack_req_command(mode, func, uniq, argref) =cut sub pack_submit_packet { my Gearman::Task $task = shift; my $client = shift; my $func = $task->{func}; if ($client && $client->prefix()) { $func = join "\t", $client->prefix(), $task->{func}; } return Gearman::Util::pack_req_command( $task->mode, join( "\0", $func || '', $task->{uniq} || '', ${ $task->{argref} } || '' ) ); } ## end sub pack_submit_packet =head2 fail($reason) =cut sub fail { my Gearman::Task $task = shift; my $reason = shift; return if $task->{is_finished}; # try to retry, if we can if ($task->{retries_done} < $task->{retry_count}) { $task->{retries_done}++; $task->{on_retry}->($task->{retries_done}) if $task->{on_retry}; $task->handle(undef); return $task->{taskset}->add_task($task); } ## end if ($task->{retries_done...}) $task->final_fail($reason); } ## end sub fail =head2 final_fail($reason) run if !is_finished =over =item on_fail =item on_post_hooks =back =cut sub final_fail { my Gearman::Task $task = $_[0]; my $reason = $_[1]; return if $task->{is_finished}; $task->{is_finished} = $_[1] || 1; $task->run_hook('final_fail', $task); $task->{on_fail}->($reason) if $task->{on_fail}; $task->{on_post_hooks}->() if $task->{on_post_hooks}; $task->wipe; return undef; } ## end sub final_fail #FIXME obsolete? =head2 exception($exc_ref) $exc_ref may be a Storable serialized value run on_exception if defined =cut sub exception { my Gearman::Task $task = shift; my $exception_ref = shift; my $exception = Storable::thaw($$exception_ref); $task->{on_exception}->($$exception) if $task->{on_exception}; return; } ## end sub exception =head2 complete() =cut sub complete { my Gearman::Task $task = shift; return if $task->{is_finished}; my $result_ref = shift; $task->{is_finished} = 'complete'; $task->run_hook('complete', $task); $task->{on_complete}->($result_ref) if $task->{on_complete}; $task->{on_post_hooks}->() if $task->{on_post_hooks}; $task->wipe; } ## end sub complete =head2 status() =cut sub status { my Gearman::Task $task = shift; return if $task->{is_finished}; return unless $task->{on_status}; my ($nu, $de) = @_; $task->{on_status}->($nu, $de); } ## end sub status =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 Gearman::Task $task = shift; if (@_) { $task->{handle} = shift; } return $task->{handle}; } ## end sub handle #FIXME obsolete? =head2 set_on_post_hooks($code) =cut sub set_on_post_hooks { my Gearman::Task $task = shift; my $code = shift; $task->{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 Gearman::Task $task = shift; my @h = qw/ on_post_hooks on_complete on_fail on_retry on_status hooks /; foreach my $f (@h) { $task->{$f} = undef; } } ## end sub wipe =head2 func() =cut sub func { my Gearman::Task $task = shift; return $task->{func}; } =head2 timeout() getter =head2 timeout($t) setter B timeout =cut sub timeout { my Gearman::Task $task = shift; if (@_) { $task->{timeout} = shift; } return $task->{timeout}; } ## end sub timeout =head2 mode() B mode in depends of background and hight_priority =cut sub mode { my Gearman::Task $task = shift; return $task->{background} ? ( $task->{high_priority} ? "submit_job_high_bg" : "submit_job_bg" ) : ( $task->{high_priority} ? "submit_job_high" : "submit_job" ); } ## end sub mode 1; __END__ Gearman-1.130.004/lib/Gearman/Worker.pm000644 001751 001751 00000045556 12751340654 017613 0ustar00palikpalik000000 000000 package Gearman::Worker; use version; $Gearman::Worker::VERSION = qv("1.130.004"); 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'); $worker->register_function($funcname => $subref); $worker->work while 1; =head1 DESCRIPTION I is a worker class for the Gearman distributed job system, providing a framework for receiving and serving jobs from a Gearman server. Callers instantiate a I object, register a list of functions and capabilities that they can handle, then enter an event loop, waiting for the server to send jobs. The worker can send a return value back to the server, which then gets sent back to the client that requested the job; or it can simply execute silently. =head1 USAGE =head2 Gearman::Worker->new(%options) Creates a new I object, and returns the object. If I<%options> is provided, initializes the new worker object with the settings in I<%options>, which can contain: =over 4 =item * job_servers Calls I (see below) to initialize the list of job servers. It will be ignored if this worker is running as a child process of a gearman server. =item * prefix Calls I (see below) to set the prefix / namespace. =back =head2 $client-Eprefix($prefix) Sets the namespace / prefix for the function names. This is useful for sharing job servers between different applications or different instances of the same application (different development sandboxes for example). The namespace is currently implemented as a simple tab separated 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 I documentation for a sample client sending the I job. =head1 METHODS =cut #TODO: retries? # use Gearman::Util; use Gearman::Job; use Carp (); use IO::Socket::INET (); use Socket qw( IPPROTO_TCP TCP_NODELAY SOL_SOCKET PF_INET SOCK_STREAM); use fields ( 'sock_cache', # host:port -> IO::Socket::INET 'last_connect_fail', # host:port -> unixtime 'down_since', # host:port -> unixtime 'connecting', # host:port -> unixtime connect started at 'can', # ability -> subref (ability is func with optional prefix) 'timeouts', # ability -> timeouts 'client_id', # random 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.. ); BEGIN { my $storable = eval { require Storable; 1 } if !defined &THROW_EXCEPTIONS || THROW_EXCEPTIONS(); $storable ||= 0; if (defined &THROW_EXCEPTIONS) { die "Exceptions support requires Storable: $@"; } else { eval "sub THROW_EXCEPTIONS () { $storable }"; die "Couldn't define THROW_EXCEPTIONS: $@\n" if $@; } } ## end BEGIN sub new { my ($class, %opts) = @_; my $self = $class; $self = fields::new($class) unless ref $self; $self->SUPER::new( debug => delete $opts{debug}, prefix => delete $opts{prefix} ); $self->{sock_cache} = {}; $self->{last_connect_fail} = {}; $self->{down_since} = {}; $self->{can} = {}; $self->{timeouts} = {}; $self->{client_id} = join("", map { chr(int(rand(26)) + 97) } (1 .. 30)); if ($ENV{GEARMAN_WORKER_USE_STDIO}) { open my $sock, '+<&', \*STDIN or die "Unable to dup STDIN to socket for worker to use."; $self->{job_servers} = [$sock]; $self->{parent_pipe} = $sock; die "Unable to initialize connection to gearmand" unless $self->_on_connect($sock); } ## end if ($ENV{GEARMAN_WORKER_USE_STDIO...}) elsif ($opts{job_servers}) { $self->job_servers(@{ $opts{job_servers} }); } $self->prefix($opts{prefix}) if $opts{prefix}; return $self; } ## end sub new # # _get_js_sock($ipport, %opts) # sub _get_js_sock { my Gearman::Worker $self = shift; my $ipport = shift; my %opts = @_; $ipport || return; my $on_connect = delete $opts{on_connect}; # Someday should warn when called with extra opts. warn "getting job server socket: $ipport" if $self->debug; # special case, if we're a child process of a gearman::server # parent process, talking over a unix pipe... return $self->{parent_pipe} if $self->{parent_pipe}; if (my $sock = $self->{sock_cache}{$ipport}) { return $sock if getpeername($sock); delete $self->{sock_cache}{$ipport}; } my $now = time; my $down_since = $self->{down_since}{$ipport}; if ($down_since) { warn "job server down since $down_since" if $self->debug; my $down_for = $now - $down_since; my $retry_period = $down_for > 60 ? 30 : (int($down_for / 2) + 1); if ($self->{last_connect_fail}{$ipport} > $now - $retry_period) { return undef; } } ## end if ($down_since) warn "connecting to '$ipport'" if $self->debug; my $sock = IO::Socket::INET->new( PeerAddr => $ipport, Timeout => 1 ); unless ($sock) { $self->debug && warn "$@"; $self->{down_since}{$ipport} ||= $now; $self->{last_connect_fail}{$ipport} = $now; return; } delete $self->{last_connect_fail}{$ipport}; delete $self->{down_since}{$ipport}; $sock->autoflush(1); setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; $self->{sock_cache}{$ipport} = $sock; unless ($self->_on_connect($sock) && $on_connect && $on_connect->($sock)) { delete $self->{sock_cache}{$ipport}; return; } return $sock; } ## end sub _get_js_sock # # _on_connect($sock) # # Housekeeping things to do on connection to a server. Method call # with one argument being the 'socket' we're going to take care of. # returns true on success, false on failure. # sub _on_connect { my ($self, $sock) = @_; my $cid_req = Gearman::Util::pack_req_command("set_client_id", $self->{client_id}); return undef unless Gearman::Util::send_req($sock, \$cid_req); # get this socket's state caught-up foreach my $ability (keys %{ $self->{can} }) { my $timeout = $self->{timeouts}->{$ability}; unless ($self->_set_ability($sock, $ability, $timeout)) { return undef; } } ## end foreach my $ability (keys %...) return 1; } ## end sub _on_connect # # _set_ability($sock, $ability, $timeout) # sub _set_ability { my Gearman::Worker $self = shift; my ($sock, $ability, $timeout) = @_; my $req; if (defined $timeout) { $req = Gearman::Util::pack_req_command("can_do_timeout", "$ability\0$timeout"); } else { $req = Gearman::Util::pack_req_command("can_do", $ability); } return Gearman::Util::send_req($sock, \$req); } ## end sub _set_ability =head2 reset_abilities tell all the jobservers that this worker can't do anything =cut sub reset_abilities { my Gearman::Worker $self = shift; my $req = Gearman::Util::pack_req_command("reset_abilities"); foreach my $js (@{ $self->{job_servers} }) { my $jss = $self->_get_js_sock($js) or next; unless (Gearman::Util::send_req($jss, \$req)) { $self->uncache_sock("js", "err_write_reset_abilities"); } } ## end foreach my $js (@{ $self->{...}}) $self->{can} = {}; $self->{timeouts} = {}; } ## end sub reset_abilities =head2 uncache_sock($ipport, $reason) close TCP connection =cut sub uncache_sock { my ($self, $ipport, $reason) = @_; # we can't reconnect as a child process, so all we can do is die and hope our # parent process respawns us... die "Error/timeout talking to gearman parent process: [$reason]" if $self->{parent_pipe}; # normal case, we just close this TCP connection and we'll reconnect later. delete $self->{sock_cache}{$ipport}; } ## end sub uncache_sock =head2 work(%opts) Endless loop takes a job and wait for the next one. You can pass "stop_if", "on_start", "on_complete" and "on_fail" callbacks in I<%opts>. =cut sub work { my Gearman::Worker $self = shift; my %opts = @_; my $stop_if = delete $opts{'stop_if'} || sub {0}; my $complete_cb = delete $opts{on_complete}; my $fail_cb = delete $opts{on_fail}; my $start_cb = delete $opts{on_start}; die "Unknown opts" if %opts; my $grab_req = Gearman::Util::pack_req_command("grab_job"); my $presleep_req = Gearman::Util::pack_req_command("pre_sleep"); my $last_job_time; my $on_connect = sub { return Gearman::Util::send_req($_[0], \$presleep_req); }; # "Active" job servers are servers that have woken us up and should be # queried to see if they have jobs for us to handle. On our first pass # in the loop we contact all servers. my %active_js = map { $_ => 1 } @{ $self->{job_servers} }; # ( js => last_update_time, ... ) my %last_update_time; while (1) { # "Jobby" job servers are the set of server which we will contact # on this pass through the loop, because we need to clear and use # the "Active" set to plan for our next pass through the loop. my @jobby_js = keys %active_js; %active_js = (); my $js_count = @jobby_js; my $js_offset = int(rand($js_count)); my $is_idle = 0; for (my $i = 0; $i < $js_count; $i++) { my $js_index = ($i + $js_offset) % $js_count; my $js = $jobby_js[$js_index]; my $jss = $self->_get_js_sock($js, on_connect => $on_connect) or next; # TODO: add an optional sleep in here for the test suite # to test gearmand server going away here. (SIGPIPE on # send_req, etc) this testing has been done manually, at # least. unless (Gearman::Util::send_req($jss, \$grab_req)) { if ($!{EPIPE} && $self->{parent_pipe}) { # our parent process died, so let's just quit # gracefully. exit(0); } ## end if ($!{EPIPE} && $self...) $self->uncache_sock($js, "grab_job_timeout"); delete $last_update_time{$js}; next; } ## end unless (Gearman::Util::send_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}; 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}; next; } } while ($res->{type} eq "noop"); if ($res->{type} eq "no_job") { unless (Gearman::Util::send_req($jss, \$presleep_req)) { delete $last_update_time{$js}; $self->uncache_sock($js, "write_presleep_error"); } $last_update_time{$js} = time; next; } ## end if ($res->{type} eq "no_job") unless ($res->{type} eq "job_assign") { my $msg = "Uh, wasn't expecting a $res->{type} packet."; if ($res->{type} eq "error") { $msg .= " [${$res->{blobref}}]\n"; $msg =~ s/\0/ -- /g; } die $msg; } ## end unless ($res->{type} eq "job_assign") ${ $res->{'blobref'} } =~ s/^(.+?)\0(.+?)\0// or die "Uh, regexp on job_assign failed"; my ($handle, $ability) = ($1, $2); my $job = Gearman::Job->new($ability, $res->{'blobref'}, $handle, $jss); my $jobhandle = "$js//" . $job->handle; $start_cb->($jobhandle) if $start_cb; my $handler = $self->{can}{$ability}; my $ret = eval { $handler->($job); }; my $err = $@; warn "Job '$ability' died: $err" if $err; $last_update_time{$js} = $last_job_time = time(); if (THROW_EXCEPTIONS && $err) { my $exception_req = Gearman::Util::pack_req_command("work_exception", join("\0", $handle, Storable::nfreeze(\$err))); unless (Gearman::Util::send_req($jss, \$exception_req)) { $self->uncache_sock($js, "write_res_error"); next; } } ## end if (THROW_EXCEPTIONS &&...) my $work_req; if (defined $ret) { my $rv = ref $ret ? $$ret : $ret; $work_req = Gearman::Util::pack_req_command("work_complete", "$handle\0$rv"); $complete_cb->($jobhandle, $ret) if $complete_cb; } ## end if (defined $ret) else { $work_req = Gearman::Util::pack_req_command("work_fail", $handle); $fail_cb->($jobhandle, $err) if $fail_cb; } unless (Gearman::Util::send_req($jss, \$work_req)) { $self->uncache_sock($js, "write_res_error"); next; } $active_js{$js} = 1; } ## end for (my $i = 0; $i < $js_count...) my @jss; foreach my $js (@{ $self->{job_servers} }) { my $jss = $self->_get_js_sock($js, on_connect => $on_connect) or next; push @jss, [$js, $jss]; } $is_idle = 1; my $wake_vec = ''; foreach my $j (@jss) { my ($js, $jss) = @$j; my $fd = $jss->fileno; vec($wake_vec, $fd, 1) = 1; } my $timeout = keys %active_js ? 0 : (10 + rand(2)); # chill for some arbitrary time until we're woken up again my $nready = select(my $wout = $wake_vec, undef, undef, $timeout); if ($nready) { foreach my $j (@jss) { my ($js, $jss) = @$j; my $fd = $jss->fileno; $active_js{$js} = 1 if vec($wout, $fd, 1); } ## end foreach my $j (@jss) } ## end if ($nready) $is_idle = 0 if keys %active_js; return if $stop_if->($is_idle, $last_job_time); my $update_since = time - (15 + rand 60); while (my ($js, $last_update) = each %last_update_time) { $active_js{$js} = 1 if $last_update < $update_since; } } ## end while (1) } ## end sub work =head2 $worker->register_function($funcname, $subref) =head2 $worker->register_function($funcname, $timeout, $subref) Registers the function I<$funcname> as being provided by the worker I<$worker>, and advertises these capabilities to all of the job servers defined in this worker. I<$subref> must be a subroutine reference that will be invoked when the worker receives a request for this function. It will be passed a I object representing the job that has been received by the worker. I<$timeout> is an optional parameter specifying how long the jobserver will wait for your subroutine to give an answer. Exceeding this time will result in the jobserver reassigning the task and ignoring your result. This prevents a gimpy worker from ruining the 'user experience' in many situations. The subroutine reference can return a return value, which will be sent back to the job server. =cut sub register_function { my Gearman::Worker $self = shift; my $func = shift; my $timeout = shift unless (ref $_[0] eq 'CODE'); my $subref = shift; my $prefix = $self->prefix; my $ability = defined($prefix) ? "$prefix\t$func" : "$func"; my $req; if (defined $timeout) { $req = Gearman::Util::pack_req_command("can_do_timeout", "$ability\0$timeout"); $self->{timeouts}{$ability} = $timeout; } else { $req = Gearman::Util::pack_req_command("can_do", $ability); } $self->_register_all($req); $self->{can}{$ability} = $subref; } ## end sub register_function =head2 unregister_function($funcname) =cut sub unregister_function { my Gearman::Worker $self = shift; my $func = shift; my $prefix = $self->prefix; my $ability = defined($prefix) ? "$prefix\t$func" : "$func"; my $req = Gearman::Util::pack_req_command("cant_do", $ability); $self->_register_all($req); delete $self->{can}{$ability}; } ## end sub unregister_function # # _register_all($req) # sub _register_all { my Gearman::Worker $self = shift; my $req = shift; foreach my $js (@{ $self->{job_servers} }) { my $jss = $self->_get_js_sock($js) or next; unless (Gearman::Util::send_req($jss, \$req)) { $self->uncache_sock($js, "write_register_func_error"); } } ## end foreach my $js (@{ $self->{...}}) } ## end sub _register_all =head2 job_servers(@servers) override L method to skip job server initialization if defined C<$ENV{GEARMAN_WORKER_USE_STDIO}> 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 Gearman::Worker $self = shift; return if ($ENV{GEARMAN_WORKER_USE_STDIO}); return $self->SUPER::job_servers(@_); } ## end sub job_servers 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 jobservers function and option for new() are ignored and the unix socket bound to STDIN/OUT are used instead as the IO path to the gearman server. Gearman-1.130.004/lib/Gearman/Objects.pm000644 001751 001751 00000003600 12751340654 017713 0ustar00palikpalik000000 000000 package Gearman::Objects; use version; $Gearman::Objects::VERSION = qv("1.130.004"); use strict; use warnings; =head1 NAME Gearman::Objects - a parrent class for L and L =head1 METHODS =cut use constant DEFAULT_PORT => 4730; use fields qw/ debug job_servers js_count prefix /; sub new { my Gearman::Objects $self = shift; my (%opts) = @_; unless (ref($self)) { $self = fields::new($self); } $self->{job_servers} = []; $self->{js_count} = 0; $self->{prefix} = undef; $opts{job_servers} && $self->set_job_servers( ref($opts{job_servers}) ? @{ $opts{job_servers} } : [$opts{job_servers}] ); $opts{debug} && $self->debug($opts{debug}); $opts{prefix} && $self->prefix($opts{prefix}); return $self; } ## end sub new =head2 job_servers([$js]) getter/setter C<$js> may be an array reference or scalar =cut sub job_servers { my ($self) = shift; (@_) && $self->set_job_servers(@_); return wantarray ? @{ $self->{job_servers} } : $self->{job_servers}; } ## end sub job_servers 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 sub canonicalize_job_servers { my ($self) = shift; # take arrayref or array my $list = ref $_[0] ? $_[0] : [@_]; foreach (@$list) { $_ .= ':' . Gearman::Objects::DEFAULT_PORT unless /:/; } return $list; } ## end sub canonicalize_job_servers sub debug { my $self = shift; $self->{debug} = shift if @_; return $self->{debug} || 0; } =head2 prefix([$prefix]) getter/setter =cut sub prefix { my $self = shift; if (@_) { $self->{prefix} = shift; } return $self->{prefix}; } ## end sub prefix 1; Gearman-1.130.004/lib/Gearman/Taskset.pm000644 001751 001751 00000032372 12751340654 017750 0ustar00palikpalik000000 000000 package Gearman::Taskset; use version; $Gearman::Taskset::VERSION = qv("1.130.004"); use strict; use warnings; use Socket; =head1 NAME Gearman::Taskset - a taskset in Gearman, from the point of view of a client =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 Gearman::Client's representation of tasks queue t in Gearman =head1 METHODS =cut use fields ( # { handle => [Task, ...] } 'waiting', # Gearman::Client 'client', # arrayref 'need_handle', # default socket (non-merged requests) 'default_sock', # default socket's ip/port 'default_sockaddr', # { hostport => socket } 'loaned_sock', # bool, if taskset has been cancelled mid-processing 'cancelled', # hookname -> coderef 'hooks', ); use Carp (); use Gearman::Util; use Gearman::ResponseParser::Taskset; # i thought about weakening taskset's client, but might be too weak. use Scalar::Util (); use Time::HiRes (); =head2 new($client) =cut sub new { my $self = shift; my $client = shift; ref($client) eq "Gearman::Client" || Carp::croak "provided client argument is not a Gearman::Client reference"; unless (ref $self) { $self = fields::new($self); } $self->{waiting} = {}; $self->{need_handle} = []; $self->{client} = $client; $self->{loaned_sock} = {}; $self->{cancelled} = 0; $self->{hooks} = {}; return $self; } ## end sub new sub DESTROY { my Gearman::Taskset $ts = shift; # During global cleanup this may be called out of order, and the client my not exist in the taskset. return unless $ts->{client}; if ($ts->{default_sock}) { $ts->{client} ->_put_js_sock($ts->{default_sockaddr}, $ts->{default_sock}); } while (my ($hp, $sock) = each %{ $ts->{loaned_sock} }) { $ts->{client}->_put_js_sock($hp, $sock); } } ## end sub DESTROY =head2 run_hook($name) run a hook callback if defined =cut sub run_hook { my Gearman::Taskset $self = shift; my $name = 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) add a hook =cut sub add_hook { my Gearman::Taskset $self = shift; my $name = shift || return; if (@_) { $self->{hooks}->{$name} = shift; } else { delete $self->{hooks}->{$name}; } } ## end sub add_hook =head2 client () 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. =cut sub client { my Gearman::Taskset $ts = shift; return $ts->{client}; } =head2 cancel() =cut sub cancel { my Gearman::Taskset $ts = shift; $ts->{cancelled} = 1; if ($ts->{default_sock}) { close($ts->{default_sock}); $ts->{default_sock} = undef; } while (my ($hp, $sock) = each %{ $ts->{loaned_sock} }) { $sock->close; } $ts->{waiting} = {}; $ts->{need_handle} = []; $ts->{client} = undef; } ## end sub cancel #=head2 _get_loaned_sock($hostport) # #=cut sub _get_loaned_sock { my Gearman::Taskset $ts = shift; my $hostport = shift; if (my $sock = $ts->{loaned_sock}{$hostport}) { return $sock if $sock->connected; delete $ts->{loaned_sock}{$hostport}; } my $sock = $ts->{client}->_get_js_sock($hostport); return $ts->{loaned_sock}{$hostport} = $sock; } ## end sub _get_loaned_sock =head2 wait() event loop for reading in replies =cut sub wait { my Gearman::Taskset $ts = shift; my %opts = @_; my $timeout; if (exists $opts{timeout}) { $timeout = delete $opts{timeout}; $timeout += Time::HiRes::time() if defined $timeout; } Carp::carp "Unknown options: " . join(',', keys %opts) . " passed to Taskset->wait." if keys %opts; my %parser; # fd -> Gearman::ResponseParser object my ($rin, $rout, $eout) = ('', '', ''); my %watching; for my $sock ($ts->{default_sock}, values %{ $ts->{loaned_sock} }) { next unless $sock; my $fd = $sock->fileno; vec($rin, $fd, 1) = 1; $watching{$fd} = $sock; } ## end for my $sock ($ts->{default_sock...}) my $tries = 0; while (!$ts->{cancelled} && keys %{ $ts->{waiting} }) { $tries++; my $time_left = $timeout ? $timeout - Time::HiRes::time() : 0.5; my $nfound = select($rout = $rin, undef, $eout = $rin, $time_left) ; # TODO drop the eout. if ($timeout && $time_left <= 0) { $ts->cancel; return; } next if !$nfound; foreach my $fd (keys %watching) { next unless vec($rout, $fd, 1); # TODO: deal with error vector my $sock = $watching{$fd}; my $parser = $parser{$fd} ||= Gearman::ResponseParser::Taskset->new( source => $sock, taskset => $ts ); eval { $parser->parse_sock($sock); }; if ($@) { # TODO this should remove the fd from the list, and reassign any tasks to other jobserver, or bail. # We're not in an accessible place here, so if all job servers fail we must die to prevent hanging. Carp::croak("Job server failure: $@"); } ## end if ($@) } ## end foreach my $fd (keys %watching) } ## end while (!$ts->{cancelled} ...) } ## end sub wait =head2 add_task(Gearman::Task) =head2 add_task($func, <$scalar | $scalarref>, <$uniq | $opts_hr> C<$opts_hr> see L =cut sub add_task { my Gearman::Taskset $ts = shift; my $task = $ts->client()->_get_task_from_args(@_); $task->taskset($ts); $ts->run_hook('add_task', $ts, $task); my $jssock = $task->{jssock}; return $task->fail("undefined jssock") unless ($jssock); my $req = $task->pack_submit_packet($ts->client); my $len = length($req); my $rv = $jssock->syswrite($req, $len); $rv ||= 0; Carp::croak "Wrote $rv but expected to write $len" unless $rv == $len; push @{ $ts->{need_handle} }, $task; while (@{ $ts->{need_handle} }) { my $rv = $ts->_wait_for_packet($jssock, $ts->{client}->{command_timeout}); if (!$rv) { shift @{ $ts->{need_handle} }; # ditch it, it failed. # this will resubmit it if it failed. return $task->fail( join(' ', "no rv on waiting for packet", defined($rv) ? $rv : $!) ); } ## end if (!$rv) } ## end while (@{ $ts->{need_handle...}}) return $task->handle; } ## end sub add_task # # _get_default_soc() # used in Gearman::Task->taskset only # sub _get_default_sock { my Gearman::Taskset $ts = shift; return $ts->{default_sock} if $ts->{default_sock}; my $getter = sub { my $hostport = shift; return $ts->{loaned_sock}{$hostport} || $ts->{client}->_get_js_sock($hostport); }; my ($jst, $jss) = $ts->{client}->_get_random_js_sock($getter); return unless $jss; $ts->{loaned_sock}{$jst} ||= $jss; $ts->{default_sock} = $jss; $ts->{default_sockaddr} = $jst; 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 Gearman::Taskset $ts = shift; my $hv = shift; my $cl = $ts->client; my $sock; for (my $off = 0; $off < $cl->{js_count}; $off++) { my $idx = ($hv + $off) % ($cl->{js_count}); $sock = $ts->_get_loaned_sock($cl->{job_servers}[$idx]); last; } return $sock; } ## end sub _get_hashed_sock # # _wait_for_packet($sock, $timeout) # # returns boolean when given a sock to wait on. # otherwise, return value is undefined. sub _wait_for_packet { my Gearman::Taskset $ts = shift; # socket to singularly read from my $sock = shift; my $timeout = shift; my ($res, $err); $res = Gearman::Util::read_res_packet($sock, \$err, $timeout); return $res ? $ts->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; while (my ($hp, $s) = each %{ $self->{loaned_sock} }) { $s || next; if ($sock == $s) { $hostport = $hp; last; } } ## end while (my ($hp, $s) = each...) # hopefully it solves client->get_status mismatch $hostport && return $hostport; my ($port, $iaddr) = Socket::sockaddr_in($pn); return join ':', Socket::inet_ntoa($iaddr), $port; } ## end sub _ip_port # # _fail_jshandle($shandle) # # note the failure of a task given by its jobserver-specific handle # sub _fail_jshandle { my Gearman::Taskset $ts = shift; my $shandle = shift; $shandle or Carp::croak sprintf "_fail_jshandle() called without shandle parameter"; my $task_list = $ts->{waiting}{$shandle} or Carp::croak "Uhhhh: got work_fail for unknown handle: $shandle"; my $task = shift @$task_list; ($task && ref($task) eq "Gearman::Task") or Carp::croak "Uhhhh: task_list is empty on work_fail for handle $shandle\n"; $task->fail("jshandle fail"); delete $ts->{waiting}{$shandle} unless @$task_list; } ## end sub _fail_jshandle =head2 process_packet($res, $sock) =cut sub process_packet { my Gearman::Taskset $ts = shift; my ($res, $sock) = @_; if ($res->{type} eq "job_created") { my $task = shift @{ $ts->{need_handle} }; ($task && ref($task) eq "Gearman::Task") or Carp::croak "Um, got an unexpected job_created notification"; my $shandle = ${ $res->{'blobref'} }; my $ipport = $ts->_ip_port($sock); # did sock become disconnected in the meantime? if (!$ipport) { $ts->_fail_jshandle($shandle); return 1; } $task->handle("$ipport//$shandle"); return 1 if $task->{background}; push @{ $ts->{waiting}{$shandle} ||= [] }, $task; return 1; } ## end if ($res->{type} eq "job_created") if ($res->{type} eq "work_fail") { my $shandle = ${ $res->{'blobref'} }; $ts->_fail_jshandle($shandle); return 1; } my $qr = qr/(.+?)\0/; if ($res->{type} eq "work_complete") { (${ $res->{'blobref'} } =~ /^$qr/) or Carp::croak "Bogus work_complete from server"; ${ $res->{'blobref'} } =~ s/^$qr//; my $shandle = $1; my $task_list = $ts->{waiting}{$shandle} or Carp::croak "Uhhhh: got work_complete for unknown handle: $shandle\n"; my $task = shift @$task_list; ($task && ref($task) eq "Gearman::Task") or Carp::croak "Uhhhh: task_list is empty on work_complete for handle $shandle\n"; $task->complete($res->{'blobref'}); delete $ts->{waiting}{$shandle} unless @$task_list; return 1; } ## end if ($res->{type} eq "work_complete") if ($res->{type} eq "work_exception") { # ${ $res->{'blobref'} } =~ s/^(.+?)\0// # or Carp::croak "Bogus work_exception from server"; (${ $res->{'blobref'} } =~ /^$qr/) or Carp::croak "Bogus work_exception from server"; ${ $res->{'blobref'} } =~ s/^$qr//; my $shandle = $1; my $task_list = $ts->{waiting}{$shandle} or Carp::croak "Uhhhh: got work_exception for unknown handle: $shandle\n"; my $task = $task_list->[0]; ($task && ref($task) eq "Gearman::Task") or Carp::croak "Uhhhh: task_list is empty on work_exception for handle $shandle\n"; $task->exception($res->{'blobref'}); return 1; } ## end if ($res->{type} eq "work_exception") if ($res->{type} eq "work_status") { my ($shandle, $nu, $de) = split(/\0/, ${ $res->{'blobref'} }); my $task_list = $ts->{waiting}{$shandle} or Carp::croak "Uhhhh: got work_status for unknown handle: $shandle\n"; # FIXME: the server is (probably) sending a work_status packet for each # interested client, even if the clients are the same, so probably need # to fix the server not to do that. just put this FIXME here for now, # though really it's a server issue. foreach my $task (@$task_list) { $task->status($nu, $de); } return 1; } ## end if ($res->{type} eq "work_status") Carp::croak "Unknown/unimplemented packet type: $res->{type} [${$res->{blobref}}]"; } ## end sub process_packet 1; Gearman-1.130.004/lib/Gearman/ResponseParser/000755 001751 001751 00000000000 12751342315 020734 5ustar00palikpalik000000 000000 Gearman-1.130.004/lib/Gearman/Client.pm000644 001751 001751 00000037266 12751340654 017557 0ustar00palikpalik000000 000000 package Gearman::Client; use version; $Gearman::Client::VERSION = qv("1.130.004"); 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', '10.0.0.1'); # running a single task my $result_ref = $client->do_task("add", "1+2"); print "1 + 2 = $$result_ref\n"; # waiting on a set of tasks in parallel my $taskset = $client->new_task_set; $taskset->add_task( "add" => "1+2", { on_complete => sub { ... } }); $taskset->add_task( "divide" => "5/0", { on_fail => sub { print "divide by zero error!\n"; }, }); $taskset->wait; =head1 DESCRIPTION I is a client class for the Gearman distributed job system, providing a framework for sending jobs to one or more Gearman servers. These jobs are then distributed out to a farm of workers. Callers instantiate a I object and from it dispatch single tasks, sets of tasks, or check on the status of tasks. =head1 USAGE =head2 Gearman::Client->new(%options) Creates a new I object, and returns the object. If I<%options> is provided, initializes the new client object with the settings in I<%options>, which can contain: =over 4 =item * job_servers Calls I (see below) to initialize the list of job servers. Value in this case should be an arrayref. =item * prefix Calls I (see below) to set the prefix / namespace. =back =head2 $client->job_servers(@servers) Initializes the client I<$client> with the list of job servers in I<@servers>. I<@servers> should contain a list of IP addresses, with optional port numbers. For example: $client->job_servers('127.0.0.1', '192.168.1.100:4730'); If the port number is not provided, C<4730> is used as the default. =head2 $client-Edo_task($task) =head2 $client-Edo_task($funcname, $arg, \%options) Dispatches a task and waits on the results. May either provide a L object, or the 3 arguments that the Gearman::Task constructor takes. Returns a scalar reference to the result, or undef on failure. If you provide on_complete and on_fail handlers, they're ignored, as this function currently overrides them. =head2 $client-Edispatch_background($task) =head2 $client-Edispatch_background($funcname, $arg, \%options) Dispatches a task and doesn't wait for the result. Return value is an opaque scalar that can be used to refer to the task with get_status. =head2 $taskset = $client-Enew_task_set Creates and returns a new L object. =head2 $taskset-Eadd_task($task) =head2 $taskset-Eadd_task($funcname, $arg, $uniq) =head2 $taskset-Eadd_task($funcname, $arg, \%options) Adds a task to a taskset. Three different calling conventions are available. =head2 $taskset-Ewait Waits for a response from the job server for any of the tasks listed in the taskset. Will call the I handlers for each of the tasks that have been completed, updated, etc. Doesn't return until everything has finished running or failing. =head2 $client-Eprefix($prefix) Sets the namespace / prefix for the function names. See L for more details. =head1 EXAMPLES =head2 Summation This is an example client that sends off a request to sum up a list of integers. use Gearman::Client; use Storable qw( freeze ); my $client = Gearman::Client->new; $client->job_servers('127.0.0.1'); my $tasks = $client->new_task_set; my $handle = $tasks->add_task(sum => freeze([ 3, 5 ]), { on_complete => sub { print ${ $_[0] }, "\n" } }); $tasks->wait; See the L documentation for the worker for the I function. =cut use base 'Gearman::Objects'; use fields ( 'sock_cache', # hostport -> socket '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 IO::Socket::INET; use Socket qw/ IPPROTO_TCP TCP_NODELAY SOL_SOCKET /; use Time::HiRes; sub new { my ($class, %opts) = @_; my Gearman::Client $self = $class; $self = fields::new($class) unless ref $self; $self->SUPER::new(%opts); $self->{sock_cache} = {}; $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() B Gearman::Taskset =cut sub new_task_set { my Gearman::Client $self = shift; my $taskset = Gearman::Taskset->new($self); $self->run_hook('new_task_set', $self, $taskset); return $taskset; } ## end sub new_task_set # # _job_server_status_command($command=status\n) # sub _job_server_status_command { my Gearman::Client $self = shift; my $command = shift; # e.g. "status\n". my $each_line_sub = shift; # A sub to be called on each line of response; # takes $hostport and the $line as args. my $list = $self->canonicalize_job_servers(@_); $list = $self->{job_servers} unless @$list; foreach my $hostport (@$list) { next unless grep { $_ eq $hostport } @{ $self->{job_servers} }; my $sock = $self->_get_js_sock($hostport) or next; my $rv = $sock->write($command); my $err; my @lines = Gearman::Util::read_text_status($sock, \$err); next if $err; $each_line_sub->($hostport, $_) foreach @lines; $self->_put_js_sock($hostport, $sock); } ## end foreach my $hostport (@$list) } ## end sub _job_server_status_command =head2 get_job_server_status() B {job => {capable, queued, running}} =cut sub get_job_server_status { my Gearman::Client $self = shift; my $js_status = {}; $self->_job_server_status_command( "status\n", sub { my ($hostport, $line) = @_; return unless $line =~ /^(\S+)\s+(\d+)\s+(\d+)\s+(\d+)$/; my ($job, $queued, $running, $capable) = ($1, $2, $3, $4); $js_status->{$hostport}->{$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 {job => {address, listeners, key}} =cut sub get_job_server_jobs { my Gearman::Client $self = shift; my $js_jobs = {}; $self->_job_server_status_command( "jobs\n", sub { my ($hostport, $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->{$hostport}->{$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 Gearman::Client $self = shift; my $js_clients = {}; my $client; $self->_job_server_status_command( "clients\n", sub { my ($hostport, $line) = @_; if ($line =~ /^(\S+)$/) { $client = $1; $js_clients->{$hostport}->{$client} ||= {}; } elsif ($client && $line =~ /^\s+(\S+)\s+(\S*)\s+(\S+)$/) { my ($job, $key, $address) = ($1, $2, $3); $js_clients->{$hostport}->{$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 Gearman::Task $task; if (ref $_[0]) { $task = shift; Carp::croak("Argument isn't a Gearman::Task") unless ref $task eq "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) given a (func, arg_p, opts?), B either undef (on fail) or scalarref of result =cut sub do_task { my Gearman::Client $self = shift; my Gearman::Task $task = $self->_get_task_from_args(@_); my $ret = undef; my $did_err = 0; $task->{on_complete} = sub { $ret = shift; }; $task->{on_fail} = sub { $did_err = 1; }; my $ts = $self->new_task_set; $ts->add_task($task); $ts->wait(timeout => $task->timeout); return $did_err ? undef : $ret; } ## end sub do_task =head2 dispatch_background($func, $arg_p, $opts) =head2 dispatch_background($task) dispatches job in background return the handle from the jobserver, or false if any failure =cut sub dispatch_background { my Gearman::Client $self = shift; my Gearman::Task $task = $self->_get_task_from_args(@_); $task->{background} = 1; my $ts = $self->new_task_set; return $ts->add_task($task); } ## end sub dispatch_background =head2 run_hook($name) run a hook callback if defined =cut sub run_hook { my Gearman::Client $self = shift; my $hookname = shift || return; my $hook = $self->{hooks}->{$hookname}; return unless $hook; eval { $hook->(@_) }; warn "Gearman::Client hook '$hookname' threw error: $@\n" if $@; } ## end sub run_hook =head2 add_hook($name, $cb) add a hook =cut sub add_hook { my Gearman::Client $self = shift; my $hookname = shift || return; if (@_) { $self->{hooks}->{$hookname} = shift; } else { delete $self->{hooks}->{$hookname}; } } ## end sub add_hook =head2 get_status($handle) The Gearman Server will assign a scalar job handle when you request a background job with dispatch_background. Save this scalar, and use it later in order to request the status of this job. B L on success =cut sub get_status { my Gearman::Client $self = shift; my $handle = shift; $handle || return; my ($hostport, $shandle) = split(m!//!, $handle); #TODO simple check for $hostport in job_server doesn't work if # $hostport is not contained in job_servers # job_servers = ["localhost:4730"] # handle = 127.0.0.1:4730//H:... # # hopefully commit 58e2aa5 solves this TODO return undef unless grep { $hostport eq $_ } @{ $self->{job_servers} }; my $sock = $self->_get_js_sock($hostport) or return undef; my $req = Gearman::Util::pack_req_command("get_status", $shandle); my $len = length($req); my $rv = $sock->write($req, $len); my $err; my $res = Gearman::Util::read_res_packet($sock, \$err); if ($res && $res->{type} eq "error") { Carp::croak "Error packet from server after get_status: ${$res->{blobref}}\n"; } return undef unless $res && $res->{type} eq "status_res"; my @args = split(/\0/, ${ $res->{blobref} }); return undef unless $args[0]; shift @args; $self->_put_js_sock($hostport, $sock); return Gearman::JobStatus->new(@args); } ## end sub get_status # # _option_request($sock, $option) # sub _option_request { my Gearman::Client $self = shift; my $sock = shift; my $option = shift; my $req = Gearman::Util::pack_req_command("option_req", $option); my $len = length($req); my $rv = $sock->write($req, $len); my $err; my $res = Gearman::Util::read_res_packet($sock, \$err, $self->{command_timeout}); return unless $res; return 0 if $res->{type} eq "error"; return 1 if $res->{type} eq "option_res"; warn "Got unknown response to option request: $res->{type}\n"; return; } ## end sub _option_request # # _get_js_sock($hostport) # # returns a socket from the cache. it should be returned to the # cache with _put_js_sock. the hostport isn't verified. the caller # should verify that $hostport is in the set of jobservers. sub _get_js_sock { my Gearman::Client $self = shift; my $hostport = shift; if (my $sock = delete $self->{sock_cache}{$hostport}) { return $sock if $sock->connected; } my $sockinfo = $self->{sock_info}{$hostport} ||= {}; my $disabled_until = $sockinfo->{disabled_until}; return if defined $disabled_until && $disabled_until > Time::HiRes::time(); my $sock = IO::Socket::INET->new( PeerAddr => $hostport, Timeout => 1 ); unless ($sock) { my $count = ++$sockinfo->{failed_connects}; my $disable_for = $count**2; my $max = $self->{backoff_max}; $disable_for = $disable_for > $max ? $max : $disable_for; $sockinfo->{disabled_until} = $disable_for + Time::HiRes::time(); return; } ## end unless ($sock) setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or Carp::croak "setsockopt: $!"; $sock->autoflush(1); # If exceptions support is to be requested, and the request fails, disable # exceptions for this client. if ($self->{exceptions} && !$self->_option_request($sock, 'exceptions')) { warn "Exceptions support denied by server, disabling.\n"; $self->{exceptions} = 0; } delete $sockinfo->{failed_connects}; # Success, mark the socket as such. delete $sockinfo->{disabled_until}; return $sock; } ## end sub _get_js_sock # # _put_js_sock($hostport, $sock) # # way for a caller to give back a socket it previously requested. # the $hostport isn't verified, so the caller should verify the # $hostport is still in the set of jobservers. sub _put_js_sock { my Gearman::Client $self = shift; my ($hostport, $sock) = @_; $self->{sock_cache}{$hostport} ||= $sock; } ## end sub _put_js_sock sub _get_random_js_sock { my Gearman::Client $self = shift; my $getter = shift; return undef unless $self->{js_count}; $getter ||= sub { my $hostport = shift; return $self->_get_js_sock($hostport); }; my $ridx = int(rand($self->{js_count})); for (my $try = 0; $try < $self->{js_count}; $try++) { my $aidx = ($ridx + $try) % $self->{js_count}; my $hostport = $self->{job_servers}[$aidx]; my $sock = $getter->($hostport) or next; return ($hostport, $sock); } ## end for (my $try = 0; $try ...) return (); } ## end sub _get_random_js_sock 1; __END__ =head1 COPYRIGHT Copyright 2006-2007 Six Apart, Ltd. License granted to use/distribute under the same terms as Perl itself. =head1 WARRANTY This is free software. This comes with no warranty whatsoever. =head1 AUTHORS Brad Fitzpatrick () Jonathan Steinert () Alexei Pastuchov () co-maintainer =head1 REPOSITORY L Gearman-1.130.004/lib/Gearman/ResponseParser/Taskset.pm000644 001751 001751 00000001745 12751340654 022723 0ustar00palikpalik000000 000000 package Gearman::ResponseParser::Taskset; use version; $Gearman::ResponseParser::Taskset::VERSION = qv("1.130.004"); use strict; use warnings; use base 'Gearman::ResponseParser'; =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}; ref($ts) eq "Gearman::Taskset" || die "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;