r69734 - in /trunk/libredis-perl: ./ debian/ lib/ lib/Redis/ scripts/ t/ t/tlib/

ghedo-guest at users.alioth.debian.org ghedo-guest at users.alioth.debian.org
Sat Feb 26 10:42:47 UTC 2011


Author: ghedo-guest
Date: Sat Feb 26 10:42:38 2011
New Revision: 69734

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=69734
Log:
new upstream release

Added:
    trunk/libredis-perl/scripts/publish.pl
      - copied unchanged from r69733, branches/upstream/libredis-perl/current/scripts/publish.pl
    trunk/libredis-perl/t/01-basic.t
      - copied unchanged from r69733, branches/upstream/libredis-perl/current/t/01-basic.t
    trunk/libredis-perl/t/02-responses.t
      - copied unchanged from r69733, branches/upstream/libredis-perl/current/t/02-responses.t
    trunk/libredis-perl/t/03-pubsub.t
      - copied unchanged from r69733, branches/upstream/libredis-perl/current/t/03-pubsub.t
    trunk/libredis-perl/t/05-nonblock.t
      - copied unchanged from r69733, branches/upstream/libredis-perl/current/t/05-nonblock.t
    trunk/libredis-perl/t/10-tie-list.t
      - copied unchanged from r69733, branches/upstream/libredis-perl/current/t/10-tie-list.t
    trunk/libredis-perl/t/20-tie-hash.t
      - copied unchanged from r69733, branches/upstream/libredis-perl/current/t/20-tie-hash.t
    trunk/libredis-perl/t/tlib/
      - copied from r69733, branches/upstream/libredis-perl/current/t/tlib/
Modified:
    trunk/libredis-perl/Changes
    trunk/libredis-perl/MANIFEST
    trunk/libredis-perl/META.yml
    trunk/libredis-perl/Makefile.PL
    trunk/libredis-perl/README
    trunk/libredis-perl/debian/changelog
    trunk/libredis-perl/lib/Redis.pm
    trunk/libredis-perl/lib/Redis/Hash.pm
    trunk/libredis-perl/lib/Redis/List.pm

Modified: trunk/libredis-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/Changes?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/Changes (original)
+++ trunk/libredis-perl/Changes Sat Feb 26 10:42:38 2011
@@ -1,13 +1,32 @@
 Revision history for Redis
 
