Gecko [ www.jdcpatala.org ]

Name	Size	Permission
File	[ DIR ]	drwxr-xr-x
SafeProcess	[ DIR ]	drwxr-xr-x
Config.pm	9.98 KB	-rw-r--r--
ConfigFactory.pm	18.66 KB	-rw-r--r--
CoreDump.pm	8.98 KB	-rw-r--r--
Exec.pm	4.24 KB	-rw-r--r--
Find.pm	7.62 KB	-rw-r--r--
Handles.pm	2.04 KB	-rw-r--r--
Memcache.pm	26.33 KB	-rw-r--r--
Options.pm	4.19 KB	-rw-r--r--
Platform.pm	4.05 KB	-rw-r--r--
SafeProcess.pm	14.42 KB	-rw-r--r--
SysInfo.pm	5.45 KB	-rw-r--r--
Test.pm	3.81 KB	-rw-r--r--

Code Editor : Memcache.pm

# -*- cperl -*-
# Copyright (c) 2013, 2022, Oracle and/or its affiliates.
# All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License, version 2.0,
# as published by the Free Software Foundation.
#
# This program is also distributed with certain software (including
# but not limited to OpenSSL) that is licensed under separate terms,
# as designated in a particular file or component or in included license
# documentation.  The authors of MySQL hereby grant you an additional
# permission to link the program and your derivative works with the
# separately licensed software that they have included with MySQL.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License, version 2.0, for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301  USA

########## Memcache Client Library for Perl
### 
###  $mc = My::Memcache->new()          create an ascii-protocol client 
###  $mc = My::Memcache::Binary->new()  create a binary-protocol client
###
###  $mc->connect(host, port)           returns 1 on success, 0 on failure
### 
###  $mc->{error}                       holds most recent error/status message
### 
###  $mc->store(cmd, key, value, ...)   alternate API for set/add/replace/append/prepend
###  $mc->set(key, value)               returns 1 on success, 0 on failure
###  $mc->add(key, value)               set if record does not exist
###  $mc->replace(key, value)           set if record exists
###  $mc->append(key, value)            append value to existing data
###  $mc->prepend(key, value)           prepend value to existing data
###
###  $mc->get(key, [ key ...])          returns a value or undef 
###  $mc->next_result()                 Fetch results after get()
### 
###  $mc->delete(key)                   returns 1 on success, 0 on failure
###  $mc->stats(stat_key)               get stats; returns a hash
###  $mc->incr(key, amount, [initial])  returns the new value or undef
###  $mc->decr(key, amount, [initial])  like incr.  
###                                           The third argument is used in
###                                           the binary protocol ONLY. 
###  $mc->flush()                       flush_all
###
###  $mc->set_expires(sec)              Set TTL for all store operations
###  $mc->set_flags(int_flags)          Set numeric flags for store operations
###
###  $mc->note_config_version() 
###    Store the generation number of the running config in the filesystem,
###    for later use by wait_for_reconf()
### 
###  $mc->wait_for_reconf()
###    Wait for NDB/Memcache to complete online reconfiguration.  
###    Returns the generation number of the newly running configuration, 
###    or zero on timeout/error.

################ TODO ################################
###  * Support explicit binary k/q commands with pipelining
###  * Implement TOUCH & GAT commands
###  * Support UDP
###  * Standardize APIs to take (key, value, hashref-of-options)

use strict;
use IO::Socket::INET;
use IO::File;
use Carp;
use Time::HiRes;
use Errno qw( EWOULDBLOCK );

######## Memcache Result

package My::Memcache::Result;

sub new {
  my ($pkg, $key, $flags, $cas) = @_;
  $cas = 0 if(! defined($cas));
  bless {
    "key" => $key,
    "flags" => $flags,
    "cas" => $cas,
    "value" => undef,
  }, $pkg;
}

######## Memcache Client

package My::Memcache;

