Gearman-Server-1.12/0000755000175000017500000000000012443453633014452 5ustar dormandodormandoGearman-Server-1.12/lib/0000755000175000017500000000000012443453633015220 5ustar dormandodormandoGearman-Server-1.12/lib/Gearman/0000755000175000017500000000000012443453633016572 5ustar dormandodormandoGearman-Server-1.12/lib/Gearman/Server.pm0000644000175000017500000003026612443453632020404 0ustar dormandodormandopackage Gearman::Server; =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 strict; use Gearman::Server::Client; use Gearman::Server::Listener; use Gearman::Server::Job; use Socket qw(IPPROTO_TCP SOL_SOCKET SOCK_STREAM AF_UNIX SOCK_STREAM PF_UNSPEC); use Carp qw(croak); use Sys::Hostname (); use IO::Handle (); 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 ); our $VERSION = "1.12"; =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; } sub debug { my ($self, $msg) = @_; #warn "$msg\n"; } =head2 create_listening_sock $server_object->create_listening_sock( $portnum ) Add a TCP port listener for incoming Gearman worker and client connections. =cut sub create_listening_sock { my ($self, $portnum, %opts) = @_; my $accept_per_loop = delete $opts{accept_per_loop}; 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 ) 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; } sub new_client { my ($self, $sock) = @_; my $client = Gearman::Server::Client->new($sock, $self); $client->watch_read(1); $self->{client_map}{$client->{fd}} = $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; } =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: $!"; } 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; } 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; } } if ($highpri) { unshift @$jq, $job; } else { push @$jq, $job; } $self->{job_of_handle}{$job->{'handle'}} = $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; } # 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; } delete $self->{sleepers}{$func}; delete $self->{sleepers_list}{$func}; return; } 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; } } 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}}; } # <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}; } } 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); } } 1; __END__ =head1 SEE ALSO L =cut Gearman-Server-1.12/lib/Gearman/Server/0000755000175000017500000000000012443453633020040 5ustar dormandodormandoGearman-Server-1.12/lib/Gearman/Server/Client.pm0000644000175000017500000005426012443450660021620 0ustar dormandodormandopackage Gearman::Server::Client; =head1 NAME Gearman::Server::Client =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 strict; use Danga::Socket; use base 'Danga::Socket'; use fields ( 'can_do', # { $job_name => $timeout } $timeout can be undef indicating no timeout 'can_do_list', 'can_do_iter', 'fast_read', 'fast_buffer', 'read_buf', 'sleeping', # 0/1: they've said they're sleeping and we haven't woken them up 'timer', # Timer for job cancellation 'doing', # { $job_handle => Job } 'client_id', # opaque string, no whitespace. workers give this so checker scripts # can tell apart the same worker connected to multiple jobservers. 'server', # pointer up to client's 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); $self->{fast_read} = undef; # Number of bytes to read as fast as we can (don't try to process them) $self->{fast_buffer} = []; # Array of buffers used during fast read operation $self->{read_buf} = ''; $self->{sleeping} = 0; $self->{can_do} = {}; $self->{doing} = {}; # handle -> Job $self->{can_do_list} = []; $self->{can_do_iter} = 0; # numeric iterator for where we start looking for jobs $self->{client_id} = "-"; $self->{server} = $server; $self->{options} = {}; $self->{jobs_done_since_sleep} = 0; return $self; } sub option { my Gearman::Server::Client $self = shift; my $option = shift; return $self->{options}->{$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; } $self->{server}->note_disconnected_client($self); $self->CMD_reset_abilities; $self->SUPER::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; } 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); } $self->{read_buf} .= $$bref; } 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; } $self->process_cmd($cmd, substr($self->{read_buf}, 12, $len)); # and slide down buf: $self->{read_buf} = substr($self->{read_buf}, 12+$len); } elsif ($self->{read_buf} =~ s/^(\w.+?)?\r?\n//) { # ASCII command case (useful for telnetting in) my $line = $1; $self->process_line($line); } else { $found_cmd = 0; } } while ($found_cmd); } 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; } } return $self->err_line('unknown_command'); } =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); } 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; } 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; } 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; } 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; } sub CMD_pre_sleep { my Gearman::Server::Client $self = shift; $self->{'sleeping'} = 1; $self->{server}->on_client_sleep($self); return 1; } 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; } return $self->res_packet("job_assign", join("\0", $job->handle, $job->func, ${$job->argref}, )); } $self->res_packet("no_job"); } sub CMD_can_do { my Gearman::Server::Client $self = shift; my $ar = shift; $self->{can_do}->{$$ar} = undef; $self->_setup_can_do_list; } 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; } 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"); } 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}; } sub CMD_cant_do { my Gearman::Server::Client $self = shift; my $ar = shift; delete $self->{can_do}->{$$ar}; $self->_setup_can_do_list; } 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; } } $num = '' unless defined $num; $den = '' unless defined $den; $self->res_packet("status_res", join("\0", $$ar, $known, $running, $num, $den)); } sub CMD_reset_abilities { my Gearman::Server::Client $self = shift; $self->{can_do} = {}; $self->_setup_can_do_list; } 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); } sub res_packet { my Gearman::Server::Client $self = shift; my ($code, $arg) = @_; $self->write(Gearman::Util::pack_res_command($code, $arg)); return 1; } 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; } 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", $@); } 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"); } $self->write(".\n"); } =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; } } 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}++; } } # 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" ); } $self->write( ".\n" ); } =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"); } $self->write(".\n"); } =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; } } 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"); } } $self->write(".\n"); } 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/; } } $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})); } } $self->write(".\n"); } =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"); } =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'); } } =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' => "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; } sub eurl { my $a = $_[0]; $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg; $a =~ tr/ /+/; return $a; } 1; Gearman-Server-1.12/lib/Gearman/Server/Job.pm0000644000175000017500000000627412443450660021116 0ustar dormandodormandopackage Gearman::Server::Job; use strict; 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-1.12/lib/Gearman/Server/Listener.pm0000644000175000017500000000315212443450660022161 0ustar dormandodormandopackage Gearman::Server::Listener; use strict; 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; } 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; } return if $! == EAGAIN; warn "Error accepting incoming connection: $!\n"; $self->watch_read(0); Danga::Socket->AddTimer( .1, sub { $self->watch_read(1); }); } 1; Gearman-Server-1.12/CHANGES0000644000175000017500000001074212443453572015453 0ustar dormandodormando1.12 2014-12-14 * Add HACKING file * Fix 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-1.12/META.yml0000664000175000017500000000107112443453633015724 0ustar dormandodormando--- abstract: "function call \"router\" and load balancer" author: - 'Brad Fitzpatrick (brad@danga.com), Brad Whitaker (whitaker@danga.com)' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.76, CPAN::Meta::Converter version 2.132510' 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: 1.12 Gearman-Server-1.12/HACKING0000644000175000017500000000012312443453260015431 0ustar dormandodormandohttp://contributing.appspot.com/gearman Please submit patches to the mailing list Gearman-Server-1.12/MANIFEST0000644000175000017500000000050212443453633015600 0ustar dormandodormandoCHANGES gearmand lib/Gearman/Server.pm lib/Gearman/Server/Client.pm lib/Gearman/Server/Job.pm lib/Gearman/Server/Listener.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) HACKING META.json Module JSON meta-data (added by MakeMaker) Gearman-Server-1.12/Makefile.PL0000644000175000017500000000114012443450660016415 0ustar dormandodormandouse 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 => ['gearmand'], PREREQ_PM => { 'Gearman::Util' => 0, 'Danga::Socket' => 1.52, }, AUTHOR => 'Brad Fitzpatrick (brad@danga.com), Brad Whitaker (whitaker@danga.com)', ); Gearman-Server-1.12/gearmand0000755000175000017500000001151112443450660016152 0ustar dormandodormando#!/usr/bin/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=7003 / -p 7003 Set the port number, defaults to 7003. =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 happe, so only the initial workers will be woken up to handle jobs in the queue. =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 { $^P = 0x200; # Provide informative names to anonymous subroutines } use FindBin; use lib "$FindBin::Bin/lib"; use Gearman::Server; use Getopt::Long; use Carp; use Danga::Socket 1.52; use IO::Socket::INET; use POSIX (); use Gearman::Util; use vars qw($DEBUG); use Scalar::Util (); $DEBUG = 0; my ( $daemonize, $nokeepalive, $notify_pid, $opt_pidfile, $accept, $wakeup, $wakeup_delay, ); my $conf_port = 7003; Getopt::Long::GetOptions( 'd|daemonize' => \$daemonize, 'p|port=i' => \$conf_port, 'debug=i' => \$DEBUG, 'pidfile=s' => \$opt_pidfile, 'accept=i' => \$accept, 'wakeup=i' => \$wakeup, 'wakeup-delay=f' => \$wakeup_delay, 'notifypid|n=i' => \$notify_pid, # for test suite only. ); 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; $SIG{'PIPE'} = "IGNORE"; # handled manually my $server = Gearman::Server->new( wakeup => $wakeup, wakeup_delay => $wakeup_delay, ); my $ssock = $server->create_listening_sock($conf_port, accept_per_loop => $accept); 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(); } 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 controling 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"); } 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-1.12/META.json0000664000175000017500000000171312443453633016077 0ustar dormandodormando{ "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.76, CPAN::Meta::Converter version 2.132510", "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" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Danga::Socket" : "1.52", "Gearman::Util" : "0" } } }, "release_status" : "stable", "version" : "1.12" } Gearman-Server-1.12/MANIFEST.SKIP0000644000175000017500000000065512443453404016352 0ustar dormandodormando# 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