-0.01    Sun Mar 22 19:02:17 CET 2009
-        First version, tracking git://github.com/antirez/redis
+1.903 Tue Feb 22 13:04:24 UTC 2011
+    * remove the Guard dependency
+
+1.902 Sat Feb  5 12:38:57 UTC 2011
+    * fix: ping() no longer dies (RT #62489)
+    * fix: shutdown() no longer dies
+
+1.901 Sat Feb  5 11:15:04 UTC 2011
+    * Released 1.900_01 as latest version
+
+1.900_01  Sun Jan 30 06:03:14 UTC 2011
+    * admin: change of maintainer to Pedro Melo <melo at simplicidade.org>
+    * feature: full support for Redis 2.x multi-bulk protocol
+    * 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 at Zawodny.com> CPAN RT #54841
+    * Version bump to be in-sync with Redis version
+    * bug: Correctly round-trip utf-8 encoded characters
 
 0.08	Tue Mar 24 22:38:59 CET 2009
-	This version supports new protocol introduced in beta 8
-	Version bump to be in-sync with Redis version
+    * This version supports new protocol introduced in beta 8
+    * Version bump to be in-sync with Redis version
 
-1.2001	Wed Mar 17 17:22:01 CET 2010
-	Redis protocol 1.2 support by Jeremy Zawodny <Jeremy at Zawodny.com> CPAN RT #54841
-	Version bump to be in-sync with Redis version
-	Correctly round-trip utf-8 encoded characters
+0.01    Sun Mar 22 19:02:17 CET 2009
+    * First version, tracking git://github.com/antirez/redis
+

Modified: trunk/libredis-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/MANIFEST?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/MANIFEST (original)
+++ trunk/libredis-perl/MANIFEST Sat Feb 26 10:42:38 2011
@@ -1,12 +1,20 @@
 Changes
+lib/Redis.pm
+lib/Redis/Hash.pm
+lib/Redis/List.pm
+Makefile.PL
 MANIFEST
-Makefile.PL
 README
-lib/Redis.pm
-lib/Redis/List.pm
-lib/Redis/Hash.pm
+scripts/publish.pl
 scripts/redis-benchmark.pl
 t/00-load.t
+t/01-basic.t
+t/02-responses.t
+t/03-pubsub.t
+t/05-nonblock.t
+t/10-tie-list.t
+t/20-tie-hash.t
 t/pod-coverage.t
 t/pod.t
+t/tlib/Test/SpawnRedisServer.pm
 META.yml                                 Module meta-data (added by MakeMaker)

Modified: trunk/libredis-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/META.yml?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/META.yml (original)
+++ trunk/libredis-perl/META.yml Sat Feb 26 10:42:38 2011
@@ -1,9 +1,9 @@
 --- #YAML:1.0
 name:               Redis
-version:            1.2001
+version:            1.903
 abstract:           perl binding for Redis database
 author:
-    - Dobrica Pavlinusic <dpavlin at rot13.org>
+    - Pedro Melo <melo at simplicidade.org>
 license:            unknown
 distribution_type:  module
 configure_requires:
@@ -14,15 +14,23 @@
     Carp:              0
     Data::Dumper:      0
     Encode:            0
+    Exporter:          0
+    Fcntl:             0
+    File::Temp:        0
+    IO::Handle:        0
+    IO::Select:        0
     IO::Socket::INET:  0
+    IO::String:        0
+    POSIX:             0
     Test::Deep:        0
     Test::Exception:   0
-    Test::More:        0.92
+    Test::More:        0.96
+    Tie::Hash:         0
 no_index:
     directory:
         - t
         - inc
-generated_by:       ExtUtils::MakeMaker version 6.55_02
+generated_by:       ExtUtils::MakeMaker version 6.56
 meta-spec:
     url:      http://module-build.sourceforge.net/META-spec-v1.4.html
     version:  1.4

Modified: trunk/libredis-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/Makefile.PL?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/Makefile.PL (original)
+++ trunk/libredis-perl/Makefile.PL Sat Feb 26 10:42:38 2011
@@ -3,20 +3,28 @@
 use ExtUtils::MakeMaker;
 
 WriteMakefile(
-    NAME                => 'Redis',
-    AUTHOR              => 'Dobrica Pavlinusic <dpavlin at rot13.org>',
-    VERSION_FROM        => 'lib/Redis.pm',
-    ABSTRACT_FROM       => 'lib/Redis.pm',
-    PL_FILES            => {},
-    PREREQ_PM => {
-        'Test::More' => 0.92,
-        'Test::Exception' => 0,
-        'Test::Deep' => 0,
-		'IO::Socket::INET' => 0,
-		'Data::Dumper' => 0,
-		'Carp' => 0,
-		'Encode' => 0,
-    },
-    dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
-    clean               => { FILES => 'Redis-*' },
+  NAME          => 'Redis',
+  AUTHOR        => 'Pedro Melo <melo at simplicidade.org>',
+  VERSION_FROM  => 'lib/Redis.pm',
+  ABSTRACT_FROM => 'lib/Redis.pm',
+  PL_FILES      => {},
+  PREREQ_PM     => {
+    'Carp'             => 0,
+    'Data::Dumper'     => 0,
+    'Encode'           => 0,
+    'Exporter'         => 0,
+    'Fcntl'            => 0,
+    'File::Temp'       => 0,
+    'IO::Handle'       => 0,
+    'IO::Select'       => 0,
+    'IO::Socket::INET' => 0,
+    'IO::String'       => 0,
+    'POSIX'            => 0,
+    'Test::Deep'       => 0,
+    'Test::Exception'  => 0,
+    'Test::More'       => 0.96,
+    'Tie::Hash'        => 0,
+  },
+  dist  => {COMPRESS => 'gzip -9f', SUFFIX => 'gz'},
+  clean => {FILES    => 'Redis-*'},
 );

Modified: trunk/libredis-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/README?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/README (original)
+++ trunk/libredis-perl/README Sat Feb 26 10:42:38 2011
@@ -36,7 +36,8 @@
 
 COPYRIGHT AND LICENCE
 
-Copyright (C) 2009 Dobrica Pavlinusic
+Copyright (C) 2011 Pedro Melo
+Copyright (C) 2009-2010 Dobrica Pavlinusic
 
 This program is free software; you can redistribute it and/or modify it
 under the same terms as Perl itself.

Modified: trunk/libredis-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/debian/changelog?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/debian/changelog (original)
+++ trunk/libredis-perl/debian/changelog Sat Feb 26 10:42:38 2011
@@ -1,3 +1,9 @@
+libredis-perl (2:1.9030-1) UNRELEASED; urgency=low
+
+  * New upstream release
+
+ -- Alessandro Ghedini <al3xbio at gmail.com>  Sat, 26 Feb 2011 11:38:39 +0100
+
 libredis-perl (2:1.2001+git20110127-1) unstable; urgency=low
 
   * New upstream release bringing Redis 2.0 support from git 20110127.91693e7f

Modified: trunk/libredis-perl/lib/Redis.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/lib/Redis.pm?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/lib/Redis.pm (original)
+++ trunk/libredis-perl/lib/Redis.pm Sat Feb 26 10:42:38 2011
@@ -5,6 +5,7 @@
 
 use IO::Socket::INET;
 use IO::Select;
+use IO::Handle;
 use Fcntl qw( O_NONBLOCK F_SETFL );
 use Data::Dumper;
 use Carp qw/confess/;
@@ -16,30 +17,70 @@
 
 =cut
 
-our $VERSION = '1.2001';
+our $VERSION = '1.903';
+
+=head1 SYNOPSIS
+
+    ## Defaults to $ENV{REDIS_SERVER} or 127.0.0.1:6379
+    my $redis = Redis->new;
+    
+    my $redis = Redis->new(server => 'redis.example.com:8080');
+    
+    ## Disable the automatic utf8 encoding => much more performance
+    my $redis = Redis->new(encoding => undef);
+    
+    ## Use all the regular Redis commands, they all accept a list of
+    ## arguments
+    ## See http://redis.io/commands for full list
+    $redis->get('key');
+    $redis->set('key' => 'value');
+    $redis->sort('list', 'DESC');
+    $redis->sort(qw{list LIMIT 0 5 ALPHA DESC});
+    
+    ## Publish/Subscribe
+    $redis->subscribe(
+      'topic_1',
+      'topic_2',
+      sub {
+        my ($message, $topic, $subscribed_topic) = @_
+    
+          ## $subscribed_topic can be different from topic if
+          ## you use psubscribe() with wildcards
+      }
+    );
+    $redis->psubscribe('nasdaq.*', sub {...});
+    
+    ## Blocks and waits for messages, calls subscribe() callbacks
+    ##  ... forever
+    $redis->wait_for_messages($timeout) while 1;
+    
+    ##  ... until some condition
+    $redis->wait_for_messages($timeout) while $keep_going;
+    
+    $redis->publish('topic_1', 'message');
 
 
 =head1 DESCRIPTION
 
-Pure perl bindings for L<http://code.google.com/p/redis/>
-
-This version supports protocol 1.2 or later of Redis available at
-
-L<git://github.com/antirez/redis>
-
-This documentation
-lists commands which are exercised in test suite, but
-additinal commands will work correctly since protocol
-specifies enough information to support almost all commands
-with same peace of code with a little help of C<AUTOLOAD>.
-
-=head1 FUNCTIONS
+Pure perl bindings for L<http://redis.io/>
+
+This version supports protocol 2.x (multi-bulk) or later of Redis
+available at L<https://github.com/antirez/redis/>.
+
+This documentation lists commands which are exercised in test suite, but
+additinal commands will work correctly since protocol specifies enough
+information to support almost all commands with same peace of code with
+a little help of C <AUTOLOAD> .
+
+
+=head1 METHODS
 
 =head2 new
 
-  my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
-
-  my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
+    my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
+
+    my $r = Redis->new( server => '192.168.0.1:6379', debug => 0 );
+    my $r = Redis->new( server => '192.168.0.1:6379', encoding => undef );
 
 =cut
 
@@ -48,7 +89,8 @@
   my $self  = {@_};
 
   $self->{debug} ||= $ENV{REDIS_DEBUG};
-  $self->{encoding} ||= 'utf8';    ## default to lax utf8
+  $self->{encoding} = 'utf8'
+    unless exists $self->{encoding};    ## default to lax utf8
 
   $self->{server} ||= $ENV{REDIS_SERVER} || '127.0.0.1:6379';
   $self->{sock} = IO::Socket::INET->new(
@@ -56,9 +98,6 @@
     Proto    => 'tcp',
   ) || confess("Could not connect to Redis server at $self->{server}: $!");
 
-  $self->{read_size} = 8192;
-  $self->{rbuf}      = '';
-
   $self->{is_subscriber} = 0;
   $self->{subscribers}   = {};
 
@@ -115,10 +154,35 @@
 
   $self->__send_command('QUIT');
 
-  delete $self->{rbuf};
   close(delete $self->{sock}) || confess("Can't close socket: $!");
 
   return 1;
+}
+
+sub shutdown {
+  my ($self) = @_;
+
+  $self->__send_command('SHUTDOWN');
+  close(delete $self->{sock}) || confess("Can't close socket: $!");
+
+  return 1;
+}
+
+sub ping {
+  my ($self) = @_;
+  return unless exists $self->{sock};
+
+  my $reply;
+  eval {
+    $self->__send_command('PING');
+    $reply = $self->__read_response('PING');
+  };
+  if ($@) {
+    close(delete $self->{sock});
+    return;
+  }
+
+  return $reply;
 }
 
 sub info {
@@ -151,13 +215,14 @@
 ### PubSub
 sub wait_for_messages {
   my ($self, $timeout) = @_;
+  my $sock = $self->{sock};
 
   my $s = IO::Select->new;
-  $s->add($self->{sock});
+  $s->add($sock);
 
   my $count = 0;
   while ($s->can_read($timeout)) {
-    while ($self->__can_read_sock) {
+    while (__try_read_sock($sock)) {
       my @m = $self->__read_response('WAIT_FOR_MESSAGES');
       $self->__process_pubsub_msg(\@m);
       $count++;
@@ -269,9 +334,31 @@
 }
 
 sub __read_response {
+  my ($self, $cmd) = @_;
+
+  confess("Not connected to any server") unless $self->{sock};
+
+  local $/ = "\r\n";
+
+  ## no debug => fast path
+  return __read_response_r(@_) unless $self->{debug};
+
+  if (wantarray) {
+    my @r = __read_response_r(@_);
+    warn "[RECV] $cmd ", Dumper(\@r);
+    return @r;
+  }
+  else {
+    my $r = __read_response_r(@_);
+    warn "[RECV] $cmd ", Dumper($r);
+    return $r;
+  }
+}
+
+sub __read_response_r {
   my ($self, $command, $type_r) = @_;
 
-  my ($type, $result) = $self->__read_sock;
+  my ($type, $result) = $self->__read_line;
   $$type_r = $type if $type_r;
 
   if ($type eq '-') {
@@ -282,12 +369,12 @@
   }
   elsif ($type eq '$') {
     return if $result < 0;
-    return $self->__read_sock($result);
+    return $self->__read_len($result + 2);
   }
   elsif ($type eq '*') {
     my @list;
     while ($result--) {
-      push @list, scalar($self->__read_response($command));
+      push @list, scalar($self->__read_response_r($command));
     }
     return @list if wantarray;
     return \@list;
@@ -300,55 +387,79 @@
   }
 }
 
-sub __read_sock {
+sub __read_line {
+  my $self = $_[0];
+  my $sock = $self->{sock};
+
+  my $data = <$sock>;
+  confess("Error while reading from Redis server: $!")
+    unless defined $data;
+
+  chomp $data;
+  warn "[RECV RAW] '$data'" if $self->{debug};
+
+  my $type = substr($data, 0, 1, '');
+  return ($type, $data) unless $self->{encoding};
+  return ($type, decode($self->{encoding}, $data));
+}
+
+sub __read_len {
   my ($self, $len) = @_;
-  my $sock = $self->{sock} || confess("Not connected to any server");
-  my $enc  = $self->{encoding};
-  my $deb  = $self->{debug};
-  my $rbuf = \($self->{rbuf});
-
-  my ($data, $type) = ('', '');
-  my $read_size = $self->{read_size};
-  $read_size = $len + 2 if defined $len && $len + 2 > $read_size;
-
-  while (1) {
-    ## Read NN bytes, strip \r\n at the end
-    if (defined $len) {
-      if (length($$rbuf) >= $len + 2) {
-        $data = substr(substr($$rbuf, 0, $len + 2, ''), 0, -2);
-        last;
-      }
-    }
-    ## No len, means line more, read until \r\n
-    elsif ($$rbuf =~ s/^(.)([^\015\012]*)\015\012//) {
-      ($type, $data) = ($1, $2);
-      last;
-    }
-
-    my $bytes = sysread $sock, $$rbuf, $read_size, length $$rbuf;
+
+  my $data;
+  my $offset = 0;
+  while ($len) {
+    my $bytes = read $self->{sock}, $data, $len, $offset;
     confess("Error while reading from Redis server: $!")
       unless defined $bytes;
     confess("Redis server closed connection") unless $bytes;
-  }
-
-  $data = decode($enc, $data) if $enc;
-  warn "[RECV] '$type$data'" if $self->{debug};
-
-  return ($type, $data) if $type;
-  return $data;
-}
-
-sub __can_read_sock {
-  my ($self) = @_;
-  my $sock   = $self->{sock};
-  my $rbuf   = \($self->{rbuf});
-
-  return 1 if $$rbuf;
+
+    $offset += $bytes;
+    $len -= $bytes;
+  }
+
+  chomp $data;
+  warn "[RECV RAW] '$data'" if $self->{debug};
+
+  return $data unless $self->{encoding};
+  return decode($self->{encoding}, $data);
+}
+
+
+#
+# The reason for this code:
+#
+# IO::Select and buffered reads like <$sock> and read() dont mix
+# For example, if I receive two MESSAGE messages (from Redis PubSub),
+# the first read for the first message will probably empty to socket
+# buffer and move the data to the perl IO buffer.
+#
+# This means that IO::Select->can_read will return false (after all
+# the socket buffer is empty) but from the application point of view
+# there is still data to be read and process
+#
+# Hence this code. We try to do a non-blocking read() of 1 byte, and if
+# we succeed, we put it back and signal "yes, Virginia, there is still
+# stuff out there"
+#
+# We could just use sysread and leave the socket buffer with the second
+# message, and then use IO::Select as intended, and previous versions of
+# this code did that (check the git history for this file), but
+# performance suffers, about 20/30% slower, mostly because we do a lot
+# of "read one line", where <$sock> beats the crap of anything you can
+# write on Perl-land.
+#
+sub __try_read_sock {
+  my $sock = shift;
+  my $data;
+
   __fh_nonblocking($sock, 1);
-  my $bytes = sysread $sock, $$rbuf, $self->{read_size}, length $$rbuf;
+  my $result = read($sock, $data, 1);
   __fh_nonblocking($sock, 0);
-  return 1 if $bytes;
-  return 0;
+
+  return unless $result;
+  $sock->ungetc(ord($data));
+  return 1;
 }
 
 
@@ -550,17 +661,27 @@
 
   my $info_hash = $r->info;
 
+
 =head1 ENCODING
 
-Since Redis knows nothing about encoding, we are forcing utf-8 flag on all data received from Redis.
-This change is introduced in 1.2001 version.
-
-This allows us to round-trip utf-8 encoded characters correctly, but might be problem if you push
-binary junk into Redis and expect to get it back without utf-8 flag turned on.
-
-=head1 AUTHOR
-
-Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
+Since Redis knows nothing about encoding, we are forcing utf-8 flag on
+all data received from Redis. This change is introduced in 1.2001
+version. B<Please note> that this encoding option severely degrades
+performance
+
+You can disable this automatic encoding by passing an option to
+new: C<< encoding => undef >>.
+
+This allows us to round-trip utf-8 encoded characters correctly, but
+might be problem if you push binary junk into Redis and expect to get it
+back without utf-8 flag turned on.
+
+
+=head1 AUTHORS
+
+Pedro Melo, C<< <melo at cpan.org> >>
+
+Original author and maintainer: Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
 
 =head1 BUGS
 
@@ -576,8 +697,8 @@
 You can find documentation for this module with the perldoc command.
 
     perldoc Redis
-	perldoc Redis::List
-	perldoc Redis::Hash
+    perldoc Redis::List
+    perldoc Redis::Hash
 
 
 You can also look for information at:
@@ -605,10 +726,24 @@
 
 =head1 ACKNOWLEDGEMENTS
 
+The following persons contributed to this project (alphabetical order):
+
+=over 4
+
+=item Dirk Vleugels
+
+=item Jeremy Zawodny
+
+=item sunnavy at bestpractical.com
+
+=back
+
 
 =head1 COPYRIGHT & LICENSE
 
 Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
+
+Copyright 2011 Pedro Melo, all rights reserved
 
 This program is free software; you can redistribute it and/or modify it
 under the same terms as Perl itself.

Modified: trunk/libredis-perl/lib/Redis/Hash.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/lib/Redis/Hash.pm?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/lib/Redis/Hash.pm (original)
+++ trunk/libredis-perl/lib/Redis/Hash.pm Sat Feb 26 10:42:38 2011
@@ -2,7 +2,6 @@
 
 use strict;
 use warnings;
-
 use Tie::Hash;
 use base qw/Redis Tie::StdHash/;
 
@@ -12,60 +11,87 @@
 
 =head1 SYNOPSYS
 
-  tie %name, 'Redis::Hash', 'prefix';
+    ## Create fake hash using keys like 'hash_prefix:KEY'
+    tie %my_hash, 'Redis::Hash', 'hash_prefix', @Redis_new_parameters;
+    
+    ## Treat the entire Redis database as a hash
+    tie %my_hash, 'Redis::Hash', undef, @Redis_new_parameters;
+    
+    $value = $my_list{$key};
+    $my_list{$key} = $value;
+    
+    @keys   = keys %my_hash;
+    @values = values %my_hash;
+    
+    %my_hash = reverse %my_hash;
+    
+    %my_hash = ();
 
-  my $o = tie %foobar, 'Redis::Hash', 'foobar';
-  print $o->info->{used_memory}; # or any redis command
+
+=head1 DESCRIPTION
+
+Ties a Perl hash to Redis. Note that it doesn't use Redis Hashes, but
+implements a fake hash using regular keys like "prefix:KEY".
+
+If no C<prefix> is given, it will tie the entire Redis database
+as a hash.
+
+Future versions will also allow you to use real Redis hash structures.
+
 
 =cut
 
-# mandatory methods
+
 sub TIEHASH {
-	my ($class,$name) = @_;
-	my $self = Redis->new;
-	$name .= ':' if $name;
-	$self->{name} = $name || '';
-	bless $self => $class;
+  my ($class, $prefix, @rest) = @_;
+  my $self = $class->new(@rest);
+
+  $self->{prefix} = $prefix ? "$prefix:" : '';
+
+  return $self;
 }
 
 sub STORE {
-	my ($self,$key,$value) = @_;
-	$self->set( $self->{name} . $key, $value );
+  my ($self, $key, $value) = @_;
+  $self->set($self->{prefix} . $key, $value);
 }
 
 sub FETCH {
-	my ($self,$key) = @_;
-	$self->get( $self->{name} . $key );
+  my ($self, $key) = @_;
+  $self->get($self->{prefix} . $key);
 }
 
 sub FIRSTKEY {
-	my $self = shift;
-	$self->{keys} = [ $self->keys( $self->{name} . '*' ) ];
-	$self->NEXTKEY;
-} 
+  my $self = shift;
+  $self->{prefix_keys} = [$self->keys($self->{prefix} . '*')];
+  $self->NEXTKEY;
+}
 
 sub NEXTKEY {
-	my $self = shift;
-	my $key = shift @{ $self->{keys} } || return;
-	my $name = $self->{name};
-	$key =~ s{^$name}{} || warn "can't strip $name from $key";
-	return $key;
+  my $self = shift;
+
+  my $key = shift @{$self->{prefix_keys}};
+  return unless defined $key;
+
+  my $p = $self->{prefix};
+  $key =~ s/^$p// if $p;
+  return $key;
 }
 
 sub EXISTS {
-	my ($self,$key) = @_;
-	$self->exists( $self->{name} . $key );
+  my ($self, $key) = @_;
+  $self->exists($self->{prefix} . $key);
 }
 
 sub DELETE {
-	my ($self,$key) = @_;
-	$self->del( $self->{name} . $key );
+  my ($self, $key) = @_;
+  $self->del($self->{prefix} . $key);
 }
 
 sub CLEAR {
-	my ($self) = @_;
-	$self->del( $_ ) foreach ( $self->keys( $self->{name} . '*' ) );
-	$self->{keys} = [];
+  my ($self) = @_;
+  $self->del($_) for $self->keys($self->{prefix} . '*');
+  $self->{prefix_keys} = [];
 }
 
 1;

Modified: trunk/libredis-perl/lib/Redis/List.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libredis-perl/lib/Redis/List.pm?rev=69734&op=diff
==============================================================================
--- trunk/libredis-perl/lib/Redis/List.pm (original)
+++ trunk/libredis-perl/lib/Redis/List.pm Sat Feb 26 10:42:38 2011
@@ -2,7 +2,6 @@
 
 use strict;
 use warnings;
-
 use base qw/Redis Tie::Array/;
 
 =head1 NAME
@@ -11,75 +10,99 @@
 
 =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 );
+  my ($self, $index) = @_;
+  $self->lindex($self->{list}, $index);
 }
 
 sub FETCHSIZE {
-	my ($self) = @_;
-	$self->llen( $self->{name} );
-} 
+  my ($self) = @_;
+  $self->llen($self->{list});
+}
 
 sub STORE {
-	my ($self,$index,$value) = @_;
-	$self->lset( $self->{name}, $index, $value );
+  my ($self, $index, $value) = @_;
+  $self->lset($self->{list}, $index, $value);
 }
 
 sub STORESIZE {
-	my ($self,$count) = @_;
-	$self->ltrim( $self->{name}, 0, $count );
+  my ($self, $count) = @_;
+  $self->ltrim($self->{list}, 0, $count);
+
 #		if $count > $self->FETCHSIZE;
 }
 
 sub CLEAR {
-	my ($self) = @_;
-	$self->del( $self->{name} );
+  my ($self) = @_;
+  $self->del($self->{list});
 }
 
 sub PUSH {
-	my $self = shift;
-	$self->rpush( $self->{name}, $_ ) foreach @_;
+  my $self = shift;
+  my $list = $self->{list};
+
+  $self->rpush($list, $_) for @_;
+}
+
+sub POP {
+  my $self = shift;
+  $self->rpop($self->{list});
 }
 
 sub SHIFT {
-	my $self = shift;
-	$self->lpop( $self->{name} );
+  my ($self) = @_;
+  $self->lpop($self->{list});
 }
 
 sub UNSHIFT {
-	my $self = shift;
-	$self->lpush( $self->{name}, $_ ) foreach @_;
+  my $self = shift;
+  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 );
-	# FIXME rest of @_ ?
+  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 ) );
-} 
-
-sub DESTROY {
-	my $self = shift;
-	$self->quit;
+  my ($self, $count) = @_;
+  $self->rpush($self->{list}, '') for ($self->FETCHSIZE .. ($count - 1));
 }
 
+sub DESTROY { $_[0]->quit }
+
 1;




More information about the Pkg-perl-cvs-commits mailing list