sub new {
  my $pkg = shift;
  # min/max wait refer to msec. wait during temporary errors.  Both powers of 2.
  # io_timeout is in seconds (possibly fractional)
  # io_timeout * max_read_tries = read timeout
  bless { "created" => 1 , "error" => "OK" , "cf_gen" => 0, "req_id" => 0,
          "min_wait" => 4,  "max_wait" => 8192, "temp_errors" => 0 ,
          "total_wait" => 0, "has_cas" => 0, "flags" => 0, "exptime" => 0,
          "get_results" => undef, "get_with_cas" => 0, "failed" => 0,
          "io_timeout" => 5.0, "sysread_size" => 512, "max_read_tries" => 6,
          "readbuf" => "", "buflen" => 0, "error_detail" => "", "read_try" => 0,
          "max_write_tries" => 6
        }, $pkg;
}

sub summarize {
  my $val = shift;
  my $len = length $val;

if($len > 25) {
    return substr($val,0,10) . "..." . substr($val,-10) . " [len $len]";
  } else {
    return $val;
  }
}

# fail() is called when an MTR test fails
sub fail {
  my $self = shift;
  my $fd;

if($self->{failed}) {
    print STDERR " /// My::Memcache::fail() called recursively.\n";
    return;
  }
  $self->{failed} = 1;

my $msg =
      "error: "         . $self->{error}       ."\t".
      "read_try: "      . $self->{read_try}    ."\t".
      "protocol: "      . $self->protocol()    ."\n".
      "req_id: "        . $self->{req_id}      ."\t".
      "temp err wait: " . $self->{total_wait}  ." msec.\n";

$msg .= "detail: " . $self->{error_detail} . "\n";
  $msg .= "buffer: " . summarize($self->{readbuf}) . "\n";

my $r = $self->next_result();
  $msg .= "value: " . summarize($r->{value}) . "\n" if($r);

while(my $extra = shift) {
    $msg .= $extra;
  }
  $msg .= "\n";

$msg .= $self->get_server_error_stats();

# Load Average on linux
  $msg .= ("Load Avg: " . <$fd>) if(open($fd, "/proc/loadavg"));

$msg .= "====~~~~____~~~~====\n";

Carp::confess($msg);
}

# Attempt a new connection to memcached to flush the server's error log
# and obtain error statistics

sub get_server_error_stats {
  my $self = shift;
  my $new_client = My::Memcache::Binary->new();
  my $r = $new_client->connect($self->{host}, $self->{port});
  my $msg = "";

if($r) {
    my %stats = $new_client->stats("errors");  # also flushes server log
    $msg .= "Server error stats:\n";
    $msg .= sprintf("%s : %s\n", $_, $stats{$_}) for keys(%stats);
  } else {
    $msg = "Attempted new server connection to fetch error statistics but failed.\n";
  }
  return $msg;
}

# Common code to ASCII and BINARY protocols:

sub connect {
  my $self = shift;
  my $host = shift;
  my $port = shift; 
  my $conn;
  
  # Wait for memcached to be ready, up to ten seconds.
  my $retries = 100;
  do {
    $conn = IO::Socket::INET->new(PeerAddr => "$host:$port", Proto => "tcp");
    if(! $conn) { 
      Time::HiRes::usleep(100 * 1000);
      $retries--;   
    }
  } while($retries && !$conn);

if($conn) {
    $conn->blocking(0);    # Set non-blocking
    my $fd = fileno $conn;
    my $fdset = '';
    vec($fdset, $fd, 1) = 1;
    $self->{fdset} = $fdset;
    $self->{connection} = $conn;
    $self->{host} = $host;
    $self->{port} = $port;
    return 1;
  }
  $self->{error} = "CONNECTION_FAILED";
  return 0;
}

sub DESTROY {
  my $self = shift;
  if($self->{connection}) {
    $self->{connection}->close();
  }
}

sub set_expires {
  my $self = shift;
  $self->{exptime} = shift;  
}

sub set_flags {
  my $self = shift;
  $self->{flags} = shift;
}

