New file dump format, perl client library added

client-libraries/perl/lib/Redis.pm

@@ -0,0 +1,422 @@
+package Redis;
+
+use warnings;
+use strict;
+
+use IO::Socket::INET;
+use Data::Dump qw/dump/;
+use Carp qw/confess/;
+
+=head1 NAME
+
+Redis - perl binding for Redis database
+
+=cut
+
+our $VERSION = '0.08';
+
+
+=head1 DESCRIPTION
+
+Pure perl bindings for L<http://code.google.com/p/redis/>
+
+This version support git version 0.08 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
+
+=head2 new
+
+  my $r = Redis->new;
+
+=cut
+
+our $debug = $ENV{REDIS} || 0;
+
+our $sock;
+my $server = '127.0.0.1:6379';
+
+sub new {
+	my $class = shift;
+	my $self = {};
+	bless($self, $class);
+
+	warn "# opening socket to $server";
+
+	$sock ||= IO::Socket::INET->new(
+		PeerAddr => $server,
+		Proto => 'tcp',
+	) || die $!;
+
+	$self;
+}
+
+my $bulk_command = {
+	set => 1,	setnx => 1,
+	rpush => 1,	lpush => 1,
+	lset => 1,	lrem => 1,
+	sadd => 1,	srem => 1,
+	sismember => 1,
+	echo => 1,
+};
+
+# we don't want DESTROY to fallback into AUTOLOAD
+sub DESTROY {}
+
+our $AUTOLOAD;
+sub AUTOLOAD {
+	my $self = shift;
+
+	my $command = $AUTOLOAD;
+	$command =~ s/.*://;
+
+	warn "## $command ",dump(@_) if $debug;
+
+	my $send;
+
+	if ( defined $bulk_command->{$command} ) {
+		my $value = pop;
+		$value = '' if ! defined $value;
+		$send
+			= uc($command)
+			. ' '
+			. join(' ', @_)
+			. ' ' 
+			. length( $value )
+			. "\r\n$value\r\n"
+			;
+	} else {
+		$send
+			= uc($command)
+			. ' '
+			. join(' ', @_)
+			. "\r\n"
+			;
+	}
+
+	warn ">> $send" if $debug;
+	print $sock $send;
+
+	if ( $command eq 'quit' ) {
+		close( $sock ) || die "can't close socket: $!";
+		return 1;
+	}
+
+	my $result = <$sock> || die "can't read socket: $!";
+	warn "<< $result" if $debug;
+	my $type = substr($result,0,1);
+	$result = substr($result,1,-2);
+
+	if ( $command eq 'info' ) {
+		my $hash;
+		foreach my $l ( split(/\r\n/, __sock_read_bulk($result) ) ) {
+			my ($n,$v) = split(/:/, $l, 2);
+			$hash->{$n} = $v;
+		}
+		return $hash;
+	} elsif ( $command eq 'keys' ) {
+		my $keys = __sock_read_bulk($result);
+		return split(/\s/, $keys) if $keys;
+		return;
+	}
+
+	if ( $type eq '-' ) {
+		confess $result;
+	} elsif ( $type eq '+' ) {
+		return $result;
+	} elsif ( $type eq '$' ) {
+		return __sock_read_bulk($result);
+	} elsif ( $type eq '*' ) {
+		return __sock_read_multi_bulk($result);
+	} elsif ( $type eq ':' ) {
+		return $result; # FIXME check if int?
+	} else {
+		confess "unknown type: $type", __sock_read_line();
+	}
+}
+
+sub __sock_read_bulk {
+	my $len = shift;
+	return undef if $len < 0;
+
+	my $v;
+	if ( $len > 0 ) {
+		read($sock, $v, $len) || die $!;
+		warn "<< ",dump($v),$/ if $debug;
+	}
+	my $crlf;
+	read($sock, $crlf, 2); # skip cr/lf
+	return $v;
+}
+
+sub __sock_read_multi_bulk {
+	my $size = shift;
+	return undef if $size < 0;
+
+	$size--;
+
+	my @list = ( 0 .. $size );
+	foreach ( 0 .. $size ) {
+		$list[ $_ ] = __sock_read_bulk( substr(<$sock>,1,-2) );
+	}
+
+	warn "## list = ", dump( @list ) if $debug;
+	return @list;
+}
+
+1;
+
+__END__
+
+=head1 Connection Handling
+
+=head2 quit
+
+  $r->quit;
+
+=head2 ping
+
+  $r->ping || die "no server?";
+
+=head1 Commands operating on string values
+
+=head2 set
+
+  $r->set( foo => 'bar' );
+
+  $r->setnx( foo => 42 );
+
+=head2 get
+
+  my $value = $r->get( 'foo' );
+
+=head2 mget
+
+  my @values = $r->mget( 'foo', 'bar', 'baz' );
+
+=head2 incr
+
+  $r->incr('counter');
+
+  $r->incrby('tripplets', 3);
+
+=head2 decr
+
+  $r->decr('counter');
+
+  $r->decrby('tripplets', 3);
+
+=head2 exists
+
+  $r->exists( 'key' ) && print "got key!";
+
+=head2 del
+
+  $r->del( 'key' ) || warn "key doesn't exist";
+
+=head2 type
+
+  $r->type( 'key' ); # = string
+
+=head1 Commands operating on the key space
+
+=head2 keys
+
+  my @keys = $r->keys( '*glob_pattern*' );
+
+=head2 randomkey
+
+  my $key = $r->randomkey;
+
+=head2 rename
+
+  my $ok = $r->rename( 'old-key', 'new-key', $new );
+
+=head2 dbsize
+
+  my $nr_keys = $r->dbsize;
+
+=head1 Commands operating on lists
+
+See also L<Redis::List> for tie interface.
+
+=head2 rpush
+
+  $r->rpush( $key, $value );
+
+=head2 lpush
+
+  $r->lpush( $key, $value );
+
+=head2 llen
+
+  $r->llen( $key );
+
+=head2 lrange
+
+  my @list = $r->lrange( $key, $start, $end );
+
+=head2 ltrim
+
+  my $ok = $r->ltrim( $key, $start, $end );
+
+=head2 lindex
+
+  $r->lindex( $key, $index );
+
+=head2 lset
+
+  $r->lset( $key, $index, $value );
+
+=head2 lrem
+
+  my $modified_count = $r->lrem( $key, $count, $value );
+
+=head2 lpop
+
+  my $value = $r->lpop( $key );
+
+=head2 rpop
+
+  my $value = $r->rpop( $key );
+
+=head1 Commands operating on sets
+
+=head2 sadd
+
+  $r->sadd( $key, $member );
+
+=head2 srem
+
+  $r->srem( $key, $member );
+
+=head2 scard
+
+  my $elements = $r->scard( $key );
+
+=head2 sismember
+
+  $r->sismember( $key, $member );
+
+=head2 sinter
+
+  $r->sinter( $key1, $key2, ... );
+
+=head2 sinterstore
+
+  my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
+
+=head1 Multiple databases handling commands
+
+=head2 select
+
+  $r->select( $dbindex ); # 0 for new clients
+
+=head2 move
+
+  $r->move( $key, $dbindex );
+
+=head2 flushdb
+
+  $r->flushdb;
+
+=head2 flushall
+
+  $r->flushall;
+
+=head1 Sorting
+
+=head2 sort
+
+  $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
+
+=head1 Persistence control commands
+
+=head2 save
+
+  $r->save;
+
+=head2 bgsave
+
+  $r->bgsave;
+
+=head2 lastsave
+
+  $r->lastsave;
+
+=head2 shutdown
+
+  $r->shutdown;
+
+=head1 Remote server control commands
+
+=head2 info
+
+  my $info_hash = $r->info;
+
+=head1 AUTHOR
+
+Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
+the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>.  I will be notified, and then you'll
+automatically be notified of progress on your bug as I make changes.
+
+
+
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+    perldoc Redis
+	perldoc Redis::List
+	perldoc Redis::Hash
+
+
+You can also look for information at:
+
+=over 4
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Redis>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Redis>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Redis>
+
+=back
+
+
+=head1 ACKNOWLEDGEMENTS
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2009 Dobrica Pavlinusic, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+
+=cut
+
+1; # End of Redis

