Gearman-Server-v1.130.1/0000755000175000017500000000000012741117575013655 5ustar palikpalikGearman-Server-v1.130.1/META.json0000664000175000017500000000204512741117575015301 0ustar palikpalik{ "abstract" : "function call \"router\" and load balancer", "author" : [ "Brad Fitzpatrick (brad@danga.com), Brad Whitaker (whitaker@danga.com)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.82, CPAN::Meta::Converter version 2.120351", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Gearman-Server", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0", "Test::Script" : "1.12", "version" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Danga::Socket" : "1.52", "Gearman::Util" : "0", "version" : "0" } } }, "release_status" : "stable", "version" : "v1.130.1" } Gearman-Server-v1.130.1/MANIFEST.SKIP0000644000175000017500000000065512443453404015552 0ustar palikpalik# Avoid version control files. \bRCS\b \bCVS\b ,v$ \B\.svn\b \.git # 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-Server-v1.130.1/lib/0000755000175000017500000000000012741117575014423 5ustar palikpalikGearman-Server-v1.130.1/lib/Gearman/0000755000175000017500000000000012741117575015775 5ustar palikpalikGearman-Server-v1.130.1/lib/Gearman/Server/0000755000175000017500000000000012741117575017243 5ustar palikpalikGearman-Server-v1.130.1/lib/Gearman/Server/Client.pm0000644000175000017500000005774512741116550021031 0ustar palikpalikpackage Gearman::Server::Client; use version; $Gearman::Server::Client::VERSION = qv("v1.130.1"); use strict; use warnings; =head1 NAME Gearman::Server::Client - client for gearmand =head1 NAME Used by L to instantiate connections from clients. Clients speak either a binary protocol, for normal operation (calling functions, grabbing function call requests, returning function values, etc), or a text-based line protocol, for relatively rare administrative / monitoring commands. The binary protocol commands aren't currently documented. (FIXME) But they're well-implemented in L, L, and L, if that's any consolation. The line-based administrative commands are documented below. =cut use Danga::Socket; use base 'Danga::Socket'; use fields ( # { $job_name => $timeout } $timeout can be undef indicating no timeout 'can_do', 'can_do_list', 'can_do_iter', 'fast_read', 'fast_buffer', 'read_buf', # 0/1: they've said they're sleeping and we haven't woken them up 'sleeping', # Timer for job cancellation 'timer', # { $job_handle => Job } 'doing', # opaque string, no whitespace. workers give this so checker scripts # can tell apart the same worker connected to multiple jobservers. 'client_id', # pointer up to client's server 'server', 'options', 'jobs_done_since_sleep', ); # 60k read buffer default, similar to perlbal's backend read. use constant READ_SIZE => 60 * 1024; use constant MAX_READ_SIZE => 512 * 1024; # Class Method: sub new { my Gearman::Server::Client $self = shift; my ($sock, $server) = @_; $self = fields::new($self) unless ref $self; $self->SUPER::new($sock); # Number of bytes to read as fast as we can (don't try to process them) $self->{fast_read} = undef; # Array of buffers used during fast read operation $self->{fast_buffer} = []; $self->{read_buf} = ''; $self->{sleeping} = 0; $self->{can_do} = {}; # handle -> Job $self->{doing} = {}; $self->{can_do_list} = []; # numeric iterator for where we start looking for jobs $self->{can_do_iter} = 0; $self->{client_id} = "-"; $self->{server} = $server; $self->{options} = {}; $self->{jobs_done_since_sleep} = 0; return $self; } ## end sub new sub option { my Gearman::Server::Client $self = shift; my $option = shift; return $self->{options}->{$option}; } ## end sub option sub close { my Gearman::Server::Client $self = shift; my $doing = $self->{doing}; while (my ($handle, $job) = each %$doing) { my $msg = Gearman::Util::pack_res_command("work_fail", $handle); $job->relay_to_listeners($msg); $job->note_finished(0); } # Clear the doing list, since it may contain a set of jobs which contain # references back to us. %$doing = (); # Remove self from sleepers, otherwise it will be leaked if another worker # for the job never connects. my $sleepers = $self->{server}{sleepers}; my $sleepers_list = $self->{server}{sleepers_list}; for my $job (@{ $self->{can_do_list} }) { my $sleeping = $sleepers->{$job}; delete $sleeping->{$self}; my $new_sleepers_list; for my $client (@{ $sleepers_list->{$job} }) { next unless $client; push @{$new_sleepers_list}, $client unless $sleeping->{$client}; } if ($new_sleepers_list) { $self->{server}{sleepers_list}->{$job} = $new_sleepers_list; } else { delete $self->{server}{sleepers_list}->{$job}; } delete $sleepers->{$job} unless %$sleeping; } ## end for my $job (@{ $self->...}) $self->{server}->note_disconnected_client($self); $self->CMD_reset_abilities; $self->SUPER::close; } ## end sub close # Client sub event_read { my Gearman::Server::Client $self = shift; my $read_size = $self->{fast_read} || READ_SIZE; my $bref = $self->read($read_size); # Delay close till after buffers are written on EOF. If we are unable # to write 'err' or 'hup' will be thrown and we'll close faster. return $self->write(sub { $self->close }) unless defined $bref; if ($self->{fast_read}) { push @{ $self->{fast_buffer} }, $$bref; $self->{fast_read} -= length($$bref); # If fast_read is still positive, then we need to read more data return if ($self->{fast_read} > 0); # Append the whole giant read buffer to our main read buffer $self->{read_buf} .= join('', @{ $self->{fast_buffer} }); # Reset the fast read state for next time. $self->{fast_buffer} = []; $self->{fast_read} = undef; } ## end if ($self->{fast_read}) else { # Exact read size length likely means we have more sitting on the # socket. Buffer up to half a meg in one go. if (length($$bref) == READ_SIZE) { my $limit = int(MAX_READ_SIZE / READ_SIZE); my @crefs = ($$bref); while (my $cref = $self->read(READ_SIZE)) { push(@crefs, $$cref); last if (length($$cref) < READ_SIZE || $limit-- < 1); } $bref = \join('', @crefs); } ## end if (length($$bref) == ...) $self->{read_buf} .= $$bref; } ## end else [ if ($self->{fast_read})] my $found_cmd; do { $found_cmd = 1; my $blen = length($self->{read_buf}); if ($self->{read_buf} =~ /^\0REQ(.{8,8})/s) { my ($cmd, $len) = unpack("NN", $1); if ($blen < $len + 12) { # Start a fast read loop to get all the data we need, less # what we already have in the buffer. $self->{fast_read} = $len + 12 - $blen; return; } ## end if ($blen < $len + 12) $self->process_cmd($cmd, substr($self->{read_buf}, 12, $len)); # and slide down buf: $self->{read_buf} = substr($self->{read_buf}, 12 + $len); } ## end if ($self->{read_buf} ...) elsif ($self->{read_buf} =~ s/^(\w.+?)?\r?\n//) { # ASCII command case (useful for telnetting in) my $line = $1; $self->process_line($line); } ## end elsif ($self->{read_buf} ...) else { $found_cmd = 0; } } while ($found_cmd); } ## end sub event_read sub event_write { my $self = shift; my $done = $self->write(undef); $self->watch_write(0) if $done; } # Line based command processor sub process_line { my Gearman::Server::Client $self = shift; my $line = shift; if ($line && $line =~ /^(\w+)\s*(.*)/) { my ($cmd, $args) = ($1, $2); $cmd = lc($cmd); my $code = $self->can("TXTCMD_$cmd"); if ($code) { $code->($self, $args); return; } } ## end if ($line && $line =~ ...) return $self->err_line('unknown_command'); } ## end sub process_line =head1 Binary Protocol Structure All binary protocol exchanges between clients (which can be callers, workers, or both) and the Gearman server have common packet header: 4 byte magic -- either "\0REQ" for requests to the server, or "\0RES" for responses from the server 4 byte type -- network order integer, representing the packet type 4 byte length -- network order length, for data segment. data -- optional, if length is non-zero =head1 Binary Protocol Commands =head2 echo_req (type=16) A debug command. The server will reply with the same data, in a echo_res (type=17) packet. =head2 (and many more...) FIXME: auto-generate protocol docs from internal Gearman::Util table, once annotated with some English? =cut sub CMD_echo_req { my Gearman::Server::Client $self = shift; my $blobref = shift; return $self->res_packet("echo_res", $$blobref); } ## end sub CMD_echo_req sub CMD_work_status { my Gearman::Server::Client $self = shift; my $ar = shift; my ($handle, $nu, $de) = split(/\0/, $$ar); my $job = $self->{doing}{$handle}; return $self->error_packet("not_worker") unless $job && $job->worker == $self; my $msg = Gearman::Util::pack_res_command("work_status", $$ar); $job->relay_to_listeners($msg); $job->status([$nu, $de]); return 1; } ## end sub CMD_work_status sub CMD_work_complete { my Gearman::Server::Client $self = shift; my $ar = shift; $$ar =~ s/^(.+?)\0//; my $handle = $1; my $job = delete $self->{doing}{$handle}; return $self->error_packet("not_worker") unless $job && $job->worker == $self; my $msg = Gearman::Util::pack_res_command("work_complete", join("\0", $handle, $$ar)); $job->relay_to_listeners($msg); $job->note_finished(1); if (my $timer = $self->{timer}) { $timer->cancel; $self->{timer} = undef; } return 1; } ## end sub CMD_work_complete sub CMD_work_fail { my Gearman::Server::Client $self = shift; my $ar = shift; my $handle = $$ar; my $job = delete $self->{doing}{$handle}; return $self->error_packet("not_worker") unless $job && $job->worker == $self; my $msg = Gearman::Util::pack_res_command("work_fail", $handle); $job->relay_to_listeners($msg); $job->note_finished(1); if (my $timer = $self->{timer}) { $timer->cancel; $self->{timer} = undef; } return 1; } ## end sub CMD_work_fail sub CMD_work_exception { my Gearman::Server::Client $self = shift; my $ar = shift; $$ar =~ s/^(.+?)\0//; my $handle = $1; my $job = $self->{doing}{$handle}; return $self->error_packet("not_worker") unless $job && $job->worker == $self; my $msg = Gearman::Util::pack_res_command("work_exception", join("\0", $handle, $$ar)); $job->relay_to_option_listeners($msg, "exceptions"); return 1; } ## end sub CMD_work_exception sub CMD_pre_sleep { my Gearman::Server::Client $self = shift; $self->{'sleeping'} = 1; $self->{server}->on_client_sleep($self); return 1; } ## end sub CMD_pre_sleep sub CMD_grab_job { my Gearman::Server::Client $self = shift; my $job; my $can_do_size = scalar @{ $self->{can_do_list} }; unless ($can_do_size) { $self->res_packet("no_job"); return; } # the offset where we start asking for jobs, to prevent starvation # of some job types. $self->{can_do_iter} = ($self->{can_do_iter} + 1) % $can_do_size; my $tried = 0; while ($tried < $can_do_size) { my $idx = ($tried + $self->{can_do_iter}) % $can_do_size; $tried++; my $job_to_grab = $self->{can_do_list}->[$idx]; $job = $self->{server}->grab_job($job_to_grab) or next; $job->worker($self); $self->{doing}{ $job->handle } = $job; my $timeout = $self->{can_do}->{$job_to_grab}; if (defined $timeout) { my $timer = Danga::Socket->AddTimer( $timeout, sub { return $self->error_packet("not_worker") unless $job->worker == $self; my $msg = Gearman::Util::pack_res_command("work_fail", $job->handle); $job->relay_to_listeners($msg); $job->note_finished(1); $job->clear_listeners; $self->{timer} = undef; } ); $self->{timer} = $timer; } ## end if (defined $timeout) return $self->res_packet("job_assign", join("\0", $job->handle, $job->func, ${ $job->argref },)); } ## end while ($tried < $can_do_size) $self->res_packet("no_job"); } ## end sub CMD_grab_job sub CMD_can_do { my Gearman::Server::Client $self = shift; my $ar = shift; $self->{can_do}->{$$ar} = undef; $self->_setup_can_do_list; } ## end sub CMD_can_do sub CMD_can_do_timeout { my Gearman::Server::Client $self = shift; my $ar = shift; my ($task, $timeout) = $$ar =~ m/([^\0]+)(?:\0(.+))?/; if (defined $timeout) { $self->{can_do}->{$task} = $timeout; } else { $self->{can_do}->{$task} = undef; } $self->_setup_can_do_list; } ## end sub CMD_can_do_timeout sub CMD_option_req { my Gearman::Server::Client $self = shift; my $ar = shift; my $success = sub { return $self->res_packet("option_res", $$ar); }; if ($$ar eq 'exceptions') { $self->{options}->{exceptions} = 1; return $success->(); } return $self->error_packet("unknown_option"); } ## end sub CMD_option_req sub CMD_set_client_id { my Gearman::Server::Client $self = shift; my $ar = shift; $self->{client_id} = $$ar; $self->{client_id} =~ s/\s+//g; $self->{client_id} = "-" unless length $self->{client_id}; } ## end sub CMD_set_client_id sub CMD_cant_do { my Gearman::Server::Client $self = shift; my $ar = shift; delete $self->{can_do}->{$$ar}; $self->_setup_can_do_list; } ## end sub CMD_cant_do sub CMD_get_status { my Gearman::Server::Client $self = shift; my $ar = shift; my $job = $self->{server}->job_by_handle($$ar); # handles can't contain nulls return if $$ar =~ /\0/; my ($known, $running, $num, $den); $known = 0; $running = 0; if ($job) { $known = 1; $running = $job->worker ? 1 : 0; if (my $stat = $job->status) { ($num, $den) = @$stat; } } ## end if ($job) $num = '' unless defined $num; $den = '' unless defined $den; $self->res_packet("status_res", join("\0", $$ar, $known, $running, $num, $den)); } ## end sub CMD_get_status sub CMD_reset_abilities { my Gearman::Server::Client $self = shift; $self->{can_do} = {}; $self->_setup_can_do_list; } ## end sub CMD_reset_abilities sub _setup_can_do_list { my Gearman::Server::Client $self = shift; $self->{can_do_list} = [keys %{ $self->{can_do} }]; $self->{can_do_iter} = 0; } sub CMD_submit_job { push @_, 1; &_cmd_submit_job; } sub CMD_submit_job_bg { push @_, 0; &_cmd_submit_job; } sub CMD_submit_job_high { push @_, 1, 1; &_cmd_submit_job; } sub _cmd_submit_job { my Gearman::Server::Client $self = shift; my $ar = shift; my $subscribe = shift; my $high_pri = shift; return $self->error_packet("invalid_args", "No func/uniq header [$$ar].") unless $$ar =~ s/^(.+?)\0(.*?)\0//; my ($func, $uniq) = ($1, $2); my $job = Gearman::Server::Job->new($self->{server}, $func, $uniq, $ar, $high_pri); if ($subscribe) { $job->add_listener($self); } else { # background mode $job->require_listener(0); } $self->res_packet("job_created", $job->handle); $self->{server}->wake_up_sleepers($func); } ## end sub _cmd_submit_job sub res_packet { my Gearman::Server::Client $self = shift; my ($code, $arg) = @_; $self->write(Gearman::Util::pack_res_command($code, $arg)); return 1; } ## end sub res_packet sub error_packet { my Gearman::Server::Client $self = shift; my ($code, $msg) = @_; $self->write(Gearman::Util::pack_res_command("error", "$code\0$msg")); return 0; } ## end sub error_packet sub process_cmd { my Gearman::Server::Client $self = shift; my $cmd = shift; my $blob = shift; my $cmd_name = "CMD_" . Gearman::Util::cmd_name($cmd); my $ret = eval { $self->$cmd_name(\$blob); }; return $ret unless $@; warn "Error: $@\n"; return $self->error_packet("server_error", $@); } ## end sub process_cmd sub event_err { my $self = shift; $self->close; } sub event_hup { my $self = shift; $self->close; } ############################################################################ =head1 Line based commands These commands are used for administrative or statistic tasks to be done on the gearman server. They can be entered using a line based client (telnet, etc.) by connecting to the listening port (7003) and are also intended to be machine parsable. =head2 "workers" Emits list of registered workers, their fds, IPs, client ids, and list of registered abilities (function names they can do). Of format: fd ip.x.y.z client_id : func_a func_b func_c fd ip.x.y.z client_id : func_a func_b func_c fd ip.x.y.z client_id : func_a func_b func_c . It ends with a line with just a period. =cut sub TXTCMD_workers { my Gearman::Server::Client $self = shift; foreach my $cl (sort { $a->{fd} <=> $b->{fd} } $self->{server}->clients) { my $fd = $cl->{fd}; $self->write("$fd " . $cl->peer_ip_string . " $cl->{client_id} : @{$cl->{can_do_list}}\n"); } ## end foreach my $cl (sort { $a->...}) $self->write(".\n"); } ## end sub TXTCMD_workers =head2 "status" The output format of this function is tab separated columns as follows, followed by a line consisting of a fullstop and a newline (".\n") to indicate the end of output. =over =item Function name A string denoting the name of the function of the job =item Number in queue A positive integer indicating the total number of jobs for this function in the queue. This includes currently running ones as well (next column) =item Number of jobs running A positive integer showing how many jobs of this function are currently running =item Number of capable workers A positive integer denoting the maximum possible count of workers that could be doing this job. Though they may not all be working on it due to other tasks holding them busy. =back =cut sub TXTCMD_status { my Gearman::Server::Client $self = shift; my %funcs; # func -> 1 (set of all funcs to display) # keep track of how many workers can do which functions my %can; foreach my $client ($self->{server}->clients) { foreach my $func (@{ $client->{can_do_list} }) { $can{$func}++; $funcs{$func} = 1; } } ## end foreach my $client ($self->...) my %queued_funcs; my %running_funcs; foreach my $job ($self->{server}->jobs) { my $func = $job->func; $queued_funcs{$func}++; if ($job->worker) { $running_funcs{$func}++; } } ## end foreach my $job ($self->{server...}) # also include queued functions (even if there aren't workers) # in our list of funcs to show. $funcs{$_} = 1 foreach keys %queued_funcs; foreach my $func (sort keys %funcs) { my $queued = $queued_funcs{$func} || 0; my $running = $running_funcs{$func} || 0; my $can = $can{$func} || 0; $self->write("$func\t$queued\t$running\t$can\n"); } ## end foreach my $func (sort keys...) $self->write(".\n"); } ## end sub TXTCMD_status =head2 "jobs" Output format is zero or more lines of: [Job function name]\t[Uniq (coalescing) key]\t[Worker address]\t[Number of listeners]\n Follows by a single line of: .\n \t is a literal tab character \n is perl's definition of newline (literal \n on linux, something else on win32) =cut sub TXTCMD_jobs { my Gearman::Server::Client $self = shift; foreach my $job ($self->{server}->jobs) { my $func = $job->func; my $uniq = $job->uniq; my $worker_addr = "-"; if (my $worker = $job->worker) { $worker_addr = $worker->peer_addr_string; } my $listeners = $job->listeners; $self->write("$func\t$uniq\t$worker_addr\t$listeners\n"); } ## end foreach my $job ($self->{server...}) $self->write(".\n"); } ## end sub TXTCMD_jobs =head2 "clients" Output format is zero or more sections of: =over One line of: [Client Address]\n Followed by zero or more lines of: \t[Job Function]\t[Uniq (coalescing) key]\t[Worker Address]\n =back Follows by a single line of: .\n \t is a literal tab character \n is perl's definition of newline (literal \n on linux, something else on win32) =cut sub TXTCMD_clients { my Gearman::Server::Client $self = shift; my %jobs_by_client; foreach my $job ($self->{server}->jobs) { foreach my $client ($job->listeners) { my $ent = $jobs_by_client{$client} ||= []; push @$ent, $job; } } ## end foreach my $job ($self->{server...}) foreach my $client ($self->{server}->clients) { my $client_addr = $client->peer_addr_string; $self->write("$client_addr\n"); my $jobs = $jobs_by_client{$client} || []; foreach my $job (@$jobs) { my $func = $job->func; my $uniq = $job->uniq; my $worker_addr = "-"; if (my $worker = $job->worker) { $worker_addr = $worker->peer_addr_string; } $self->write("\t$func\t$uniq\t$worker_addr\n"); } ## end foreach my $job (@$jobs) } ## end foreach my $client ($self->...) $self->write(".\n"); } ## end sub TXTCMD_clients sub TXTCMD_gladiator { my Gearman::Server::Client $self = shift; my $args = shift || ""; my $has_gladiator = eval "use Devel::Gladiator; use Devel::Peek; 1;"; if ($has_gladiator) { my $all = Devel::Gladiator::walk_arena(); my %ct; foreach my $it (@$all) { $ct{ ref $it }++; if (ref $it eq "CODE") { my $name = Devel::Peek::CvGV($it); $ct{$name}++ if $name =~ /ANON/; } } ## end foreach my $it (@$all) $all = undef; # required to free memory foreach my $n (sort { $ct{$a} <=> $ct{$b} } keys %ct) { next unless $ct{$n} > 1 || $args eq "all"; $self->write(sprintf("%7d $n\n", $ct{$n})); } } ## end if ($has_gladiator) $self->write(".\n"); } ## end sub TXTCMD_gladiator =head2 "maxqueue" function [max_queue_size] For a given function of job, the maximum queue size is adjusted to be max_queue_size jobs long. A negative value indicates unlimited queue size. If the max_queue_size value is not supplied then it is unset (and the default maximum queue size will apply to this function). This function will return OK upon success, and will return ERR incomplete_args upon an invalid number of arguments. =cut sub TXTCMD_maxqueue { my Gearman::Server::Client $self = shift; my $args = shift; my ($func, $max) = split /\s+/, $args; unless (length $func) { return $self->err_line('incomplete_args'); } $self->{server}->set_max_queue($func, $max); $self->write("OK\n"); } ## end sub TXTCMD_maxqueue =head2 "shutdown" ["graceful"] Close the server. Or "shutdown graceful" to close the listening socket, then close the server when traffic has died away. =cut sub TXTCMD_shutdown { my Gearman::Server::Client $self = shift; my $args = shift; if ($args eq "graceful") { $self->write("OK\n"); Gearmand::shutdown_graceful(); } elsif (!$args) { $self->write("OK\n"); exit 0; } else { $self->err_line('unknown_args'); } } ## end sub TXTCMD_shutdown =head2 "version" Returns server version. =cut sub TXTCMD_version { my Gearman::Server::Client $self = shift; $self->write("$Gearman::Server::VERSION\n"); } sub err_line { my Gearman::Server::Client $self = shift; my $err_code = shift; my $err_text = { 'unknown_command# numeric iterator for where we start looking for jobl' => "Unknown server command", 'unknown_args' => "Unknown arguments to server command", 'incomplete_args' => "An incomplete set of arguments was sent to this command", }->{$err_code}; $self->write("ERR $err_code " . eurl($err_text) . "\r\n"); return 0; } ## end sub err_line sub eurl { my $a = $_[0]; $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg; $a =~ tr/ /+/; return $a; } ## end sub eurl 1; Gearman-Server-v1.130.1/lib/Gearman/Server/Listener.pm0000644000175000017500000000363512741116550021365 0ustar palikpalikpackage Gearman::Server::Listener; use version; $Gearman::Server::Listener::VERSION = qv("v1.130.1"); use strict; use warnings; use base 'Danga::Socket'; use fields qw/ server accept_per_loop /; use Errno qw(EAGAIN); use Socket qw/ IPPROTO_TCP TCP_NODELAY SOL_SOCKET SO_ERROR /; sub new { my Gearman::Server::Listener $self = shift; my $sock = shift; my $server = shift; my %opts = @_; my $accept_per_loop = delete $opts{accept_per_loop}; warn "Extra options passed into new: " . join(', ', keys %opts) . "\n" if keys %opts; $accept_per_loop = 10 unless defined $accept_per_loop and $accept_per_loop >= 1; $self = fields::new($self) unless ref $self; # make sure provided listening socket is non-blocking IO::Handle::blocking($sock, 0); $self->SUPER::new($sock); $self->{server} = $server; $self->{accept_per_loop} = int($accept_per_loop); $self->watch_read(1); return $self; } ## end sub new sub event_read { my Gearman::Server::Listener $self = shift; my $listen_sock = $self->sock; local $!; local $SIG{PIPE} = "IGNORE"; my $remaining = $self->{accept_per_loop}; while (my $csock = $listen_sock->accept) { IO::Handle::blocking($csock, 0); setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; my $server = $self->{server}; $server->debug( sprintf("Listen child making a Client for %d.", fileno($csock))); $server->new_client($csock); return unless $remaining-- > 0; } ## end while (my $csock = $listen_sock...) return if $! == EAGAIN; warn "Error accepting incoming connection: $!\n"; $self->watch_read(0); Danga::Socket->AddTimer( .1, sub { $self->watch_read(1); } ); } ## end sub event_read 1; Gearman-Server-v1.130.1/lib/Gearman/Server/Job.pm0000644000175000017500000000644712741116550020316 0ustar palikpalikpackage Gearman::Server::Job; use version; $Gearman::Server::Job::VERSION = qv("v1.130.1"); use strict; use warnings; use Gearman::Server::Client; use Scalar::Util; use Sys::Hostname; use fields ( 'func', 'uniq', 'argref', 'listeners', # arrayref of interested Clients 'worker', 'handle', 'status', # [1, 100] 'require_listener', 'server', # Gearman::Server that owns us ); sub new { my Gearman::Server::Job $self = shift; my ($server, $func, $uniq, $argref, $highpri) = @_; $self = fields::new($self) unless ref $self; # if they specified a uniq, see if we have a dup job running already # to merge with if (length($uniq)) { # a unique value of "-" means "use my args as my unique key" $uniq = $$argref if $uniq eq "-"; if (my $job = $server->job_of_unique($func, $uniq)) { # found a match return $job; } # create a new key $server->set_unique_job($func, $uniq => $self); } $self->{'server'} = $server; $self->{'func'} = $func; $self->{'uniq'} = $uniq; $self->{'argref'} = $argref; $self->{'require_listener'} = 1; $self->{'listeners'} = []; $self->{'handle'} = $server->new_job_handle; $server->enqueue_job($self, $highpri); return $self; } sub add_listener { my Gearman::Server::Job $self = shift; my Gearman::Server::Client $li = shift; push @{$self->{listeners}}, $li; Scalar::Util::weaken($self->{listeners}->[-1]); } sub relay_to_listeners { my Gearman::Server::Job $self = shift; foreach my Gearman::Server::Client $c (@{$self->{listeners}}) { next if !$c || $c->{closed}; $c->write($_[0]); } } sub relay_to_option_listeners { my Gearman::Server::Job $self = shift; my $option = $_[1]; foreach my Gearman::Server::Client $c (@{$self->{listeners}}) { next if !$c || $c->{closed}; next unless $c->option($option); $c->write($_[0]); } } sub clear_listeners { my Gearman::Server::Job $self = shift; $self->{listeners} = []; } sub listeners { my Gearman::Server::Job $self = shift; return @{$self->{listeners}}; } sub uniq { my Gearman::Server::Job $self = shift; return $self->{uniq}; } sub note_finished { my Gearman::Server::Job $self = shift; my $success = shift; $self->{server}->note_job_finished($self); if ($Gearmand::graceful_shutdown) { Gearmand::shutdown_if_calm(); } } # accessors: sub worker { my Gearman::Server::Job $self = shift; return $self->{'worker'} unless @_; return $self->{'worker'} = shift; } sub require_listener { my Gearman::Server::Job $self = shift; return $self->{'require_listener'} unless @_; return $self->{'require_listener'} = shift; } # takes arrayref of [numerator,denominator] sub status { my Gearman::Server::Job $self = shift; return $self->{'status'} unless @_; return $self->{'status'} = shift; } sub handle { my Gearman::Server::Job $self = shift; return $self->{'handle'}; } sub func { my Gearman::Server::Job $self = shift; return $self->{'func'}; } sub argref { my Gearman::Server::Job $self = shift; return $self->{'argref'}; } 1; Gearman-Server-v1.130.1/lib/Gearman/Server.pm0000644000175000017500000003170712741117333017601 0ustar palikpalikpackage Gearman::Server; use version; $Gearman::Server::VERSION = qv("v1.130.1"); use strict; use warnings; =head1 NAME Gearman::Server - function call "router" and load balancer =head1 DESCRIPTION You run a Gearman server (or more likely, many of them for both high-availability and load balancing), then have workers (using L from the Gearman module, or libraries for other languages) register their ability to do certain functions to all of them, and then clients (using L, L, etc) request work to be done from one of the Gearman servers. The servers connect them, routing function call requests to the appropriate workers, multiplexing responses to duplicate requests as requested, etc. More than likely, you want to use the provided L wrapper script, and not use Gearman::Server directly. =cut use Carp qw(croak); use Gearman::Server::Client; use Gearman::Server::Listener; use Gearman::Server::Job; use IO::Handle (); use Socket qw/ IPPROTO_TCP SOL_SOCKET SOCK_STREAM AF_UNIX SOCK_STREAM PF_UNSPEC /; use Sys::Hostname (); use fields ( 'client_map', # fd -> Client 'sleepers', # func -> { "Client=HASH(0xdeadbeef)" => Client } 'sleepers_list', # func -> [ Client, ... ], ... 'job_queue', # job_name -> [Job, Job*] (key only exists if non-empty) 'job_of_handle', # handle -> Job 'max_queue', # func -> configured max jobqueue size 'job_of_uniq', # func -> uniq -> Job 'handle_ct', # atomic counter 'handle_base', # atomic counter 'listeners', # arrayref of listener objects 'wakeup', # number of workers to wake 'wakeup_delay', # seconds to wait before waking more workers 'wakeup_timers', # func -> timer, timer to be canceled or adjusted # when job grab/inject is called ); =head1 METHODS =head2 new $server_object = Gearman::Server->new( %options ) Creates and returns a new Gearman::Server object, which attaches itself to the Danga::Socket event loop. The server will begin operating when the Danga::Socket runloop is started. This means you need to start up the runloop before anything will happen. Options: =over =item port Specify a port which you would like the Gearman::Server to listen on for TCP connections (not necessary, but useful) =back =cut sub new { my ($class, %opts) = @_; my $self = ref $class ? $class : fields::new($class); $self->{client_map} = {}; $self->{sleepers} = {}; $self->{sleepers_list} = {}; $self->{job_queue} = {}; $self->{job_of_handle} = {}; $self->{max_queue} = {}; $self->{job_of_uniq} = {}; $self->{listeners} = []; $self->{wakeup} = 3; $self->{wakeup_delay} = .1; $self->{wakeup_timers} = {}; $self->{handle_ct} = 0; $self->{handle_base} = "H:" . Sys::Hostname::hostname() . ":"; my $port = delete $opts{port}; my $wakeup = delete $opts{wakeup}; if (defined $wakeup) { die "Invalid value passed in wakeup option" if $wakeup < 0 && $wakeup != -1; $self->{wakeup} = $wakeup; } my $wakeup_delay = delete $opts{wakeup_delay}; if (defined $wakeup_delay) { die "Invalid value passed in wakeup_delay option" if $wakeup_delay < 0 && $wakeup_delay != -1; $self->{wakeup_delay} = $wakeup_delay; } croak("Unknown options") if %opts; $self->create_listening_sock($port); return $self; } ## end sub new sub debug { my ($self, $msg) = @_; #warn "$msg\n"; } =head2 create_listening_sock $server_object->create_listening_sock( $portnum, \%options ) Add a TCP port listener for incoming Gearman worker and client connections. Options: =over 4 =item accept_per_loop =item local_addr Bind socket to only this address. =back =cut sub create_listening_sock { my ($self, $portnum, %opts) = @_; my $accept_per_loop = delete $opts{accept_per_loop}; my $local_addr = delete $opts{local_addr}; warn "Extra options passed into create_listening_sock: " . join(', ', keys %opts) . "\n" if keys %opts; my $ssock = IO::Socket::INET->new( LocalPort => $portnum, Type => SOCK_STREAM, Proto => IPPROTO_TCP, Blocking => 0, Reuse => 1, Listen => 1024, ($local_addr ? (LocalAddr => $local_addr) : ()) ) or die "Error creating socket: $@\n"; my $listeners = $self->{listeners}; push @$listeners, Gearman::Server::Listener->new($ssock, $self, accept_per_loop => $accept_per_loop); return $ssock; } ## end sub create_listening_sock sub new_client { my ($self, $sock) = @_; my $client = Gearman::Server::Client->new($sock, $self); $client->watch_read(1); $self->{client_map}{ $client->{fd} } = $client; } ## end sub new_client sub note_disconnected_client { my ($self, $client) = @_; delete $self->{client_map}{ $client->{fd} }; } sub clients { my $self = shift; return values %{ $self->{client_map} }; } # Returns a socket that is connected to the server, we can then use this # socket with a Gearman::Client::Async object to run clients and servers in the # same thread. sub to_inprocess_server { my $self = shift; my ($psock, $csock); socketpair($csock, $psock, AF_UNIX, SOCK_STREAM, PF_UNSPEC) or die "socketpair: $!"; $csock->autoflush(1); $psock->autoflush(1); IO::Handle::blocking($csock, 0); IO::Handle::blocking($psock, 0); my $client = Gearman::Server::Client->new($csock, $self); my ($package, $file, $line) = caller; $client->{peer_ip} = "[$package|$file|$line]"; $client->watch_read(1); $self->{client_map}{ $client->{fd} } = $client; return $psock; } ## end sub to_inprocess_server =head2 start_worker $pid = $server_object->start_worker( $prog ) ($pid, $client) = $server_object->start_worker( $prog ) Fork and start a worker process named by C<$prog> and returns the pid (or pid and client object). =cut sub start_worker { my ($self, $prog) = @_; my ($psock, $csock); socketpair($csock, $psock, AF_UNIX, SOCK_STREAM, PF_UNSPEC) or die "socketpair: $!"; $csock->autoflush(1); $psock->autoflush(1); my $pid = fork; unless (defined $pid) { warn "fork failed: $!\n"; return undef; } # child process unless ($pid) { local $ENV{'GEARMAN_WORKER_USE_STDIO'} = 1; close(STDIN); close(STDOUT); open(STDIN, '<&', $psock) or die "Unable to dup socketpair to STDIN: $!"; open(STDOUT, '>&', $psock) or die "Unable to dup socketpair to STDOUT: $!"; if (UNIVERSAL::isa($prog, "CODE")) { $prog->(); exit 0; # shouldn't get here. subref should exec. } exec $prog; die "Exec failed: $!"; } ## end unless ($pid) close($psock); IO::Handle::blocking($csock, 0); my $sock = $csock; my $client = Gearman::Server::Client->new($sock, $self); $client->{peer_ip} = "[gearman_child]"; $client->watch_read(1); $self->{client_map}{ $client->{fd} } = $client; return wantarray ? ($pid, $client) : $pid; } ## end sub start_worker sub enqueue_job { my ($self, $job, $highpri) = @_; my $jq = ($self->{job_queue}{ $job->{func} } ||= []); if (defined(my $max_queue_size = $self->{max_queue}{ $job->{func} })) { $max_queue_size --; # Subtract one, because we're about to add one more below. while (@$jq > $max_queue_size) { my $delete_job = pop @$jq; my $msg = Gearman::Util::pack_res_command("work_fail", $delete_job->handle); $delete_job->relay_to_listeners($msg); $delete_job->note_finished; } ## end while (@$jq > $max_queue_size) } ## end if (defined(my $max_queue_size...)) if ($highpri) { unshift @$jq, $job; } else { push @$jq, $job; } $self->{job_of_handle}{ $job->{'handle'} } = $job; } ## end sub enqueue_job sub wake_up_sleepers { my ($self, $func) = @_; if (my $existing_timer = delete($self->{wakeup_timers}->{$func})) { $existing_timer->cancel(); } return unless $self->_wake_up_some($func); my $delay = $self->{wakeup_delay}; # -1 means don't setup a timer. 0 actually means go as fast as we can, cooperatively. return if $delay == -1; # If we're only going to wakeup 0 workers anyways, don't set up a timer. return if $self->{wakeup} == 0; my $timer = Danga::Socket->AddTimer( $delay, sub { # Be sure to not wake up more sleepers if we have no jobs in the queue. # I know the object definition above says I can trust the func element to determine # if there are items in the list, but I'm just gonna be safe, rather than sorry. return unless @{ $self->{job_queue}{$func} || [] }; $self->wake_up_sleepers($func); } ); $self->{wakeup_timers}->{$func} = $timer; } ## end sub wake_up_sleepers # Returns true when there are still more workers to wake up # False if there are no sleepers sub _wake_up_some { my ($self, $func) = @_; my $sleepmap = $self->{sleepers}{$func} or return; my $sleeporder = $self->{sleepers_list}{$func} or return; # TODO SYNC UP STATE HERE IN CASE TWO LISTS END UP OUT OF SYNC my $max = $self->{wakeup}; while (@$sleeporder) { my Gearman::Server::Client $c = shift @$sleeporder; next if $c->{closed} || !$c->{sleeping}; if ($max-- <= 0) { unshift @$sleeporder, $c; return 1; } delete $sleepmap->{"$c"}; $c->res_packet("noop"); $c->{sleeping} = 0; } ## end while (@$sleeporder) delete $self->{sleepers}{$func}; delete $self->{sleepers_list}{$func}; return; } ## end sub _wake_up_some sub on_client_sleep { my $self = shift; my Gearman::Server::Client $cl = shift; foreach my $cd (@{ $cl->{can_do_list} }) { # immediately wake the sleeper up if there are things to be done if ($self->{job_queue}{$cd}) { $cl->res_packet("noop"); $cl->{sleeping} = 0; return; } my $sleepmap = ($self->{sleepers}{$cd} ||= {}); my $count = $sleepmap->{"$cl"}++; next if $count >= 2; my $sleeporder = ($self->{sleepers_list}{$cd} ||= []); # The idea here is to keep workers at the head of the list if they are doing work, hopefully # this will allow extra workers that aren't needed to actually go 'idle' safely. my $jobs_done = $cl->{jobs_done_since_sleep}; if ($jobs_done) { unshift @$sleeporder, $cl; } else { push @$sleeporder, $cl; } $cl->{jobs_done_since_sleep} = 0; } ## end foreach my $cd (@{ $cl->{can_do_list...}}) } ## end sub on_client_sleep sub jobs_outstanding { my Gearman::Server $self = shift; return scalar keys %{ $self->{job_queue} }; } sub jobs { my Gearman::Server $self = shift; return values %{ $self->{job_of_handle} }; } sub job_by_handle { my ($self, $handle) = @_; return $self->{job_of_handle}{$handle}; } sub note_job_finished { my Gearman::Server $self = shift; my Gearman::Server::Job $job = shift; if (my Gearman::Server::Client $worker = $job->worker) { $worker->{jobs_done_since_sleep}++; } if (length($job->{uniq})) { delete $self->{job_of_uniq}{ $job->{func} }{ $job->{uniq} }; } delete $self->{job_of_handle}{ $job->{handle} }; } ## end sub note_job_finished # <0/undef/"" to reset. else integer max depth. sub set_max_queue { my ($self, $func, $max) = @_; if (defined $max && length $max && $max >= 0) { $self->{max_queue}{$func} = int($max); } else { delete $self->{max_queue}{$func}; } } ## end sub set_max_queue sub new_job_handle { my $self = shift; return $self->{handle_base} . (++$self->{handle_ct}); } sub job_of_unique { my ($self, $func, $uniq) = @_; return undef unless $self->{job_of_uniq}{$func}; return $self->{job_of_uniq}{$func}{$uniq}; } sub set_unique_job { my ($self, $func, $uniq, $job) = @_; $self->{job_of_uniq}{$func} ||= {}; $self->{job_of_uniq}{$func}{$uniq} = $job; } sub grab_job { my ($self, $func) = @_; return undef unless $self->{job_queue}{$func}; my $empty = sub { delete $self->{job_queue}{$func}; return undef; }; my Gearman::Server::Job $job; while (1) { $job = shift @{ $self->{job_queue}{$func} }; return $empty->() unless $job; return $job unless $job->require_listener; foreach my Gearman::Server::Client $c (@{ $job->{listeners} }) { return $job if $c && !$c->{closed}; } $job->note_finished(0); } ## end while (1) } ## end sub grab_job 1; __END__ =head1 SEE ALSO L =cut Gearman-Server-v1.130.1/CHANGES0000644000175000017500000001166712741117461014655 0ustar palikpalik1.13.002 2016-07-11 * pod links to gearmand repaired 1.13.001 2016-07-11 * Feature Request: #115368 for Gearman-Server: Allow bind to specific IP address * Fix bug #115458 Distributions contain no tests. Actually only use ok and version tests * Fix bug #89033 typo fixes * Fix bug #107045 [PATCH] fix pod whatis * Fix bug #115350 Uses old port by default (7003) should use 4730 * pod usage 1.12 2014-12-14 * Add HACKING file * Fix bug #70728 memory leak when clients disconnect (sleeper list isn't pruned). Fixes CPAN RT 70728 (Marsh Yamazaki) 1.11 2010-01-17 * Don't get stuck in the wakeup loop. Dummy. 1.10 2009-10-04 * Read client input more aggressively. Speed improvement. * Add text commands 'jobs' and 'clients' which give information allowing you to trace jobs from clients to workers while they are running. * Flush buffers to client on EOF (assume half-closed). This makes things like netcat work better as a way to speak text protocol to the gearmand. * Add command-line option to adjust a delay before more workers are woken up. This acts as an anti-starvation mechanism in case of lower wake up counts. -Default is .1 seconds, formerly this option was not needed because all workers were woken up at the time of job submission. * Add command-line option to adjust number of workers to wake up per job injected. -Default is 3, formerly was -1 (wake up all as fast as possible) * Add command-line option to change the number of sockets accepted at once per listener socket. -Default is now 10, formerly used to be 1. * Add exceptions passing support to gearman server classes, using new options support. * Add options support to server clients, so they can subscribe to newer protocol features. * Change listening socket to be a real Danga::Socket subclass, this allows pausing for a period of time when we run into accept errors. This will fix the problem of gearmand spinning 100% cpu in those cases. * Make gearmand a little more vocal about socket accept errors. * add fast read concept to server reading from client codepath. This drastically improves performance of jobs over 1k in size. * fix in-process client and start_worker method calls to use non-blocking sockets like they should. 1.09 2007-05-09 * make start_worker (for making worker child processes), return the pid in scalar context, or ($pid, $conn) in list context * make the text command "status" show functions which have registered workers, even if nothing is pending for that func. 1.08 2007-05-01 * let start_worker take a coderef for the exec, not just an $exe name 1.07 2007-05-01 * fix up bug in Gearman::Server: we set OtherFds, instead of adding with Danga::Socket->AddOtherFds, blowing away other watched fds. * Add Gearman::Server->to_inprocess_server that returns a socket connecting to the server object, we can then use this socket with a Gearman::Client::Async object to run clients and servers in the same thread. * Add ability for workers to be launched as sub processes of the gearmand, using a duped socketpair for communication. 1.06 2007-04-25 * split up the monolithic gearmand script (which had classes, but all internally), into separate files per class, and also make a new Gearman::Server class, so Gearman servers can be embedded into other processes. (running Gearman router inside Perlbal, MogileFS, DJabberd, etc... then having child processes be workers) 1.05 * add --pidfile=/path/file.pid option and document the command line options (Ask Bjoern Hansen) 1.04 2007-02-20 * Add maximum jobqueue size feature, with a test. 1.03 2006-09-25 * "version" text command * weakref client connections in listeners list so they go away. still wondering why the jobs holding them lasted so long. or was it a loop? time will tell. go gladiator. 1.02 2006-09-20 * Devel::Gladiator support for tracking elusive memory leak * support for "shutdown" and "shutdown graceful" commands, the latter of which immediate stops listens, and exits when convenient 1.01 2006-07-01 * Artur Bergman backed out some changes seconds before I did the 1.00 release. this puts them back in. 1.00 2006-07-01 * the get-it-on-CPAN-finally release. but forgot this changes entry. 0.30 2006-06-27 * fix memory leak with sleepers list. change it from list to hash so there can't be dups, as there were before, when a worker could do multiple functions. Gearman-Server-v1.130.1/MANIFEST0000644000175000017500000000062412741117575015010 0ustar palikpalikCHANGES MANIFEST This list of files MANIFEST.SKIP Makefile.PL README.md bin/gearmand lib/Gearman/Server.pm lib/Gearman/Server/Client.pm lib/Gearman/Server/Job.pm lib/Gearman/Server/Listener.pm t/00-use.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Gearman-Server-v1.130.1/Makefile.PL0000644000175000017500000000123212740734372015624 0ustar palikpalikuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'Gearman::Server', VERSION_FROM => 'lib/Gearman/Server.pm', ABSTRACT_FROM => 'lib/Gearman/Server.pm', EXE_FILES => ['bin/gearmand'], BUILD_REQUIRES => { "Test::More" => 0, "Test::Script" => 1.12, "version" => 0, }, PREREQ_PM => { "Gearman::Util" => 0, "Danga::Socket" => 1.52, "version" => 0, }, AUTHOR => 'Brad Fitzpatrick (brad@danga.com), Brad Whitaker (whitaker@danga.com)', ); Gearman-Server-v1.130.1/t/0000755000175000017500000000000012741117575014120 5ustar palikpalikGearman-Server-v1.130.1/t/00-use.t0000644000175000017500000000061412741116564015314 0ustar palikpalikuse strict; use warnings; use version; use Test::More; use Test::Script; my @mn = qw/ Gearman::Server Gearman::Server::Client Gearman::Server::Listener Gearman::Server::Job /; my $v = qv("v1.130.1"); foreach my $n (@mn) { use_ok($n); my $_v = eval '$' . $n . '::VERSION'; is($_v, $v, "$n version is $v"); } script_compiles_ok("bin/gearmand"); done_testing; Gearman-Server-v1.130.1/bin/0000755000175000017500000000000012741117575014425 5ustar palikpalikGearman-Server-v1.130.1/bin/gearmand0000755000175000017500000001174612740734461016140 0ustar palikpalik#!/usr/bin/env perl =head1 NAME gearmand - Gearman client/worker connector. =head1 SYNOPSIS gearmand --daemon =head1 DESCRIPTION This is the main executable for L. It provides command-line configuration of port numbers, pidfiles, and daemonization. =head1 OPTIONS =over =item --daemonize / -d Make the daemon run in the background (good for init.d scripts, bad for running under daemontools/supervise). =item --port=4730 / -p 4730 Set the port number, defaults to 4730. =item --listen hostname / -L hostname Address the server should listen on. Default is =item --pidfile=/some/dir/gearmand.pid Write a pidfile when starting up =item --debug=1 Enable debugging (currently the only debug output is when a client or worker connects). =item --accept=10 Number of new connections to accept each time we see a listening socket ready. This doesn't usually need to be tuned by anyone, however in dire circumstances you may need to do it quickly. =item --wakeup=3 Number of workers to wake up per job inserted into the queue. Zero (0) is a perfectly acceptable answer, and can be used if you don't care much about job latency. This would bank on the base idea of a worker checking in with the server every so often. Negative One (-1) indicates that all sleeping workers should be woken up. All other negative numbers will cause the server to throw exception and not start. =item --wakeup-delay= Time interval before waking up more workers (the value specified by --wakeup) when jobs are still in the queue. Zero (0) means go as fast as possible, but not all at the same time. Similar to -1 on --wakeup, but is more cooperative in gearmand's multitasking model. Negative One (-1) means that this event won't happen, so only the initial workers will be woken up to handle jobs in the queue. =item --version Display the version and exit. =back =head1 COPYRIGHT Copyright 2005-2007, Danga Interactive You are granted a license to use it under the same terms as Perl itself. =head1 WARRANTY This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND. =head1 AUTHORS Brad Fitzpatrick Brad Whitaker =head1 SEE ALSO L L L L =cut package Gearmand; use strict; use warnings; BEGIN { # Provide informative names to anonymous subroutines $^P = 0x200; } use Gearman::Server; use Carp; use Danga::Socket 1.52; use Gearman::Util; use Getopt::Long; use IO::Socket::INET; use POSIX (); use Pod::Usage; use Scalar::Util (); use vars qw($DEBUG); $DEBUG = 0; my ($daemonize, $nokeepalive, $notify_pid, $opt_pidfile, $accept, $wakeup, $wakeup_delay, $conf_host,); my $conf_port = 4730; Getopt::Long::GetOptions( 'd|daemonize' => \$daemonize, 'p|port=i' => \$conf_port, 'listen|L=s' => \$conf_host, 'debug=i' => \$DEBUG, 'pidfile=s' => \$opt_pidfile, 'accept=i' => \$accept, 'wakeup=i' => \$wakeup, 'wakeup-delay=f' => \$wakeup_delay, 'version|V' => sub { print "Gearman::Server $Gearman::Server::VERSION$/"; exit; }, 'help|?' => sub { pod2usage(-verbose => 1); exit; }, # for test suite only. 'notifypid|n=i' => \$notify_pid, ); daemonize() if $daemonize; # true if we've closed listening socket, and we're waiting for a # convenient place to kill the process our $graceful_shutdown = 0; # handled manually $SIG{'PIPE'} = "IGNORE"; my $server = Gearman::Server->new( wakeup => $wakeup, wakeup_delay => $wakeup_delay, ); my $ssock = $server->create_listening_sock( $conf_port, accept_per_loop => $accept, local_addr => $conf_host ); if ($opt_pidfile) { open my $fh, '>', $opt_pidfile or die "Could not open $opt_pidfile: $!"; print $fh "$$\n"; close $fh; } sub shutdown_graceful { return if $graceful_shutdown; my $ofds = Danga::Socket->OtherFds; delete $ofds->{ fileno($ssock) }; $ssock->close; $graceful_shutdown = 1; shutdown_if_calm(); } ## end sub shutdown_graceful sub shutdown_if_calm { exit 0 unless $server->jobs_outstanding; } sub daemonize { my ($pid, $sess_id, $i); ## Fork and exit parent if ($pid = fork) { exit 0; } ## Detach ourselves from the terminal croak "Cannot detach from controlling terminal" unless $sess_id = POSIX::setsid(); ## Prevent possibility of acquiring a controlling terminal $SIG{'HUP'} = 'IGNORE'; if ($pid = fork) { exit 0; } ## Change working directory chdir "/"; ## Clear file creation mask umask 0; ## Close open file descriptors close(STDIN); close(STDOUT); close(STDERR); ## Reopen stderr, stdout, stdin to /dev/null open(STDIN, "+>/dev/null"); open(STDOUT, "+>&STDIN"); open(STDERR, "+>&STDIN"); } ## end sub daemonize kill 'USR1', $notify_pid if $notify_pid; Danga::Socket->EventLoop(); # Local Variables: # mode: perl # c-basic-indent: 4 # indent-tabs-mode: nil # End: Gearman-Server-v1.130.1/README.md0000644000175000017500000000131212740712163015122 0ustar palikpalikGearman::Server =================== [![CPAN version](https://badge.fury.io/pl/Gearman-Server.png)](https://badge.fury.io/pl/Gearman-Server) [![Build Status](https://travis-ci.org/p-alik/Gearman-Server.png)](https://travis-ci.org/p-alik/Gearman-Server) [![Coverage Status](https://coveralls.io/repos/github/p-alik/Gearman-Server/badge.png)](https://coveralls.io/github/p-alik/Gearman-Server) This repository contains perl implementation of [Gearman](http://gearman.org) daemon see also ------------ * [Gearman::Client](https://metacpan.org/pod/Gearman::Client) - Client for gearman distributed job system * [Gearman::Worker](https://metacpan.org/pod/Gearman::Worker) - Worker for gearman distributed job system Gearman-Server-v1.130.1/META.yml0000664000175000017500000000114312741117575015127 0ustar palikpalik--- abstract: "function call \"router\" and load balancer" author: - 'Brad Fitzpatrick (brad@danga.com), Brad Whitaker (whitaker@danga.com)' build_requires: Test::More: 0 Test::Script: 1.12 version: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.82, CPAN::Meta::Converter version 2.120351' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Gearman-Server no_index: directory: - t - inc requires: Danga::Socket: 1.52 Gearman::Util: 0 version: 0 version: v1.130.1