# Some member variables are per-request.  
# Clear them in preparation for a new request, and increment the request counter.
sub new_request {
  my $self = shift;
  $self->{error} = "OK";
  $self->{read_try} = 0;
  $self->{has_cas} = 0;
  $self->{req_id}++;
  $self->{get_results} = undef;
}

sub next_result {
  my $self = shift;
  shift @{$self->{get_results}};
}

# note_config_version and wait_for_reconf are only for use by mysql-test-run
sub note_config_version {
  my $self = shift;

my $vardir = $ENV{MYSQLTEST_VARDIR};
  # Fetch the memcached current config generation number and save it
  my %stats = $self->stats("reconf");
  my $F = IO::File->new("$vardir/tmp/memcache_cf_gen", "w") or die;
  my $ver = $stats{"Running"};
  print $F "$ver\n";
  $F->close();

$self->{cf_gen} = $ver;
}

sub wait_for_reconf {
  my $self = shift;

if($self->{cf_gen} == 0) { 
    my $cfgen = 0;
    my $vardir = $ENV{MYSQLTEST_VARDIR};
    my $F = IO::File->new("$vardir/tmp/memcache_cf_gen", "r");
    if(defined $F) {
      chomp($cfgen = <$F>);
      undef $F;
    }
    $self->{cf_gen} = $cfgen;
  }
  
  my $wait_for = $self->{cf_gen} + 1 ;

my $new_gen = $self->wait_for_config_generation($wait_for);
  if($new_gen > 0) {
    $self->{cf_gen} = $new_gen;
  }
  else {
    print STDERR "Wait for config generation $wait_for timed out.\n";
  }
  
  return $new_gen;
}
  
# wait_for_config_generation($cf_gen)
# Wait until memcached is running config generation >= to $cf_gen
# Returns 0 on error/timeout, or the actual running generation number
#
sub wait_for_config_generation {
  my $self = shift;
  my $cf_gen = shift;
  my $ready = 0;
  my $retries = 100;   # 100 retries x 100 ms = 10s
  
  while($retries && ! $ready) {
    Time::HiRes::usleep(100 * 1000);
    my %stats = $self->stats("reconf");
    if($stats{"Running"} >= $cf_gen) {
      $ready = $stats{"Running"};
    }
    else {
      $retries -= 1;
    }
  }
  return $ready;
}

#  -----------------------------------------------------------------------
#  --------------        Low-level Network Handling        ---------------
#  -----------------------------------------------------------------------

# Utility function sets error based on network error & returns false.
sub socket_error {
  my $self = shift;
  my $retval = shift;
  my $detail = shift;

if($retval == 1) {
    $self->{error} = "CONNECTION_CLOSED";
  } elsif($retval == 0) {
    $self->{error} = "NETWORK_TIMEOUT";
  } else {
    $self->{error} = "NETWORK_ERROR: " . $!;
  }
  $self->{error_detail} = $detail if($detail);

return 0;
}

# $mc->write(packet).  Returns true on success, false on error.
sub write {
  my $self = shift;
  my $packet = shift;
  my $len = length($packet);
  my $nsent = 0;
  my $attempt = 0;
  my $r;

if(! $self->{connection}->connected()) {
    return $self->socket_error(0, "write(): not connected");
  }

while($nsent < $len) {
    $r = select(undef, $self->{fdset}, undef, $self->{io_timeout});
    if($r < 1) {
      if(++$attempt >= $self->{max_write_tries}) {
        return $self->socket_error($r, "write(): select() returned $r");
      }
    } else {
      $r = $self->{connection}->send(substr($packet, $nsent));
      if($r > 0) {
        $nsent += $r;
      } elsif($! != Errno::EWOULDBLOCK) {
        return $self->socket_error($r, "write(): send() errno $!");
      }
    }
  }
  return 1;
}

