Improve Redis::List

 * added a better synopsis;
 * fix: added the POP method;
 * improved test suite.

Signed-off-by: Pedro Melo <melo@simplicidade.org>

Changes

@@ -6,6 +6,7 @@ Revision history for Redis
     * feature: support for Redis PUBLISH/SUBSCRIBE commands
     * feature: automatic encoding can be turned off, use encoding => undef on new() (performance++)
     * performance: substantial performance improvements, specially with large responses
+    * fix: add POP method to our List Tie interface
 
 1.2001	Wed Mar 17 17:22:01 CET 2010
     * feadure: Redis protocol 1.2 support by Jeremy Zawodny <Jeremy@Zawodny.com> CPAN RT #54841

lib/Redis/List.pm

@@ -2,7 +2,6 @@ package Redis::List;
 
 use strict;
 use warnings;
-
 use base qw/Redis Tie::Array/;
 
 =head1 NAME
@@ -11,77 +10,99 @@ Redis::List - tie perl arrays into Redis lists
 
 =head1 SYNOPSYS
 
-  tie @a, 'Redis::List', 'name';
+    tie @my_list, 'Redis::List', 'list_name', @Redis_new_parameters;
+
+    $value = $my_list[$index];
+    $my_list[$index] = $value;
+
+    $count = @my_list;
+
+    push @my_list, 'values';
+    $value = pop @my_list;
+    unshift @my_list, 'values';
+    $value = shift @my_list;
+
+    ## NOTE: fourth parameter of splice is *NOT* supported for now
+    @other_list = splice(@my_list, 2, 3);
+
+    @my_list = ();
+
 
 =cut
 
-# mandatory methods
+
 sub TIEARRAY {
-  my ($class, $name) = @_;
-  my $self = $class->new;
-  $self->{name} = $name;
-  bless $self => $class;
+  my ($class, $list, @rest) = @_;
+  my $self = $class->new(@rest);
+
+  $self->{list} = $list;
+
+  return $self;
 }
 
 sub FETCH {
   my ($self, $index) = @_;
-  $self->lindex($self->{name}, $index);
+  $self->lindex($self->{list}, $index);
 }
 
 sub FETCHSIZE {
   my ($self) = @_;
-  $self->llen($self->{name});
+  $self->llen($self->{list});
 }
 
 sub STORE {
   my ($self, $index, $value) = @_;
-  $self->lset($self->{name}, $index, $value);
+  $self->lset($self->{list}, $index, $value);
 }
 
 sub STORESIZE {
   my ($self, $count) = @_;
-  $self->ltrim($self->{name}, 0, $count);
+  $self->ltrim($self->{list}, 0, $count);
 
 #		if $count > $self->FETCHSIZE;
 }
 
 sub CLEAR {
   my ($self) = @_;
-  $self->del($self->{name});
+  $self->del($self->{list});
 }
 
 sub PUSH {
   my $self = shift;
-  $self->rpush($self->{name}, $_) foreach @_;
+  my $list = $self->{list};
+
+  $self->rpush($list, $_) for @_;
 }
 
-sub SHIFT {
+sub POP {
   my $self = shift;
-  $self->lpop($self->{name});
+  $self->rpop($self->{list});
+}
+
+sub SHIFT {
+  my ($self) = @_;
+  $self->lpop($self->{list});
 }
 
 sub UNSHIFT {
   my $self = shift;
-  $self->lpush($self->{name}, $_) foreach @_;
+  my $list = $self->{list};
+
+  $self->lpush($list, $_) for @_;
 }
 
 sub SPLICE {
-  my $self   = shift;
-  my $offset = shift;
-  my $length = shift;
-  $self->lrange($self->{name}, $offset, $length);
+  my ($self, $offset, $length) = @_;
+  $self->lrange($self->{list}, $offset, $length);
 
   # FIXME rest of @_ ?
 }
 
 sub EXTEND {
   my ($self, $count) = @_;
-  $self->rpush($self->{name}, '') foreach ($self->FETCHSIZE .. ($count - 1));
+  $self->rpush($self->{list}, '') for ($self->FETCHSIZE .. ($count - 1));
 }
 
-sub DESTROY {
-  my $self = shift;
-  $self->quit;
-}
+sub DESTROY { $_[0]->quit }
 
 1;

t/10-Redis-List.t

@@ -1,28 +1,75 @@
-#!/usr/bin/perl
+#!perl
 
 use warnings;
 use strict;
+use Test::More;
+use Redis::List;
+use lib 't/tlib';
+use Test::SpawnRedisServer;
 
-use Test::More tests => 8;
-use lib 'lib';
+my ($guard, $srv) = redis();
 
-BEGIN {
-  use_ok('Redis::List');
-}
+## Setup
+my @my_list;
+ok(my $redis = tie(@my_list, 'Redis::List', 'my_list', server => $srv),
+  'tied to our test redis-server');
+ok($redis->ping, 'pinged fine');
+isa_ok($redis, 'Redis::List');
 
-my @a;
 
-ok(my $o = tie(@a, 'Redis::List', 'test-redis-list'), 'tie');
+## Direct access
+subtest 'direct access' => sub {
+  @my_list = ();
+  is_deeply(\@my_list, [], 'empty list ok');
 
-isa_ok($o, 'Redis::List');
+  @my_list = ('foo', 'bar', 'baz');
+  is_deeply(\@my_list, ['foo', 'bar', 'baz'], 'Set multiple values ok');
 
-$o->CLEAR;
+  $my_list[1] = 'BAR';
+  is_deeply(\@my_list, ['foo', 'BAR', 'baz'], 'Set single value ok');
 
-ok(!@a, 'empty list');
+  is($my_list[2]++, 'baz', 'get single value ok');
+  is(++$my_list[2], 'bbb', '... even with post/pre-increments');
+};
 
-ok(@a = ('foo', 'bar', 'baz'), '=');
-is_deeply([@a], ['foo', 'bar', 'baz']);
 
-ok(push(@a, 'push'), 'push');
-is_deeply([@a], ['foo', 'bar', 'baz', 'push']);
+## List functions
+subtest 'list functions' => sub {
+  my $v;
 
+  ok($v = shift(@my_list), 'shift ok');
+  is($v, 'foo', '... expected value');
+  is_deeply(\@my_list, ['BAR', 'bbb'], '... resulting list as expected');
+
+  ok(push(@my_list, $v), 'push ok');
+  is_deeply(
+    \@my_list,
+    ['BAR', 'bbb', 'foo'],
+    '... resulting list as expected'
+  );
+
+  ok($v = pop(@my_list), 'pop ok');
+  is($v, 'foo', '... expected value');
+  is_deeply(\@my_list, ['BAR', 'bbb'], '... resulting list as expected');
+
+  ok(unshift(@my_list, $v), 'unshift ok');
+  is_deeply(
+    \@my_list,
+    ['foo', 'BAR', 'bbb'],
+    '... resulting list as expected'
+  );
+
+  ok(my @s = splice(@my_list, 1, 2), 'splice ok');
+  is_deeply([@s], ['BAR', 'bbb'], '... resulting list as expected');
+  is_deeply(
+    \@my_list,
+    ['foo', 'BAR', 'bbb'],'... original list as expected'
+  );
+};
+
+
+## Cleanup
+@my_list = ();
+is_deeply(\@my_list, [], 'empty list ok');
+
+done_testing();