client-libraries/perl/lib/Redis/Hash.pm

@@ -0,0 +1,70 @@
+package Redis::Hash;
+
+use strict;
+use warnings;
+
+use Tie::Hash;
+use base qw/Redis Tie::StdHash/;
+
+use Data::Dump qw/dump/;
+
+=head1 NAME
+
+Redis::Hash - tie perl hashes into Redis
+
+=head1 SYNOPSYS
+
+  tie %name, 'Redis::Hash', 'prefix';
+
+=cut
+
+# mandatory methods
+sub TIEHASH {
+	my ($class,$name) = @_;
+	my $self = Redis->new;
+	$name .= ':' if $name;
+	$self->{name} = $name || '';
+	bless $self => $class;
+}
+
+sub STORE {
+	my ($self,$key,$value) = @_;
+	$self->set( $self->{name} . $key, $value );
+}
+
+sub FETCH {
+	my ($self,$key) = @_;
+	$self->get( $self->{name} . $key );
+}
+
+sub FIRSTKEY {
+	my $self = shift;
+	$self->{keys} = [ $self->keys( $self->{name} . '*' ) ];
+	$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;
+}
+
+sub EXISTS {
+	my ($self,$key) = @_;
+	$self->exists( $self->{name} . $key );
+}
+
+sub DELETE {
+	my ($self,$key) = @_;
+	$self->del( $self->{name} . $key );
+}
+
+sub CLEAR {
+	my ($self) = @_;
+	$self->del( $_ ) foreach ( $self->keys( $self->{name} . '*' ) );
+	$self->{keys} = [];
+}
+
+1;