# $mc->read(desired_size).  Low-level read.  Returns true on success,
# appends data to readbuf, and sets buflen.  Returns false on error.
sub read {
  my $self = shift;
  my $length = shift;
  my $sock = $self->{connection};
  my $r;

if($length > 0) {
    $r = select($self->{fdset}, undef, undef, $self->{io_timeout});
    return $self->socket_error($r, "read(): select() $!") if($r < 0);

$r = $sock->sysread($self->{readbuf}, $length, $self->{buflen});
    if($r > 0) {
      $self->{buflen} += $r;
    } elsif($r < 0 && $! != Errno::EWOULDBLOCK) {
      return $self->socket_error( $r == 0 ? 1 : $r, "read(): sysread() $!");
    }
  }
  return 1;
}

# Utility routine; assumes $len is available on buffer.
sub chop_from_buffer {
  my $self = shift;
  my $len = shift;

my $line = substr($self->{readbuf}, 0, $len);
  $self->{readbuf} = substr($self->{readbuf}, $len);
  $self->{buflen} -= $len;
  return $line;
}

# Returns a line if available; otherwise undef
sub get_line_from_buffer {
  my $self = shift;
  my $line = undef;

my $idx = index($self->{readbuf}, "\r\n");
  if($idx >= 0) {
    $line = $self->chop_from_buffer($idx + 2);  # 2 for \r\n
  }
  return $line;
}

# Returns length if available; otherwise undef
sub get_length_from_buffer {
  my $self = shift;
  my $len = shift;

if($self->{buflen} >= $len) {
    return $self->chop_from_buffer($len);
  }
  return undef;
}

# Read up to newline.  Returns a line, or sets and returns error.
sub read_line {
  my $self = shift;
  my $message;

$self->{read_try} = 0;
  while((! defined($message)) && $self->{read_try} < $self->{max_read_tries}) {
    $self->{read_try}++;
    $message = $self->get_line_from_buffer();
    if(! defined($message)) {
      if(! $self->read($self->{sysread_size})) {
        return $self->{error};
      }
    }
  }
  if(defined($message)) {
    $self->normalize_error($message);  # handle server error responses
    return $message;
  }

$self->socket_error(0, "read_line(): timeout");
  return $self->{error};
}

# Read <length> bytes.  Returns the data, or returns undef and sets error.
sub read_known_length {
  my $self = shift;
  my $len = shift;
  my $data;

$self->{read_try} = 0;
  while($self->{read_try} < $self->{max_read_tries}) {
    $self->{read_try}++;
    $data = $self->get_length_from_buffer($len);
    return $data if(defined($data));
    if(! $self->read($len - $self->{buflen})) {
      return undef;
    }
  }
  # Perhaps the read completed on the final attempt
  $data = $self->get_length_from_buffer($len);
  if(! defined($data)) {
    $self->socket_error(0, "read_known_length(): timeout");
  }
  return $data;
}

#  -----------------------------------------------------------------------
#  ------------------          ASCII PROTOCOL         --------------------
#  -----------------------------------------------------------------------

sub protocol {
  return "ascii";
}

sub protocol_error {
  my $self = shift;
  my $detail = shift;

if($self->{error} eq "OK") {
    $self->{error} = "PROTOCOL_ERROR";
  }
  if($detail) {
    $self->{error_detail} = $detail;
  }
  return undef;
}

sub ascii_command {
  my $self = shift;
  my $packet = shift;
  my $waitTime = $self->{min_wait};
  my $maxWait = $self->{max_wait};
  my $reply;
  
  do {
    $self->new_request();
    $self->write($packet);
    $reply = $self->read_line();
    if($self->{error} eq "SERVER_TEMPORARY_ERROR" && $waitTime < $maxWait) {
      $self->{temp_errors} += 1;
      $self->{total_wait} += ( Time::HiRes::usleep($waitTime * 1000) / 1000);
      $waitTime *= 2;
    }
  } while($self->{error} eq "SERVER_TEMPORARY_ERROR" && $waitTime <= $maxWait);

return $reply;
}

