File Coverage

blib/lib/Protocol/Redis/Faster.pm

Criterion	Covered	Total	%
statement	71	73	97.2
branch	30	32	93.7
condition	14	14	100.0
subroutine	8	8	100.0
pod	4	4	100.0
total	127	131	96.9

package Protocol::Redis::Faster;

use strict;
use warnings;
use Carp ();

use parent 'Protocol::Redis';

our $VERSION = '0.001';

sub encode {
  my ($self, $input) = @_;

  my @stack = $input;
  my $encoded = '';
  while (@stack) {
    my $message = shift @stack;

    # Simple strings, errors, and integers
    if ($message->{type} eq '+' or $message->{type} eq '-' or $message->{type} eq ':') {
      $encoded .= $message->{type} . $message->{data} . "\r\n";
    }

    # Bulk strings
    elsif ($message->{type} eq '$') {
      my $data = $message->{data};

      if (defined $data) {
        $encoded .= '$' . length($data) . "\r\n" . $data . "\r\n";
      }
      else {
        $encoded .= '$-1' . "\r\n";
      }
    }

    # Arrays
    elsif ($message->{type} eq '*') {
      my $data = $message->{data};

      if (defined $data) {
        $encoded .= '*' . scalar(@$data) . "\r\n";
        unshift @stack, @$data;
      }
      else {
        $encoded .= '*-1' . "\r\n";
      }
    }

    # Invalid type
    else {
      Carp::croak(qq/Unknown message type $message->{type}/);
    }
  }

  return $encoded;
}

sub get_message { shift @{$_[0]{_messages}} }

sub on_message {
  my ($self, $cb) = @_;
  $self->{_on_message_cb} = $cb;
}

sub parse {
  my ($self, $input) = @_;
  $self->{_buf} .= $input;

  my $curr = $self->{_curr} ||= {};
  my $buf  = \$self->{_buf};
  my $cb   = $self->{_on_message_cb};

  CHUNK:
  while (length $$buf) {

    # Look for message type and get the actual data,
    # length of the bulk string or the size of the array
    if (!$curr->{type}) {
      my $pos = index $$buf, "\r\n";
      return if $pos < 0; # Wait for more data

      $curr->{type} = substr $$buf, 0, 1;
      $curr->{len}  = substr $$buf, 1, $pos - 1;
      substr $$buf, 0, $pos + 2, ''; # Remove type + length/data + \r\n
    }

    # Bulk strings
    if ($curr->{type} eq '$') {
      if ($curr->{len} == -1) {
        $curr->{data} = undef;
      }
      elsif (length($$buf) - 2 < $curr->{len}) {
        return; # Wait for more data
      }
      else {
        $curr->{data} = substr $$buf, 0, $curr->{len}, '';
      }

      substr $$buf, 0, 2, ''; # Remove \r\n
    }

    # Simple strings, errors, and integers
    elsif ($curr->{type} eq '+' or $curr->{type} eq '-' or $curr->{type} eq ':') {
      $curr->{data} = delete $curr->{len};
    }

    # Arrays
    elsif ($curr->{type} eq '*') {
      $curr->{data} = $curr->{len} < 0 ? undef : [];

      # Fill the array with data
      if ($curr->{len} > 0) {
        $curr = $self->{_curr} = {parent => $curr};
        next CHUNK;
      }
    }

    # Invalid input
    else {
      Carp::croak(qq/Unexpected input "$curr->{type}"/);
    }

    # Fill parent array with data
    while (my $parent = delete $curr->{parent}) {
      delete $curr->{len};
      push @{$parent->{data}}, $curr;

      if (@{$parent->{data}} < $parent->{len}) {
        $curr = $self->{_curr} = {parent => $parent};
        next CHUNK;
      }
      else {
        $curr = $self->{_curr} = $parent;
      }
    }

    # Emit a complete message
    delete $curr->{len};
    if (defined $cb) {
      $cb->($self, $curr);
    } else {
      push @{$self->{_messages}}, $curr;
    }
    $curr = $self->{_curr} = {};
  }
}

1;

=head1 NAME

Protocol::Redis::Faster - Optimized pure-perl Redis protocol parser/encoder

=head1 SYNOPSIS

  use Protocol::Redis::Faster;
  my $redis = Protocol::Redis::Faster->new(api => 1) or die "API v1 not supported";

  $redis->parse("+foo\r\n");

  # get parsed message
  my $message = $redis->get_message;
  print "parsed message: ", $message->{data}, "\n";

  # asynchronous parsing interface
  $redis->on_message(sub {
      my ($redis, $message) = @_;
      print "parsed message: ", $message->{data}, "\n";
  });

  # parse pipelined message
  $redis->parse("+bar\r\n-error\r\n");

  # create message
  print "Get key message:\n",
    $redis->encode({type => '*', data => [
       {type => '$', data => 'string'},
       {type => '+', data => 'OK'}
  ]});

=head1 DESCRIPTION

This module implements the L API with more optimized pure-perl
internals. See L for usage documentation.

This is a low level parsing module, if you are looking to use Redis in Perl,
try L, L, or L.

=head1 BUGS

Report any issues on the public bugtracker.

=head1 AUTHORS

Dan Book

Jan Henning Thorsen

=head1 CREDITS

Thanks to Sergey Zasenko  for the original L
and defining the API.

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2019 by Dan Book, Jan Henning Thorsen.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=head1 SEE ALSO

L