client-libraries/perl/lib/Redis/List.pm

@@ -0,0 +1,85 @@
+package Redis::List;
+
+use strict;
+use warnings;
+
+use base qw/Redis Tie::Array/;
+
+=head1 NAME
+
+Redis::List - tie perl arrays into Redis lists
+
+=head1 SYNOPSYS
+
+  tie @a, 'Redis::List', 'name';
+
+=cut
+
+# mandatory methods
+sub TIEARRAY {
+	my ($class,$name) = @_;
+	my $self = $class->new;
+	$self->{name} = $name;
+	bless $self => $class;
+}
+
+sub FETCH {
+	my ($self,$index) = @_;
+	$self->lindex( $self->{name}, $index );
+}
+
+sub FETCHSIZE {
+	my ($self) = @_;
+	$self->llen( $self->{name} );
+} 
+
+sub STORE {
+	my ($self,$index,$value) = @_;
+	$self->lset( $self->{name}, $index, $value );
+}
+
+sub STORESIZE {
+	my ($self,$count) = @_;
+	$self->ltrim( $self->{name}, 0, $count );
+#		if $count > $self->FETCHSIZE;
+}
+
+sub CLEAR {
+	my ($self) = @_;
+	$self->del( $self->{name} );
+}
+
+sub PUSH {
+	my $self = shift;
+	$self->rpush( $self->{name}, $_ ) foreach @_;
+}
+
+sub SHIFT {
+	my $self = shift;
+	$self->lpop( $self->{name} );
+}
+
+sub UNSHIFT {
+	my $self = shift;
+	$self->lpush( $self->{name}, $_ ) foreach @_;
+}
+
+sub SPLICE {
+	my $self = shift;
+	my $offset = shift;
+	my $length = shift;
+	$self->lrange( $self->{name}, $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;
+}
+
+1;