sub delete {
  my $self = shift;
  my $key = shift;
  my $response = $self->ascii_command("delete $key\r\n");
  return 1 if($response =~ "^DELETED");
  return 0 if($response =~ "^NOT_FOUND");
  return 0 if($response =~ "^SERVER_ERROR");
  return $self->protocol_error("delete() got response: $response");
}

sub store {
  my ($self, $cmd, $key, $value, $flags, $exptime, $cas_chk) = @_;
  $flags   = $self->{flags}   unless $flags;
  $exptime = $self->{exptime} unless $exptime;
  my $packet;
  if(($cmd eq "cas" || $cmd eq "replace") && $cas_chk > 0)
  {
    $packet = sprintf("cas %s %d %d %d %d\r\n%s\r\n", 
                      $key, $flags, $exptime, $cas_chk, length($value), $value);
  }
  else 
  {
    $packet = sprintf("%s %s %d %d %d\r\n%s\r\n",
                      $cmd, $key, $flags, $exptime, length($value), $value);
  }
  my $response = $self->ascii_command($packet);
  return 1 if($response =~ "^STORED");
  return 0 if($response =~ "^NOT_STORED");
  return 0 if($response =~ "^EXISTS");
  return 0 if($response =~ "^NOT_FOUND");
  return 0 if($response =~ "^SERVER_ERROR");
  return $self->protocol_error("store() got response: $response");
}
 
sub set {
  my ($self, $key, $value, $flags, $exptime) = @_;  
  return $self->store("set", $key, $value, $flags, $exptime);
}

sub add {
  my ($self, $key, $value, $flags, $exptime) = @_;  
  return $self->store("add", $key, $value, $flags, $exptime);
}

sub append {
  my ($self, $key, $value, $flags, $exptime) = @_;  
  return $self->store("append", $key, $value, $flags, $exptime);
}

sub prepend {    
  my ($self, $key, $value, $flags, $exptime) = @_;  
  return $self->store("prepend", $key, $value, $flags, $exptime);
}

sub replace {
  my ($self, $key, $value, $flags, $exptime, $cas) = @_;  
  return $self->store("replace", $key, $value, $flags, $exptime, $cas);
}

sub get {
  my $self = shift;
  my @results;
  my $keys = "";
  $keys .= shift(@_) . " " while(@_);
  my $command = $self->{get_with_cas} ? "gets" : "get";
  $self->{get_with_cas} = 0; # CHECK, THEN RESET FOR NEXT CALL
  my $response = $self->ascii_command("$command $keys\r\n");
  return undef if($self->{error} ne "OK");
  while ($response ne "END\r\n")
  {
    $response =~ /^VALUE (\S+) (\d+) (\d+) ?(\d+)?/;
    if(! (defined($1) && defined($2) && defined($3))) {
      return $self->protocol_error("GET response: $response");
    }
    my $result = My::Memcache::Result->new($1, $2, $4);
    my $value = $self->read_known_length($3);
    return undef if(!defined($value));
    $result->{value} = $value;
    $self->read_line();  # Get trailing \r\n after value
    $self->{has_cas} = 1 if($4);
    push @results, $result;
    $response = $self->read_line();
  }
  $self->{get_results} = \@results;
  return $results[0]->{value} if @results;
  $self->{error} = "NOT_FOUND";
  return undef;
}

sub _txt_math {
  my ($self, $cmd, $key, $delta) = @_;
  my $response = $self->ascii_command("$cmd $key $delta \r\n");
  
  if ($response =~ "^NOT_FOUND" || $response =~ "ERROR") {
    return undef;
  }

$response =~ /(\d+)/;
  return $self->protocol_error("MATH response: $response") unless defined($1);
  return $1;
}

sub incr {
  my ($self, $key, $delta) = @_;
  return $self->_txt_math("incr", $key, $delta);
}

sub decr {
  my ($self, $key, $delta) = @_;
  return $self->_txt_math("decr", $key, $delta);
}

