view release on metacpan or  search on metacpan

lib/Protocol/Gearman.pm  view on Meta::CPAN

   JOB_ASSIGN_UNIQ    => 4,
);

=head2 pack_packet

   ( $type, $body ) = $gearman->pack_packet( $name, @args );

Given a name of a packet type (specified as a string as the name of one of the
C<TYPE_*> constants, without the leading C<TYPE_> prefix; case insignificant)
returns the type value and the arguments for the packet packed into a body
string. This is intended for passing directly into C<build_packet> or
C<send_packet>:

   send_packet $fh, pack_packet( SUBMIT_JOB => $func, $id, $arg );

=cut

sub pack_packet ( $, $typename, @args )
{
   my $typefn = __PACKAGE__->can( "TYPE_\U$typename" ) or
      croak "Unrecognised packet type '$typename'";

   my $n_args = $ARGS_FOR_TYPE{uc $typename};

   @args == $n_args or croak "Expected '\U$typename\E' to take $n_args args";
   $args[$_] =~ m/\0/ and croak "Non-final argument [$_] of '\U$typename\E' cannot contain a \\0"
      for 0 .. $n_args-2;

   my $type = $typefn->();
   return ( $type, join "\0", @args );
}

=head2 unpack_packet

   ( $name, @args ) = $gearman->unpack_packet( $type, $body );

Given a type code and body string, returns the type name and unpacked
arguments from the body. This function is the reverse of C<pack_packet> and is
intended to be used on the result of C<parse_packet> or C<recv_packet>:

The returned C<$name> will always be a fully-captialised type name, as one of
the C<TYPE_*> constants without the leading C<TYPE_> prefix.

This is intended for a C<given/when> control block, or dynamic method
dispatch:

   my ( $name, @args ) = unpack_packet( recv_packet $fh );

   $self->${\"handle_$name"}( @args );

=cut

sub unpack_packet ( $, $type, $body )
{
   my $typename = $TYPENAMES{$type} or
      croak "Unrecognised packet type $type";

   my $n_args = $ARGS_FOR_TYPE{$typename};

   return ( $typename ) if $n_args == 0;
   return ( $typename, split m/\0/, $body, $n_args );
}

=head2 parse_packet_from_string

   ( $name, @args ) = $gearman->parse_packet_from_string( $bytes );

Attempts to parse a complete message packet from the given byte string. If it
succeeds, it returns the type name and arguments. If it fails it returns an
empty list.

If successful, it will remove the bytes of the packet form the C<$bytes>
scalar, which must therefore be mutable.

If the byte string begins with some bytes that are not recognised as the
Gearman packet magic for a response, the function will immediately throw an
exception before modifying the string.

=cut

# hard to do $_[0] mutation with a signature
sub parse_packet_from_string
{
   my $self = shift;

   return unless length $_[0] >= 4;
   croak "Expected to find 'RES' magic in packet" unless
      unpack( "a4", $_[0] ) eq MAGIC_RESPONSE;

   return unless length $_[0] >= 12;

   my $bodylen = unpack( "x8 N", $_[0] );
   return unless length $_[0] >= 12 + $bodylen;

   # Now committed to extracting it
   my ( $type ) = unpack( "x4 N x4", substr $_[0], 0, 12, "" );
   my $body = substr $_[0], 0, $bodylen, "";

   return $self->unpack_packet( $type, $body );
}

=head2 recv_packet_from_fh

   ( $name, @args ) = $gearman->recv_packet_from_fh( $fh );

Attempts to read a complete packet from the given filehandle, blocking until
it is available. The results are undefined if this function is called on a
non-blocking filehandle.

If an IO error happens, an exception is thrown. If the first four bytes read
are not recognised as the Gearman packet magic for a response, the function
will immediately throw an exception. If either of these conditions happen, the
filehandle should be considered no longer valid and should be closed.

=cut

sub recv_packet_from_fh ( $self, $fh )
{
   $fh->read( my $magic, 4 ) or croak "Cannot read header - $!";
   croak "Expected to find 'RES' magic in packet" unless
      $magic eq MAGIC_RESPONSE;