view release on metacpan or  search on metacpan

lib/AnyEvent/Memcached.pm  view on Meta::CPAN

}

sub _get {
	my $self = shift;
	my $cmd  = shift;
	my $keys = shift;
	my %args = @_;
	my $array;
	if (ref $keys and ref $keys eq 'ARRAY') {
		$array = 1;
	}
	if (my ($key) = grep { /[\x00-\x20\x7F]/ } $array ? @$keys : $keys) {
		carp "Invalid characters in key '$key'";
		return $args{cb} ? $args{cb}(undef, "Invalid key") : 0;
	}

	$_ and $_->begin for $self->{cv}, $args{cv};
	my $servers = $self->{hash}->servers($keys, for => 'get');
	my %res;
	my $cv = AE::cv {
		$self->_deflate(\%res);
		$args{cb}( $array ? \%res :  $res{ $keys } );
		$_ and $_->end for $args{cv}, $self->{cv};
	};
	for my $srv ( keys %$servers ) {
		#warn "server for $key = $srv, $self->{peers}{$srv}";
		$cv->begin;
		my $keys = join(' ',map "$self->{namespace}$_", @{ $servers->{$srv} });
		$self->{peers}{$srv}{con}->request( "$cmd $keys" );
		$self->{peers}{$srv}{con}->reader( id => $srv.'+'.$keys, res => \%res, namespace => $self->{namespace}, cb => sub { # cb {
			$cv->end;
		});
	}
	return;
}
sub get  { shift->_get(get => @_) }
sub gets {
	my $self = shift;
	unless ($self->{cas}) { shift;my %args = @_;return $args{cb}(undef, "CAS not enabled") }
	$self->_get(gets => @_)
}

=head2 delete( $key, [cv => $cv], [ noreply => 1 ], cb => $cb->( $rc, $err ) )

Delete $key and its value from the cache.

If C<noreply> is true, cb doesn't required

=head2 del

Alias for "delete"

=head2 remove

Alias for "delete"

=cut

sub delete {
	my $self = shift;
	my ($cmd) = (caller(0))[3] =~ /([^:]+)$/;
	my $key = shift;
	my %args = @_;
	return $args{cb}(undef, "Readonly") if $self->{readonly};
	my $time = $args{delay} ? " $args{delay}" : '';
	return $self->_do(
		$key,
		"delete $self->{namespace}%s$time",
		sub { # cb {
			local $_ = shift;
			if    ($_ eq 'DELETED')    { return 1 }
			elsif ($_ eq 'NOT_FOUND')  { return 0 }
			else                       { return undef, $_ }
		},
		cb => $args{cb},
		noreply => $args{noreply},
	);
}
*del   =  \&delete;
*remove = \&delete;

=head2 incr( $key, $increment, [cv => $cv], [ noreply => 1 ], cb => $cb->( $rc, $err ) )

Increment the value for the $key by $delta. Starting with memcached 1.3.3 $key should be set to a number or the command will fail.
Note that the server doesn't check for overflow.

If C<noreply> is true, cb doesn't required, and if passed, simply called with rc = 1

Similar to DBI, zero is returned as "0E0", and evaluates to true in a boolean context.

=head2 decr( $key, $decrement, [cv => $cv], [ noreply => 1 ], cb => $cb->( $rc, $err ) )

Opposite to C<incr>

=cut

sub _delta {
	my $self = shift;
	my ($cmd) = (caller(1))[3] =~ /([^:]+)$/;
	my $key = shift;
	my $val = shift;
	my %args = @_;
	return $args{cb}(undef, "Readonly") if $self->{readonly};
	return $self->_do(
		$key,
		"$cmd $self->{namespace}%s $val",
		sub { # cb {
			local $_ = shift;
			if    ($_ eq 'NOT_FOUND')  { return 0 }
			elsif (/^(\d+)$/)          { return $1 eq '0' ? '0E0' : $_ }
			else                       { return undef, $_ }
		},
		cb => $args{cb},
		noreply => $args{noreply},
	);
}
sub incr { shift->_delta(@_) }
sub decr { shift->_delta(@_) }

#rget <start key> <end key> <left openness flag> <right openness flag> <max items>\r\n
#
#- <start key> where the query starts.
#- <end key>   where the query ends.
#- <left openness flag> indicates the openness of left side, 0 means the result includes <start key>, while 1 means not.
#- <right openness flag> indicates the openness of right side, 0 means the result includes <end key>, while 1 means not.
#- <max items> how many items at most return, max is 100.

# rget ($from,$till, '+left' => 1, '+right' => 0, max => 10, cb => sub { ... } );

=head2 rget( $from, $till, [ max => 100 ], [ '+left' => 1 ], [ '+right' => 1 ], [cv => $cv], [ rv => 'array' ], cb => $cb->( $rc, $err ) )

Memcachedb 1.2.1-beta implements rget method, that allows to look through the whole storage

=over 4

=item $from

the starting key

=item $till

finishing key

=item +left

If true, then starting key will be included in results. true by default

=item +right

If true, then finishing key will be included in results. true by default

=item max

Maximum number of results to fetch. 100 is the maximum and is the default

=item rv

If passed rv => 'array', then the return value will be arrayref with values in order, returned by memcachedb.

=back

=cut

sub rget {
	my $self = shift;
	#my ($cmd) = (caller(0))[3] =~ /([^:]+)$/;
	my $cmd = 'rget';
	my $from = shift;
	my $till = shift;
	my %args = @_;
	my ($lkey,$rkey);
	#$lkey = ( exists $args{'+left'} && !$args{'+left'} ) ? 1 : 0;
	$lkey = exists $args{'+left'}  ? $args{'+left'}  ? 0 : 1 : 0;
	$rkey = exists $args{'+right'} ? $args{'+right'} ? 0 : 1 : 0;
	$args{max} ||= 100;

	my $result;
	if (lc $args{rv} eq 'array') {
		$result = [];
	} else {
		$result = {};
	}
	my $err;
	my $cv = AnyEvent->condvar;
	$_ and $_->begin for $self->{cv}, $args{cv};
	$cv->begin(sub {
		undef $cv;
		$self->_deflate($result);
		$args{cb}( $err ? (undef,$err) : $result );
		undef $result;
		$_ and $_->end for $args{cv}, $self->{cv};
	});

	for my $peer (keys %{$self->{peers}}) {
		$cv->begin;
		my $do;$do = sub {
			undef $do;
			$self->{peers}{$peer}{con}->request( "$cmd $self->{namespace}$from $self->{namespace}$till $lkey $rkey $args{max}" );
			$self->{peers}{$peer}{con}->reader( id => $peer, res => $result, namespace => $self->{namespace}, cb => sub {
				#warn "rget from: $peer";
				$cv->end;
			});
		};
		if (exists $self->{peers}{$peer}{rget_ok}) {
			if ($self->{peers}{$peer}{rget_ok}) {
				$do->();
			} else {
				#warn
					$err = "rget not supported on peer $peer";
				$cv->end;
			}
		} else {
			$self->{peers}{$peer}{con}->command( "$cmd 1 0 0 0 1", cb => sub {
				local $_ = shift;
				if (defined $_) {
					if ($_ eq 'END') {
						$self->{peers}{$peer}{rget_ok} = 1;
						$do->();
					}
					else {
						#warn
							$err = "rget not supported on peer $peer: @_";
						$self->{peers}{$peer}{rget_ok} = 0;
						undef $do;
						$cv->end;
					}