sub stats {
  my $self = shift;
  my $key = shift || "";

$self->new_request();
  $self->write("stats $key\r\n");
  
  my %response = ();
  my $line = $self->read_line();
  while($line !~ "^END") {
    return %response if $line eq "ERROR\r\n";
    if(($line) && ($line =~ /^STAT(\s+)(\S+)(\s+)(\S+)/)) {
      $response{$2} = $4;
    } else {
      return $self->protocol_error("STATS response line: $line");
    }
    $line = $self->read_line();
  }
  
  return %response;
}

sub flush {
  my $self = shift;
  my $key = shift;
  my $result = $self->ascii_command("flush_all\r\n");
  return ($self->{error} eq "OK");
}

# Try to provide consistent error messagees across ascii & binary protocols
sub normalize_error {
  my $self = shift;
  my $reply = shift;
  my %error_message = (
  "STORED\r\n"                         => "OK",
  "EXISTS\r\n"                         => "KEY_EXISTS",
  "NOT_FOUND\r\n"                      => "NOT_FOUND",
  "NOT_STORED\r\n"                     => "NOT_STORED",
  "CLIENT_ERROR value too big\r\n"     => "VALUE_TOO_LARGE",
  "SERVER_ERROR object too large for cache\r\n"     => "VALUE_TOO_LARGE",
  "CLIENT_ERROR invalid arguments\r\n" => "INVALID_ARGUMENTS",
  "SERVER_ERROR not my vbucket\r\n"    => "NOT_MY_VBUCKET",
  "SERVER_ERROR out of memory\r\n"     => "SERVER_OUT_OF_MEMORY",
  "SERVER_ERROR not supported\r\n"     => "NOT_SUPPORTED",
  "SERVER_ERROR internal\r\n"          => "INTERNAL_ERROR",
  "SERVER_ERROR temporary failure\r\n" => "SERVER_TEMPORARY_ERROR"
  );  
  $self->{error} = $error_message{$reply} || "OK";
  return 0;
}

#  -----------------------------------------------------------------------
#  ------------------         BINARY PROTOCOL         --------------------
#  -----------------------------------------------------------------------

package My::Memcache::Binary;
BEGIN { @My::Memcache::Binary::ISA = qw(My::Memcache); }
use constant BINARY_HEADER_FMT  => "CCnCCnNNNN";
use constant BINARY_REQUEST     => 0x80;
use constant BINARY_RESPONSE    => 0x81;

use constant BIN_CMD_GET        => 0x00;
use constant BIN_CMD_SET        => 0x01;
use constant BIN_CMD_ADD        => 0x02;
use constant BIN_CMD_REPLACE    => 0x03;
use constant BIN_CMD_DELETE     => 0x04;
use constant BIN_CMD_INCR       => 0x05;
use constant BIN_CMD_DECR       => 0x06;
use constant BIN_CMD_QUIT       => 0x07;
use constant BIN_CMD_FLUSH      => 0x08;
use constant BIN_CMD_NOOP       => 0x0A;
use constant BIN_CMD_GETK       => 0x0C;
use constant BIN_CMD_GETKQ      => 0x0D;
use constant BIN_CMD_APPEND     => 0x0E;
use constant BIN_CMD_PREPEND    => 0x0F;
use constant BIN_CMD_STAT       => 0x10;

sub protocol {
  return "binary";
}

sub error_message {
  my ($self, $code) = @_;
  my %error_messages = (
   0x00 => "OK",
   0x01 => "NOT_FOUND",
   0x02 => "KEY_EXISTS", 
   0x03 => "VALUE_TOO_LARGE",
   0x04 => "INVALID_ARGUMENTS",
   0x05 => "NOT_STORED",
   0x06 => "NON_NUMERIC_VALUE",
   0x07 => "NOT_MY_VBUCKET",
   0x81 => "UNKNOWN_COMMAND",
   0x82 => "SERVER_OUT_OF_MEMORY",
   0x83 => "NOT_SUPPORTED",
   0x84 => "INTERNAL_ERROR",
   0x85 => "SERVER_BUSY",
   0x86 => "SERVER_TEMPORARY_ERROR",
   0x100 => "PROTOCOL_ERROR",
   0x101 => "NETWORK_ERROR"
  );
  return $error_messages{$code};
}

# Returns true on success, false on error
sub send_binary_request {
  my $self = shift;
  my ($cmd, $key, $val, $extra_header, $cas) = @_;

$cas = 0 unless $cas;
  my $key_len    = length($key);
  my $val_len    = length($val);
  my $extra_len  = length($extra_header);
  my $total_len  = $key_len + $val_len + $extra_len;
  my $cas_hi     = ($cas >> 32) & 0xFFFFFFFF;
  my $cas_lo     = ($cas & 0xFFFFFFFF);

$self->new_request();
  
  my $header = pack(BINARY_HEADER_FMT, BINARY_REQUEST, $cmd,
                    $key_len, $extra_len, 0, 0, $total_len, 
                    $self->{req_id}, $cas_hi, $cas_lo);
  my $packet = $header . $extra_header . $key . $val;

return $self->write($packet);
}

sub get_binary_response {
  my $self = shift;
  my $header_len = length(pack(BINARY_HEADER_FMT));
  my $header;
  my $body;

$header = $self->read_known_length($header_len);
  return (0x101) if(! defined($header));

my ($magic, $cmd, $key_len, $extra_len, $datatype, $status, $body_len,
      $sequence, $cas_hi, $cas_lo) = unpack(BINARY_HEADER_FMT, $header);

if($magic != BINARY_RESPONSE) {
    $self->{error_detail} = "Magic number in response: $magic";
    return (0x100);
  }

$body = $self->read_known_length($body_len);
  $self->{error} = $self->error_message($status);

# Packet structure is: header .. extras .. key .. value 
  my $cas = ($cas_hi * (2 ** 32)) + $cas_lo;
  my $l = $extra_len + $key_len;
  my $extras = substr $body, 0, $extra_len;
  my $key    = substr $body, $extra_len, $key_len; 
  my $value  = substr $body, $l, $body_len - $l;

return ($status, $value, $key, $extras, $cas, $sequence);
}

sub binary_command {
  my $self = shift;
  my ($cmd, $key, $value, $extra_header, $cas) = @_;
  my $waitTime = $self->{min_wait};
  my $maxWait = $self->{max_wait};
  my $status;
  my $wr;
  
  do {
    $wr = $self->send_binary_request($cmd, $key, $value, $extra_header, $cas);
    return undef unless $wr;
    ($status) = $self->get_binary_response();
    if($status == 0x86 && $waitTime < $maxWait) {
      $self->{temp_errors} += 1;
      $self->{total_wait} += ( Time::HiRes::usleep($waitTime * 1000) / 1000);
      $waitTime *= 2;
    }
  } while($status == 0x86 && $waitTime <= $maxWait);

return ($status == 0) ? 1 : undef;
}

sub bin_math {
  my $self = shift;
  my ($cmd, $key, $delta, $initial) = @_;
  my $expires = 0xffffffff;  # 0xffffffff means the create flag is NOT set
  if(defined($initial))  { $expires = $self->{exptime};   }
  else                   { $initial = 0;                  }
  my $value = undef;
  
  my $extra_header = pack "NNNNN", 
  ($delta   / (2 ** 32)),   # delta hi
  ($delta   % (2 ** 32)),   # delta lo
  ($initial / (2 ** 32)),   # initial hi
  ($initial % (2 ** 32)),   # initial lo
  $expires;
  if( $self->send_binary_request($cmd, $key, '', $extra_header)) {
    my ($status, $packed_val) = $self->get_binary_response();
    if($status == 0) {
      my ($val_hi, $val_lo) = unpack("NN", $packed_val);
      $value = ($val_hi * (2 ** 32)) + $val_lo;
    }
  }
  return $value;
}

sub bin_store {
  my ($self, $cmd, $key, $value, $flags, $exptime, $cas) = @_;
  $flags   = $self->{flags}   unless $flags;
  $exptime = $self->{exptime} unless $exptime;
  my $extra_header = pack "NN", $flags, $exptime;
  
  return $self->binary_command($cmd, $key, $value, $extra_header, $cas);
}

## Pipelined multi-get
sub get {
  my $self = shift;
  my $idx = $#_;   # Index of the final key
  my $cmd = BIN_CMD_GETKQ;  # GET + KEY + NOREPLY
  my $wr;
  my $sequence = 0;
  my @results;

for(my $i = 0 ; $i <= $idx ; $i++) {
    $cmd = BIN_CMD_GETK if($i == $idx);  # Final request gets replies
    $wr = $self->send_binary_request($cmd, $_[$i], '', '');
  }
  return undef unless $wr;

while($sequence < $self->{req_id}) {
    my ($status, $value, $key, $extra, $cas);
    ($status, $value, $key, $extra, $cas, $sequence) = $self->get_binary_response();
    return undef if($status > 0x01);
    if($status == 0) {
      my $result = My::Memcache::Result->new($key, unpack("N", $extra), $cas);
      $result->{value} = $value;
      push @results, $result;
    }
  }
  $self->{get_results} = \@results;
  if(@results) {
    $self->{error} = "OK";
    return $results[0]->{value};
  }
  $self->{error} = "NOT_FOUND";
  return undef;
}

sub stats {
  my $self = shift;
  my $key = shift;
  my %response, my $status, my $value, my $klen, my $tlen;

$self->send_binary_request(BIN_CMD_STAT, $key, '', '');
  do {
    ($status, $value, $key) = $self->get_binary_response();
    if($status == 0) {
      $response{$key} = $value;
    } 
  } while($status == 0 && $key);

return %response;
}

sub flush {
  my ($self, $key, $value) = @_;
  $self->send_binary_request(BIN_CMD_FLUSH, $key, '', ''); 
  my ($status, $result) = $self->get_binary_response();
  return ($status == 0) ? 1 : 0;
}

sub store {
  my ($self, $cmd, $key, $value, $flags, $exptime, $cas) = @_;
  my %cmd_map = (
    "set" => BIN_CMD_SET , "add" => BIN_CMD_ADD , "replace" => BIN_CMD_REPLACE ,
    "append" => BIN_CMD_APPEND , "prepend" => BIN_CMD_PREPEND
  );
  return $self->bin_store($cmd_map{$cmd}, $key, $value, $flags, $exptime, $cas);
}
  
sub set {
  my ($self, $key, $value) = @_;
  return $self->bin_store(BIN_CMD_SET, $key, $value);
}

sub add {
  my ($self, $key, $value) = @_;
  return $self->bin_store(BIN_CMD_ADD, $key, $value);
}

sub replace {
  my ($self, $key, $value) = @_;
  return $self->bin_store(BIN_CMD_REPLACE, $key, $value);
}

sub append {
  my ($self, $key, $value) = @_;
  return $self->binary_command(BIN_CMD_APPEND, $key, $value, '');
}

sub prepend {
  my ($self, $key, $value) = @_;
  return $self->binary_command(BIN_CMD_PREPEND, $key, $value, '');
}

sub delete { 
  my ($self, $key) = @_;
  return $self->binary_command(BIN_CMD_DELETE, $key, '', '');
}
  
sub incr {
  my ($self, $key, $delta, $initial) = @_;
  return $self->bin_math(BIN_CMD_INCR, $key, $delta, $initial);
}

sub decr {
  my ($self, $key, $delta, $initial) = @_;
  return $self->bin_math(BIN_CMD_DECR, $key, $delta, $initial);
}

${this.title}

Code Editor : Memcache.pm