AnyEvent-Memcached-0.06/0000755000175000000120000000000012232302511013653 5ustar monswheelAnyEvent-Memcached-0.06/LICENSE0000644000175000000120000000025212232302033014656 0ustar monswheelLICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2009 Mons Anderson, all rights reserved. AnyEvent-Memcached-0.06/Changes0000644000175000000120000000167412232302200015151 0ustar monswheelRevision history for AnyEvent-Memcached 0.06 2011-07-08 * Fix typo in incadd 0.05 2010-07-11 * Fix META * Try to fix tests 0.04 2010-07-10 * Remove missed dep 0.03 2010-07-09 * Publish previous changes 0.02_02 2010-03-31 * Fix rget support flag for the first fail by timeout * Add default timeout = 3 0.02_01 2010-03-31 * Add gets/cas methods * Add incget method * Add options to rget * Rewrite/enhance tests * Remove excess dependencies * Fix documentation 0.02 2009-12-18 * First non-dev release 0.01_7 2009-11-19 * Make hashing pluggable, add alternative hashing algorithm * Separate noreply commands in another connection * Some generalizations for pluggable hashing * Fixed decr (decr worked as incr) 0.01 Date/time First version, released on an unsuspecting world. AnyEvent-Memcached-0.06/xt/0000755000175000000120000000000012232302511014306 5ustar monswheelAnyEvent-Memcached-0.06/xt/99-dist.t0000644000175000000120000000112512232302034015674 0ustar monswheel#!/usr/bin/perl use lib::abs '../lib'; use Test::More; use Test::If 'Test::Dist'; use Test::NoWarnings; chdir lib::abs::path('..'); Test::Dist::dist_ok( '+' => 1, run => 1, skip => [qw(prereq)], kwalitee => { req => [qw( has_separate_license_file has_example metayml_has_provides metayml_declares_perl_version uses_test_nowarnings )], }, prereq => [ undef,undef, [qw( Test::Pod Test::Pod::Coverage )], ], podcover => { mod_match => qr{^AnyEvent::Memcached$}, mod_skip => [qr{^AnyEvent::Memcached::}] }, ); exit 0; require Test::Pod::Coverage; # kwalitee hacks, hope temporary AnyEvent-Memcached-0.06/META.yml0000644000175000000120000000157312232302510015131 0ustar monswheel--- abstract: 'AnyEvent memcached client' author: - 'Mons Anderson ' build_requires: ExtUtils::MakeMaker: 6.59 Test::More: 0 Test::NoWarnings: 0 lib::abs: 0.90 version: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: AnyEvent-Memcached no_index: directory: - examples - inc - t - xt provides: AnyEvent::Memcached: file: lib/AnyEvent/Memcached.pm version: 0.06 AnyEvent::Memcached::Hash::WithNext: file: lib/AnyEvent/Memcached/Hash/WithNext.pm requires: AnyEvent: 5.0 AnyEvent::Connection: 0.05 Storable: 0 String::CRC32: 0 common::sense: 2 perl: 5.8.8 resources: license: http://dev.perl.org/licenses/ version: 0.06 AnyEvent-Memcached-0.06/lib/0000755000175000000120000000000012232302511014421 5ustar monswheelAnyEvent-Memcached-0.06/lib/AnyEvent/0000755000175000000120000000000012232302511016152 5ustar monswheelAnyEvent-Memcached-0.06/lib/AnyEvent/Memcached.pm0000644000175000000120000005241012232302033020357 0ustar monswheelpackage AnyEvent::Memcached; use 5.8.8; =head1 NAME AnyEvent::Memcached - AnyEvent memcached client =cut our $VERSION = '0.06'; =head1 SYNOPSIS use AnyEvent::Memcached; my $memd = AnyEvent::Memcached->new( servers => [ "10.0.0.15:11211", "10.0.0.15:11212" ], # same as in Cache::Memcached debug => 1, compress_threshold => 10000, namespace => 'my-namespace:', # May use another hashing algo: hasher => 'AnyEvent::Memcached::Hash::WithNext', cv => $cv, # AnyEvent->condvar: group callback ); $memd->set_servers([ "10.0.0.15:11211", "10.0.0.15:11212" ]); # Basic methods are like in Cache::Memcached, but with additional cb => sub { ... }; # first argument to cb is return value, second is the error(s) $memd->set( key => $value, cb => sub { shift or warn "Set failed: @_" } ); # Single get $memd->get( 'key', cb => sub { my ($value,$err) = shift; $err and return warn "Get failed: @_"; warn "Value for key is $value"; } ); # Multi-get $memd->get( [ 'key1', 'key2' ], cb => sub { my ($values,$err) = shift; $err and return warn "Get failed: @_"; warn "Value for key1 is $values->{key1} and value for key2 is $values->{key2}" } ); # Additionally there is rget (see memcachedb-1.2.1-beta) $memd->rget( 'fromkey', 'tokey', cb => sub { my ($values,$err) = shift; $err and warn "Get failed: @_"; while (my ($key,$value) = each %$values) { # ... } } ); # Rget with sorted responce values $memd->rget( 'fromkey', 'tokey', rv => 'array' cb => sub { my ($values,$err) = shift; $err and warn "Get failed: @_"; for (0 .. $#values/2) { my ($key,$value) = @$values[$_*2,$_*2+1]; } } ); =head1 DESCRIPTION Asyncronous C client for L framework =head1 NOTICE There is a notices in L related to this module. They all has been fixed =over 4 =item Prerequisites We no longer need L and L. At all, the dependency list is like in L + L =item Binary protocol It seems to me, that usage of binary protocol from pure perl gives very little advantage. So for now I don't implement it =item Unimplemented Methods There is a note, that get_multi is not implementeted. In fact, it was implemented by method L, but the documentation was wrong. =back In general, this module follows the spirit of L rather than correspondence to L interface. =cut use common::sense 2;m{ use strict; use warnings; }x; use Carp; use AnyEvent 5; #use Devel::Leak::Cb; use AnyEvent::Socket; use AnyEvent::Handle; use AnyEvent::Connection; use AnyEvent::Connection::Util; use AnyEvent::Memcached::Conn; use Storable (); use AnyEvent::Memcached::Peer; use AnyEvent::Memcached::Hash; use AnyEvent::Memcached::Buckets; # flag definitions use constant F_STORABLE => 1; use constant F_COMPRESS => 2; # size savings required before saving compressed value use constant COMPRESS_SAVINGS => 0.20; # percent our $HAVE_ZLIB; BEGIN { $HAVE_ZLIB = eval "use Compress::Zlib (); 1;"; } =head1 METHODS =head2 new %args Currently supported options: =over 4 =item servers =item namespace =item debug =item cv =item compress_threshold =item compress_enable =item timeout =item hasher If set, will use instance of this class for hashing instead of default. For implementing your own hashing, see sources of L and L =item noreply If true, additional connection will established for noreply commands. =item cas If true, will enable cas/gets commands (since they are not suppotred in memcachedb) =back =cut sub new { my $self = bless {}, shift; my %args = @_; $self->{namespace} = exists $args{namespace} ? delete $args{namespace} : ''; for (qw( debug cv compress_threshold compress_enable timeout noreply cas)) { $self->{$_} = exists $args{$_} ? delete $args{$_} : 0; } $self->{timeout} ||= 3; $self->{_bucker} = $args{bucker} || 'AnyEvent::Memcached::Buckets'; $self->{_hasher} = $args{hasher} || 'AnyEvent::Memcached::Hash'; $self->set_servers(delete $args{servers}); $self->{compress_enable} and !$HAVE_ZLIB and Carp::carp("Have no Compress::Zlib installed, but have compress_enable option"); require Carp; Carp::carp "@{[ keys %args ]} options are not supported yet" if %args; $self; } =head2 set_servers Setup server list =cut sub set_servers { my $self = shift; my $list = shift; my $buckets = $self->{_bucker}->new(servers => $list); #warn R::Dump($list, $buckets); $self->{hash} = $self->{_hasher}->new(buckets => $buckets); $self->{peers} = my $peers = $buckets->peers; for my $peer ( values %{ $peers } ) { $peer->{con} = AnyEvent::Memcached::Peer->new( port => $peer->{port}, host => $peer->{host}, timeout => $self->{timeout}, debug => $self->{debug}, ); # Noreply connection if ($self->{noreply}) { $peer->{nrc} = AnyEvent::Memcached::Peer->new( port => $peer->{port}, host => $peer->{host}, timeout => $self->{timeout}, debug => $self->{debug},# || 1, ); } } return $self; } =head2 connect Establish connection to all servers and invoke event C, when ready =cut sub connect { my $self = shift; $_->{con}->connect for values %{ $self->{peers} }; } sub _handle_errors { my $self = shift; my $peer = shift; local $_ = shift; if ($_ eq 'ERROR') { warn "Error"; } elsif (/(CLIENT|SERVER)_ERROR (.*)/) { warn ucfirst(lc $1)." error: $2"; } else { warn "Bad response from $peer->{host}:$peer->{port}: $_"; } } sub _do { my $self = shift; my $key = shift; utf8::decode($key) xor utf8::encode($key) if utf8::is_utf8($key); my $command = shift; utf8::decode($command) xor utf8::encode($command) if utf8::is_utf8($command); my $worker = shift; # CODE my %args = @_; my $servers = $self->{hash}->servers($key); my %res; my %err; my $res; if ($args{noreply} and !$self->{noreply}) { if (!$args{cb}) { carp "Noreply option not set, but noreply command requested. command ignored"; return 0; } else { carp "Noreply option not set, but noreply command requested. fallback to common command"; } delete $args{noreply}; } if ($args{noreply}) { for my $srv ( keys %$servers ) { for my $real (@{ $servers->{$srv} }) { my $cmd = $command.' noreply'; substr($cmd, index($cmd,'%s'),2) = $real; $self->{peers}{$srv}{nrc}->request($cmd); $self->{peers}{$srv}{lastnr} = $cmd; unless ($self->{peers}{$srv}{nrc}->handles('command')) { $self->{peers}{$srv}{nrc}->reg_cb(command => sub { # cb { shift; warn "Got data from $srv noreply connection (while shouldn't): @_\nLast noreply command was $self->{peers}{$srv}{lastnr}\n"; }); $self->{peers}{$srv}{nrc}->want_command(); } } } $args{cb}(1) if $args{cb}; return 1; } $_ and $_->begin for $self->{cv}, $args{cv}; my $cv = AE::cv { #use Data::Dumper; #warn Dumper $res,\%res,\%err; if ($res != -1) { $args{cb}($res); } elsif (!%err) { warn "-1 while not err"; $args{cb}($res{$key}); } else { $args{cb}(undef, dumper($err{$key})); } #warn "cv end"; $_ and $_->end for $args{cv}, $self->{cv}; }; for my $srv ( keys %$servers ) { for my $real (@{ $servers->{$srv} }) { $cv->begin; my $cmd = $command; substr($cmd, index($cmd,'%s'),2) = $real; $self->{peers}{$srv}{con}->command( $cmd, cb => sub { # cb { if (defined( local $_ = shift )) { my ($ok,$fail) = $worker->($_); if (defined $ok) { $res{$real}{$srv} = $ok; $res = (!defined $res ) || $res == $ok ? $ok : -1; } else { $err{$real}{$srv} = $fail; $res = -1; } } else { warn "do failed: @_/$!"; $err{$real}{$srv} = $_; $res = -1; } $cv->end; } ); } } return; } sub _set { my $self = shift; my $cmd = shift; my $key = shift; my $cas; if ($cmd eq 'cas') { $cas = shift; } my $val = shift; my %args = @_; return $args{cb}(undef, "Readonly") if $self->{readonly}; #warn "cv begin"; use bytes; # return bytes from length() warn "value for memkey:$key is not defined" unless defined $val; my $flags = 0; if (ref $val) { local $Carp::CarpLevel = 2; $val = Storable::nfreeze($val); $flags |= F_STORABLE; } my $len = length($val); if ( $self->{compress_threshold} and $HAVE_ZLIB and $self->{compress_enable} and $len >= $self->{compress_threshold}) { my $c_val = Compress::Zlib::memGzip($val); my $c_len = length($c_val); # do we want to keep it? if ($c_len < $len*(1 - COMPRESS_SAVINGS)) { $val = $c_val; $len = $c_len; $flags |= F_COMPRESS; } } my $expire = int($args{expire} || 0); return $self->_do( $key, "$cmd $self->{namespace}%s $flags $expire $len".(defined $cas ? ' '.$cas : '')."\015\012$val", sub { # cb { local $_ = shift; if ($_ eq 'STORED') { return 1 } elsif ($_ eq 'NOT_STORED') { return 0 } elsif ($_ eq 'EXISTS') { return 0 } else { return undef, $_ } }, cb => $args{cb}, ); $_ and $_->begin for $self->{cv}, $args{cv}; my $servers = $self->{hash}->servers($key); my %res; my %err; my $res; my $cv = AE::cv { if ($res != -1) { $args{cb}($res); } elsif (!%err) { warn "-1 while not err"; $args{cb}($res{$key}); } else { $args{cb}(undef, dumper($err{$key})); } warn "cv end"; $_ and $_->end for $args{cv}, $self->{cv}; }; for my $srv ( keys %$servers ) { # ??? Can hasher return more than one key for single key passed? # If no, need to remove this inner loop #warn "server for $key = $srv, $self->{peers}{$srv}"; for my $real (@{ $servers->{$srv} }) { $cv->begin; $self->{peers}{$srv}{con}->command( "$cmd $self->{namespace}$real $flags $expire $len\015\012$val", cb => sub { # cb { if (defined( local $_ = shift )) { if ($_ eq 'STORED') { $res{$real}{$srv} = 1; $res = (!defined $res)||$res == 1 ? 1 : -1; } elsif ($_ eq 'NOT_STORED') { $res{$real}{$srv} = 0; $res = (!defined $res)&&$res == 0 ? 0 : -1; } elsif ($_ eq 'EXISTS') { $res{$real}{$srv} = 0; $res = (!defined $res)&&$res == 0 ? 0 : -1; } else { $err{$real}{$srv} = $_; $res = -1; } } else { warn "set failed: @_/$!"; #$args{cb}(undef, @_); $err{$real}{$srv} = $_; $res = -1; } $cv->end; } ); } } return; } =head2 set( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Unconditionally sets a key to a given value in the memcache. C<$rc> is =over 4 =item '1' Successfully stored =item '0' Item was not stored =item undef Error happens, see C<$err> =back =head2 cas( $key, $cas, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) $memd->gets($key, cb => sub { my $value = shift; unless (@_) { # No errors my ($cas,$val) = @$value; # Change your value in $val $memd->cas( $key, $cas, $value, cb => sub { my $rc = shift; if ($rc) { # stored } else { # ... } }); } }) C<$rc> is the same, as for L Store the C<$value> on the server under the C<$key>, but only if CAS value associated with this key is equal to C<$cas>. See also L =head2 add( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Like C, but only stores in memcache if the key doesn't already exist. =head2 replace( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Like C, but only stores in memcache if the key already exists. The opposite of add. =head2 append( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Append the $value to the current value on the server under the $key. B command first appeared in memcached 1.2.4. =head2 prepend( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Prepend the $value to the current value on the server under the $key. B command first appeared in memcached 1.2.4. =cut sub set { shift->_set( set => @_) } sub cas { my $self = shift; unless ($self->{cas}) { shift;shift;my %args = @_;return $args{cb}(undef, "CAS not enabled") } $self->_set( cas => @_) } sub add { shift->_set( add => @_) } sub replace { shift->_set( replace => @_) } sub append { shift->_set( append => @_) } sub prepend { shift->_set( prepend => @_) } =head2 get( $key, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Retrieve the value for a $key. $key should be a scalar =head2 get( $keys : ARRAYREF, [cv => $cv], [ expire => $expire ], cb => $cb->( $values_hash, $err ) ) Retrieve the values for a $keys. Return a hash with keys/values =head2 gets( $key, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Retrieve the value and its CAS for a $key. $key should be a scalar. C<$rc> is a reference to an array [$cas, $value], or nothing for non-existent key =head2 gets( $keys : ARRAYREF, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Retrieve the values and their CAS for a $keys. C<$rc> is a hash reference with $rc->{$key} is a reference to an array [$cas, $value] =cut sub _deflate { my $self = shift; my $result = shift; for ( ref $result eq 'ARRAY' ? @$result ? @$result[ map { $_*2+1 } 0..int( $#$result / 2 ) ] : () : values %$result ) { if ($HAVE_ZLIB and $_->{flags} & F_COMPRESS) { $_->{data} = Compress::Zlib::memGunzip($_->{data}); } if ($_->{flags} & F_STORABLE) { eval{ $_->{data} = Storable::thaw($_->{data}); 1 } or delete $_->{data}; } if (exists $_->{cas}) { $_ = [$_->{cas},$_->{data}]; } else { $_ = $_->{data}; } } return; } 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; } $_ 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 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 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 =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 \r\n # #- where the query starts. #- where the query ends. #- indicates the openness of left side, 0 means the result includes , while 1 means not. #- indicates the openness of right side, 0 means the result includes , while 1 means not. #- 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; } } else { $err = "@_"; undef $do; $cv->end; } } ); } } $cv->end; return; } =head2 incadd ( $key, $increment, [cv => $cv], [ noreply => 1 ], cb => $cb->( $rc, $err ) ) Increment key, and if it not exists, add it with initial value. If add fails, try again to incr or fail =cut sub incadd { my $self = shift; my $key = shift; my $val = shift; my %args = @_; $self->incr($key => $val, cb => sub { if (my $rc = shift or @_) { #if (@_) { # warn("incr failed: @_"); #} else { # warn "incr ok"; #} $args{cb}($rc, @_); } else { $self->add( $key, $val, %args, cb => sub { if ( my $rc = shift or @_ ) { #if (@_) { # warn("add failed: @_"); #} else { # warn "add ok"; #} $args{cb}($val, @_); } else { #warn "add failed, try again"; $self->incadd($key,$val,%args); } }); } }); } =head2 destroy Shutdown object as much, as possible, incl cleaning of incapsulated objects =cut sub AnyEvent::Memcached::destroyed::AUTOLOAD {} sub destroy { my $self = shift; $self->DESTROY; bless $self, "AnyEvent::Memcached::destroyed"; } sub DESTROY { my $self = shift; warn "(".int($self).") Destroying AE:MC" if $self->{debug}; for (values %{$self->{peers}}) { $_->{con} and $_->{con}->destroy; } %$self = (); } =head1 BUGS Feature requests are welcome Bug reports are welcome =head1 AUTHOR Mons Anderson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2009 Mons Anderson, 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 AnyEvent::Memcached AnyEvent-Memcached-0.06/lib/AnyEvent/Memcached/0000755000175000000120000000000012232302511020020 5ustar monswheelAnyEvent-Memcached-0.06/lib/AnyEvent/Memcached/Buckets.pm0000644000175000000120000000451112232302033021756 0ustar monswheelpackage #hide AnyEvent::Memcached::Buckets; use common::sense 2;m{ use strict; use warnings; }x; use Carp; sub new { my $self = bless {}, shift; my %args = @_; $self->set_servers(delete $args{servers}); $self; } sub set_servers { my $self = shift; my $list = shift or return; $list = [$list] unless ref $list eq 'ARRAY'; $self->{servers} = $list || []; $self->_init_buckets; return $self; } sub peers { my $self = shift; @{$self->{servers}} or croak "servers not set during peers"; $self->{peers}; } sub _init_buckets { my $self = shift; @{$self->{servers}} or croak "servers not set during _init_buckets"; if ($self->{buckets}) { @{ $self->{buckets} } = (); } else { $self->{buckets} = []; } my $bu = $self->{buckets}; my $i = 0; foreach my $v (@{$self->{servers}}) { my $peer; my $buck = [ 0+@$bu ]; if (ref $v eq "ARRAY") { $peer = $v->[0]; for (1..$v->[1]) { push @$bu, $v->[0]; } push @$buck, $buck->[0]+1 .. $#$bu; } else { push @$bu, $peer = $v; } my ($host,$port) = $peer =~ /^(.+?)(?:|:(\d+))$/; if ( exists $self->{peers}{$peer} ) { push @{ $self->{peers}{$peer}{bucks} }, @$buck; } else { push @{ $self->{srv} ||= [] }, $peer; $self->{peers}{$peer} = { index => $#{ $self->{srv} }, bucks => $buck, host => $host, port => $port, }; } } return; } sub peer { my $self = shift; my $hash = shift; @{$self->{servers}} or croak "servers not set during peer"; return $self->{buckets}[ $hash % @{ $self->{buckets} } ]; } sub next { my $self = shift; my $srv = shift; @{$self->{servers}} or croak "servers not set during next"; my $peer = $self->{peers}{$srv} or croak "No such server in buckets: $srv"; my %args = @_; my $by = $args{by} || 1; my $next = ( $peer->{index} + $by ) % @{$self->{srv}}; my $nsrv = $self->{srv}[$next] or die "Cant find next server by index $next"; $nsrv = $nsrv->[0] if ref $nsrv; #warn R::Dump($nsrv); if ( ( my @bucks = @{ $self->{peers}{$nsrv}{bucks} } ) > 1 ) { my $which = $bucks[ ( $args{hash} || 0 ) % @bucks ]; #warn "many buckets (@bucks) for $nsrv. using $which ($self->{buckets}[ $which ])"; return $self->{buckets}[ $which ]; } else { return $nsrv; } } sub prev { my $self = shift; my $srv = shift; my %args = @_; my $by = $args{by} || 1; $self->next( $srv, %args, by => @{$self->{srv}}-$by ); } 1; AnyEvent-Memcached-0.06/lib/AnyEvent/Memcached/Peer.pm0000644000175000000120000000627412232302033021261 0ustar monswheelpackage #hide AnyEvent::Memcached::Peer; use common::sense 2;m{ use strict; use warnings; }x; use base 'AnyEvent::Connection'; use Carp; use AnyEvent::Connection::Util; use Scalar::Util qw(weaken); #use Devel::Leak::Cb; sub DEBUG () { 0 } use AnyEvent::Memcached::Conn; sub new { my $self = shift->SUPER::new( rawcon => 'AnyEvent::Memcached::Conn', reconnect => 1, @_, ); $self->{waitingcb} = {}; $self; } sub connect { my $self = shift; $self->{connecting} and return; $self->{grd}{con} = $self->reg_cb( connected => sub { $self->{failed} = 0; } ); $self->{grd}{cfl} = $self->reg_cb( connfail => sub { $self->{failed} = 1; } ); $self->{grd}{dis} = $self->reg_cb( disconnect => sub { shift;shift; %$self or return; warn "Peer $self->{host}:$self->{port} disconnected".(@_ ? ": @_" : '')."\n" if $self->{debug}; my $e = @_ ? "@_" : "disconnected"; for ( keys %{$self->{waitingcb}} ) { if ($self->{waitingcb}{$_}) { #warn "Cleanup: ",::sub_fullname( $self->{waitingcb}{$_} ); $self->{waitingcb}{$_}(undef,$e); } delete $self->{waitingcb}{$_}; } } ); $self->SUPER::connect(@_); return; } sub conntrack { my $self = shift; my ($method,$args,$cb) = @_; if($self->{connecting} and $self->{failed}) { warn "Is connecting, have fails => not connected" if DEBUG; $cb and $cb->(undef, "Not connected"); return; } elsif (!$self->{connected}) { my @args = @$args; # copy to avoid rewriting warn time()." Not connected, do connect for ".\@args.", ".dumper($args[0]) if DEBUG; my ($c,$t); weaken( $self->{waitingcb}{int $cb} = $cb ) if $cb; weaken( $self ); # This rely on correct event invocation order of Object::Event. # If this could change, I'll add own queue $c = $self->reg_cb( connected => sub { shift->unreg_me; #$c or return; warn "connected cb for ".\@args.", ".dumper($args[0]) if DEBUG; undef $c;undef $t; $self or return; delete $self->{waitingcb}{int $cb} if $cb; return $self->{con}->$method(@args); }, ); $t = AnyEvent->timer( after => $self->{timeout},# + 0.05, # Since there are timers inside connect, we need to delay a bit longer cb => sub { #$t or return; warn time()." timeout $self->{timeout} cb for $args->[0]" if DEBUG; undef $c;undef $t; $self or return; if ($cb){ $self->{waitingcb}{int $cb}; $cb->(undef, "Connect timeout"); } }, ); $self->connect(); } else { Carp::cluck "How do I get here?"; return $self->{con}->$method(@$args); } } sub command { my $self = shift; if ($self->{connected}) { return $self->{con}->command( @_ ); } else { my ($cmd,%args) = @_; $self->conntrack( command => \@_, $args{cb} ); } } sub request { my $self = shift; if ($self->{connected}) { return $self->{con}->say(@_); } else { # no cb $self->conntrack( say => \@_ ); } } sub reader { my $self = shift; if ($self->{connected}) { return $self->{con}->reader(@_); } else { my %args = @_; $self->conntrack( reader => \@_, $args{cb} ); } } sub want_command { my $self = shift; warn "wanting command"; if ($self->{connected}) { return $self->{con}->want_command(@_); } else { my %args = @_; $self->conntrack( want_command => \@_ ); } } 1; AnyEvent-Memcached-0.06/lib/AnyEvent/Memcached/Conn.pm0000644000175000000120000000361512232302033021257 0ustar monswheelpackage #hide AnyEvent::Memcached::Conn; use common::sense 2;m{ use strict; use warnings; }x; use base 'AnyEvent::Connection::Raw'; use AnyEvent::Memcached; use AnyEvent::Connection::Util; our $NL = "\015\012"; our $QRNL = qr<\015?\012>; our $VERSION = $AnyEvent::Memcached::VERSION; sub reader { my ($self,%args) = @_; $args{cb} or return $self->event( error => "no cb for command at @{[ (caller)[1,2] ]}" ); $self->{h} or return $args{cb}->(undef,"Not connected"); my $result = $args{res} || {}; my $ar = ref $result eq 'ARRAY' ? 1 : 0; my $cut = exists $args{namespace} ? length $args{namespace} : 0; my $reader;$reader = sub { shift; defined( local $_ = shift ) or return $args{cb}(undef,@_); warn "<<$args{id} $_" if $self->{debug}; if ($_ eq "END") { undef $reader; $args{cb}( $result ); } elsif (substr($_,0,5) eq 'ERROR') { undef $reader; $args{cb}( undef, $_ ); } elsif (!length) { warn "Skip empty line"; $self->{h}->unshift_read( line => $reader); } elsif( /^VALUE (\S+) (\d+) (\d+)(?:| (.+))$/ ) { my ($key,$flags,$len,$cas) = ($1,$2,$3,$4); #warn "have to read $1 $2 $3 $4"; $self->recv( $3+2 => cb => sub { #shift; my $data = shift; substr($data,$len) = ''; # trim out data outside length #$data = substr($data,0,length($data)-2); $key = substr($key, $cut) if substr($key, 0, $cut) eq $args{namespace}; warn "+ received data $key: $data" if $self->{debug}; my $v = { data => $data, flags => $flags, defined $cas ? (cas => $cas) : (), }; if ($ar) { push @$result, $key, $v; } else { $result->{$key} = $v;#{ data => $data, $cas ? (cas => $cas) : () }; } $self->{h}->unshift_read( line => $reader); }); } else { die "Wrong data received: ".dumper($_)."($!)"; #$args{cb}(undef,$_); #$self->handle_errors($_); } }; $self->{h}->push_read( line => $reader ); } 1; 1; AnyEvent-Memcached-0.06/lib/AnyEvent/Memcached/Hash/0000755000175000000120000000000012232302511020703 5ustar monswheelAnyEvent-Memcached-0.06/lib/AnyEvent/Memcached/Hash/WithNext.pm0000644000175000000120000000200512232302033023007 0ustar monswheelpackage AnyEvent::Memcached::Hash::WithNext; =head1 NAME AnyEvent::Memcached::Hash::WithNext - Hashing algorythm for AE::Memcached =head1 SYNOPSIS my $memd = AnyEvent::Memcached->new( servers => [ "10.0.0.15:10001", "10.0.0.15:10002", "10.0.0.15:10003" ], # ... hasher => 'AnyEvent::Memcached::Hash::WithNext', ); $memd->set(key => "val", ...) # will put key on 2 servers =head1 DESCRIPTION Uses the same hashing, as default, but always put key to server, next after choosen. Result is twice-replicated data. Useful for usage with memcachdb =cut use common::sense 2;m{ use strict; use warnings; }x; use Carp; use base 'AnyEvent::Memcached::Hash'; sub peers { my $self = shift; my ($hash,$real,$peers) = @_; $peers ||= {}; my $peer = $self->{buckets}->peer( $hash ); my $next = $self->{buckets}->next( $peer ); push @{ $peers->{$peer} ||= [] }, $real; push @{ $peers->{$next} ||= [] }, $real; return $peers; } =head1 AUTHOR Mons Anderson, C<< >> =cut 1;AnyEvent-Memcached-0.06/lib/AnyEvent/Memcached/Hash.pm0000644000175000000120000000170412232302033021242 0ustar monswheelpackage #hide AnyEvent::Memcached::Hash; use common::sense 2;m{ use strict; use warnings; }x; use Carp; use String::CRC32 'crc32'; sub new { my $self = bless {}, shift; my %args = @_; $self->{buckets} = $args{buckets}; $self; } sub set_buckets { shift->{buckets} = @_ == 1 ? $_[0] : \@_ } sub hash { (crc32($_[1]) >> 16) & 0x7fff; } sub peers { my $self = shift; my ($hash,$real,$peers) = @_; $peers ||= {}; my $peer = $self->{buckets}->peer( $hash ); push @{ $peers->{$peer} ||= [] }, $real; return $peers; } sub hashes { my $self = shift; $self->{buckets} or croak "No buckets set during hashes"; my $keys = shift; my $array; if (ref $keys and ref $keys eq 'ARRAY') { $array = 1; } else { $keys = [$keys]; } my %peers; for my $keyx (@$keys) { my ($hash,$real) = ref $keyx ? (int($keyx->[0]), $keyx->[1]) : ($self->hash($keyx), $keyx); $self->peers($hash,$real,\%peers); } return \%peers; } *servers = \&hashes; 1; AnyEvent-Memcached-0.06/Makefile.PL0000644000175000000120000000104712232302033015626 0ustar monswheeluse inc::Module::Install; name 'AnyEvent-Memcached'; author 'Mons Anderson '; all_from 'lib/AnyEvent/Memcached.pm'; license 'perl'; test_requires 'Test::More'; test_requires 'Test::NoWarnings'; test_requires 'lib::abs', '0.90'; test_requires 'version'; requires 'common::sense', '2'; requires 'Storable'; requires 'AnyEvent', '5.0'; requires 'AnyEvent::Connection', '0.05'; requires 'String::CRC32'; #requires 'Devel::Leak::Cb'; #auto_include; #auto_include_deps; auto_provides; auto_install; WriteAll; AnyEvent-Memcached-0.06/t/0000755000175000000120000000000012232302511014116 5ustar monswheelAnyEvent-Memcached-0.06/t/03-storable.t0000644000175000000120000000171512232302033016341 0ustar monswheel#!/usr/bin/env perl -w use lib::abs 'lib','../lib';#, '../../AE-Cnn/lib'; use Test::AE::MC; use common::sense; runtest { my ($host,$port) = @_; diag "testing $host : $port"; require Test::NoWarnings;Test::NoWarnings->import; plan tests => 5 + 1; my $cv = AE::cv; my $memd = AnyEvent::Memcached->new( servers => "$host:$port", cv => $cv, debug => 0, namespace => "AE::Memd::t/$$/" . (time() % 100) . "/", compress_enable => 1, compress_threshold => 1, # Almost everything is greater than 1 ); isa_ok($memd, 'AnyEvent::Memcached'); # Repeated structures will be compressed $memd->set(key1 => { some => 'struct'x10, "\0" => "\1" }, cb => sub { ok(shift,"set key1") or diag " Error: @_"; $memd->get("key1", cb => sub { is_deeply(shift, { some => 'struct'x10, "\0" => "\1" }, "get key1") or diag " Error: @_"; }); }); $memd->get("test%s", cb => sub { ok !shift, 'no value'; ok !@_, 'no errors'; }); $cv->recv; }; AnyEvent-Memcached-0.06/t/01-usage-memd.t0000644000175000000120000000030312232302033016540 0ustar monswheel#!/usr/bin/env perl -w use lib::abs 'lib','../lib';#, '../../AE-Cnn/lib'; use Test::AE::MC; use common::sense; do + lib::abs::path('.').'/check.pl'; $@ and die; exit; require Test::NoWarnings; AnyEvent-Memcached-0.06/t/04-hashing.t0000644000175000000120000000615412232302033016152 0ustar monswheel#!/usr/bin/env perl use common::sense 2; use Test::NoWarnings; use Test::More tests => 35+1; use lib::abs "../lib"; use AnyEvent::Memcached::Hash; use AnyEvent::Memcached::Buckets; my $bucks = AnyEvent::Memcached::Buckets->new( servers => [ "node-x", "node-y", "node-z", "socket", [ "node-z", 3 ] ]); my $hasher = AnyEvent::Memcached::Hash->new( buckets => $bucks, ); # Basic tests is_deeply $hasher->hashes('a'), { 'node-z' => ['a'] }, 'hashes a'; is_deeply $hasher->hashes('b'), { 'node-z' => ['b'] }, 'hashes b'; is_deeply $hasher->hashes('c'), { 'node-z' => ['c'] }, 'hashes c'; is_deeply $hasher->hashes('d'), { 'node-z' => ['d'] }, 'hashes d'; is_deeply $hasher->hashes('e'), { 'node-z' => ['e'] }, 'hashes e'; is_deeply $hasher->hashes('f'), { 'node-z' => ['f'] }, 'hashes f'; is_deeply $hasher->hashes('g'), { 'node-z' => ['g'] }, 'hashes g'; is_deeply $hasher->hashes('h'), { 'node-x' => ['h'] }, 'hashes h'; is_deeply $hasher->hashes('i'), { 'node-z' => ['i'] }, 'hashes i'; is_deeply $hasher->hashes('j'), { 'node-x' => ['j'] }, 'hashes j'; is_deeply $hasher->hashes('k'), { 'node-z' => ['k'] }, 'hashes k'; is_deeply $hasher->hashes('l'), { 'socket' => ['l'] }, 'hashes l'; is_deeply $hasher->hashes('m'), { 'node-z' => ['m'] }, 'hashes m'; is_deeply $hasher->hashes('n'), { 'node-z' => ['n'] }, 'hashes n'; is_deeply $hasher->hashes('o'), { 'node-z' => ['o'] }, 'hashes o'; is_deeply $hasher->hashes('p'), { 'node-y' => ['p'] }, 'hashes p'; is_deeply $hasher->hashes('q'), { 'node-z' => ['q'] }, 'hashes q'; is_deeply $hasher->hashes('r'), { 'node-x' => ['r'] }, 'hashes r'; is_deeply $hasher->hashes('s'), { 'socket' => ['s'] }, 'hashes s'; is_deeply $hasher->hashes('t'), { 'node-x' => ['t'] }, 'hashes t'; is_deeply $hasher->hashes('u'), { 'node-z' => ['u'] }, 'hashes u'; is_deeply $hasher->hashes('v'), { 'socket' => ['v'] }, 'hashes v'; is_deeply $hasher->hashes('w'), { 'node-y' => ['w'] }, 'hashes w'; is_deeply $hasher->hashes('x'), { 'node-z' => ['x'] }, 'hashes x'; is_deeply $hasher->hashes('y'), { 'node-z' => ['y'] }, 'hashes y'; is_deeply $hasher->hashes('z'), { 'node-x' => ['z'] }, 'hashes z'; # Test many keys is_deeply $hasher->hashes([qw(h p q v)]), { 'node-x' => ['h'], 'node-y' => ['p'], 'node-z' => ['q'], 'socket' => ['v'], }, 'hashes [h p q v]'; # Test complex keys with predefined hash value is_deeply $hasher->hashes([[0 => 'a0']]), { 'node-x' => ['a0'] }, 'hashes [[0,a0]]'; is_deeply $hasher->hashes([[1 => 'a1']]), { 'node-y' => ['a1'] }, 'hashes [[1,a1]]'; is_deeply $hasher->hashes([[2 => 'a2']]), { 'node-z' => ['a2'] }, 'hashes [[2,a2]]'; is_deeply $hasher->hashes([[3 => 'a3']]), { 'socket' => ['a3'] }, 'hashes [[3,a3]]'; is_deeply $hasher->hashes([[4 => 'a4']]), { 'node-z' => ['a4'] }, 'hashes [[4,a4]]'; is_deeply $hasher->hashes([[5 => 'a5']]), { 'node-z' => ['a5'] }, 'hashes [[5,a5]]'; is_deeply $hasher->hashes([[6 => 'a6']]), { 'node-z' => ['a6'] }, 'hashes [[6,a6]]'; # Test many complex keys is_deeply $hasher->hashes([ [ 0 => 'a' ], [ 1 => 'b' ], [ 2 => 'c' ], [ 3 => 'd' ] ]), { 'node-x' => ['a'], 'node-y' => ['b'], 'node-z' => ['c'], 'socket' => ['d'], }, 'hashes [[1],[2],[3],[4]]' ; AnyEvent-Memcached-0.06/t/05-hashing-with-next.t0000644000175000000120000000747112232302033020103 0ustar monswheel#!/usr/bin/env perl use common::sense 2; use Test::NoWarnings; use Test::More tests => 35+1; use lib::abs "../lib"; use AnyEvent::Memcached::Hash; use AnyEvent::Memcached::Hash::WithNext; use AnyEvent::Memcached::Buckets; my $bucks = AnyEvent::Memcached::Buckets->new( servers => [ "node-x", "node-y", "node-z", "socket", [ "node-z", 3 ] ]); my $hasher = AnyEvent::Memcached::Hash::WithNext->new( buckets => $bucks, ); # Basic tests is_deeply $hasher->hashes('a'), { 'node-z' => ['a'], 'socket' => ['a'] }, 'hashes a'; is_deeply $hasher->hashes('b'), { 'node-z' => ['b'], 'socket' => ['b'] }, 'hashes b'; is_deeply $hasher->hashes('c'), { 'node-z' => ['c'], 'socket' => ['c'] }, 'hashes c'; is_deeply $hasher->hashes('d'), { 'node-z' => ['d'], 'socket' => ['d'] }, 'hashes d'; is_deeply $hasher->hashes('e'), { 'node-z' => ['e'], 'socket' => ['e'] }, 'hashes e'; is_deeply $hasher->hashes('f'), { 'node-z' => ['f'], 'socket' => ['f'] }, 'hashes f'; is_deeply $hasher->hashes('g'), { 'node-z' => ['g'], 'socket' => ['g'] }, 'hashes g'; is_deeply $hasher->hashes('h'), { 'node-x' => ['h'], 'node-y' => ['h'] }, 'hashes h'; is_deeply $hasher->hashes('i'), { 'node-z' => ['i'], 'socket' => ['i'] }, 'hashes i'; is_deeply $hasher->hashes('j'), { 'node-x' => ['j'], 'node-y' => ['j'] }, 'hashes j'; is_deeply $hasher->hashes('k'), { 'node-z' => ['k'], 'socket' => ['k'] }, 'hashes k'; is_deeply $hasher->hashes('l'), { 'node-x' => ['l'], 'socket' => ['l'] }, 'hashes l'; is_deeply $hasher->hashes('m'), { 'node-z' => ['m'], 'socket' => ['m'] }, 'hashes m'; is_deeply $hasher->hashes('n'), { 'node-z' => ['n'], 'socket' => ['n'] }, 'hashes n'; is_deeply $hasher->hashes('o'), { 'node-z' => ['o'], 'socket' => ['o'] }, 'hashes o'; is_deeply $hasher->hashes('p'), { 'node-z' => ['p'], 'node-y' => ['p'] }, 'hashes p'; is_deeply $hasher->hashes('q'), { 'node-z' => ['q'], 'socket' => ['q'] }, 'hashes q'; is_deeply $hasher->hashes('r'), { 'node-x' => ['r'], 'node-y' => ['r'] }, 'hashes r'; is_deeply $hasher->hashes('s'), { 'node-x' => ['s'], 'socket' => ['s'] }, 'hashes s'; is_deeply $hasher->hashes('t'), { 'node-x' => ['t'], 'node-y' => ['t'] }, 'hashes t'; is_deeply $hasher->hashes('u'), { 'node-z' => ['u'], 'socket' => ['u'] }, 'hashes u'; is_deeply $hasher->hashes('v'), { 'node-x' => ['v'], 'socket' => ['v'] }, 'hashes v'; is_deeply $hasher->hashes('w'), { 'node-z' => ['w'], 'node-y' => ['w'] }, 'hashes w'; is_deeply $hasher->hashes('x'), { 'node-z' => ['x'], 'socket' => ['x'] }, 'hashes x'; is_deeply $hasher->hashes('y'), { 'node-z' => ['y'], 'socket' => ['y'] }, 'hashes y'; is_deeply $hasher->hashes('z'), { 'node-x' => ['z'], 'node-y' => ['z'] }, 'hashes z'; # Test many keys is_deeply $hasher->hashes([qw(h p q v)]), { 'node-x' => ['h','v'], 'node-y' => ['h','p'], 'node-z' => ['p','q'], 'socket' => ['q','v'], }, 'hashes [h p q v]'; # Test complex keys with predefined hash value is_deeply $hasher->hashes([[0 => 'a0']]), { 'node-x' => ['a0'], 'node-y' => ['a0'] }, 'hashes [[0,a0]]'; is_deeply $hasher->hashes([[1 => 'a1']]), { 'node-y' => ['a1'], 'node-z' => ['a1'] }, 'hashes [[1,a1]]'; is_deeply $hasher->hashes([[2 => 'a2']]), { 'node-z' => ['a2'], 'socket' => ['a2'] }, 'hashes [[2,a2]]'; is_deeply $hasher->hashes([[3 => 'a3']]), { 'socket' => ['a3'], 'node-x' => ['a3'] }, 'hashes [[3,a3]]'; is_deeply $hasher->hashes([[4 => 'a4']]), { 'node-z' => ['a4'], 'socket' => ['a4'] }, 'hashes [[4,a4]]'; is_deeply $hasher->hashes([[5 => 'a5']]), { 'node-z' => ['a5'], 'socket' => ['a5'] }, 'hashes [[5,a5]]'; is_deeply $hasher->hashes([[6 => 'a6']]), { 'node-z' => ['a6'], 'socket' => ['a6'] }, 'hashes [[6,a6]]'; # Test many complex keys is_deeply $hasher->hashes([ [ 0 => 'a' ], [ 1 => 'b' ], [ 2 => 'c' ], [ 3 => 'd' ] ]), { 'node-x' => ['a','d'], 'node-y' => ['a','b'], 'node-z' => ['b','c'], 'socket' => ['c','d'], }, 'hashes [[1],[2],[3],[4]]' ; AnyEvent-Memcached-0.06/t/lib/0000755000175000000120000000000012232302511014664 5ustar monswheelAnyEvent-Memcached-0.06/t/lib/Test/0000755000175000000120000000000012232302511015603 5ustar monswheelAnyEvent-Memcached-0.06/t/lib/Test/AE/0000755000175000000120000000000012232302511016070 5ustar monswheelAnyEvent-Memcached-0.06/t/lib/Test/AE/MD.pm0000644000175000000120000000331612232302034016731 0ustar monswheelpackage #hide Test::AE::MD; # MemcacheDB test class use AnyEvent::Impl::Perl; use AnyEvent; use AnyEvent::Socket; use AnyEvent::Memcached; use common::sense; use utf8; use Test::More; use lib::abs; sub import { *{caller().'::runtest'} = \&runtest; @_ = 'Test::More'; goto &{ Test::More->can('import') }; } sub runtest(&) { my $cx = shift; my $code = sub { alarm 10; $cx->(@_,cas => 0, noreply => 0,); }; my ($host,$port); if (defined $ENV{MEMCACHEDB_SERVER}) { my $testaddr = $ENV{MEMCACHEDB_SERVER}; ($host,$port) = split ':',$testaddr;$host ||= '127.0.0.1'; # allow *_SERVER=:port my $do; my $cv = AE::cv; $port; my $cg;$cg = tcp_connect $host,$port, sub { undef $cg; @_ or plan skip_all => "No memcachedb instance running at $testaddr\n"; $cv->send; #connect }, sub { 1 }; $cv->recv; $code->($host,$port); } else { use version; my $v = `memcachedb -h 2>&1`; $? == 0 or plan skip_all => "Can't run memcached: $!"; my ($ver,$sub) = $v =~ m{.*?([\d.]+)(-\w+)?}; qv($ver) ge qv "1.2.1" or plan skip_all => "Memcachedb too old: $ver"; diag "using memcachedb $ver$sub"; eval q{use Test::TCP;1} or plan skip_all => "No Test::TCP"; $host = "127.0.0.1"; my $db = lib::abs::path('tdb'); $db .= '1' while -e $db; mkdir $db or plan skip_all => "Can't create test db $db: $!"; test_tcp( client => sub { $port = shift; my $pid = shift; $code->($host,$port); kill TERM => $pid; kill KILL => $pid; # Don't like to kill it, but should. }, server => sub { my $port = shift; close STDERR; exec("memcachedb -l $host -p $port -H $db") or plan skip_all => "Can't run memcachedb"; }, ); unlink $_ for (<$db/*>); rmdir $db; } } 1; AnyEvent-Memcached-0.06/t/lib/Test/AE/MC.pm0000644000175000000120000000275712232302034016740 0ustar monswheelpackage #hide Test::AE::MC; # Memcached test class use Test::More; use AnyEvent::Impl::Perl; use AnyEvent; use AnyEvent::Socket; BEGIN{ eval q{use AnyEvent::Memcached;1} or BAIL_OUT("$@") } use common::sense; use utf8; sub import { *{caller().'::runtest'} = \&runtest; @_ = 'Test::More'; goto &{ Test::More->can('import') }; } sub runtest(&) { my $cx = shift; my $code = sub { alarm 10; eval { $cx->(@_,noreply => 1, cas => 1); 1; } or do { warn "DIED $@"; die "$@"; } }; my ($host,$port); if (defined $ENV{MEMCACHED_SERVER}) { my $testaddr = $ENV{MEMCACHED_SERVER}; ($host,$port) = split ':',$testaddr;$host ||= '127.0.0.1'; # allow *_SERVER=:port my $do; my $cv = AE::cv; $port; my $cg;$cg = tcp_connect $host,$port, sub { undef $cg; @_ or plan skip_all => "No memcached instance running at $testaddr\n"; $cv->send; #connect }, sub { 1 }; $cv->recv; $code->($host,$port); } else { use version; my $v = `memcached -h 2>&1`; $? == 0 or plan skip_all => "Can't run memcached: $!"; my ($ver,$sub) = $v =~ m{.*?([\d.]+)(-\w+)?}; qv($ver) ge qv "1.2.4" or plan skip_all => "Memcached too old: $ver"; diag "using memcached $ver$sub"; eval q{use Test::TCP;1 } or plan skip_all => "No Test::TCP"; $host = "127.0.0.1"; test_tcp( client => sub { $port = shift; $code->($host,$port); }, server => sub { my $port = shift; exec("memcached -l $host -p $port") or plan skip_all => "Can't run memcached"; }, ) } } 1; AnyEvent-Memcached-0.06/t/pod.t0000644000175000000120000000044012232302034015063 0ustar monswheel#!/usr/bin/env perl use strict; use warnings; use lib::abs '../lib'; use Test::More; BEGIN { chdir lib::abs::path('..') and eval q{use Test::Pod 1.22; 1} or plan skip_all => "Prereq not met"; } all_pod_files_ok(); exit 0; # kwalitee hacks require Test::Pod; require Test::NoWarnings; AnyEvent-Memcached-0.06/t/02-usage-memdb.t0000644000175000000120000000030412232302033016704 0ustar monswheel#!/usr/bin/env perl -w use lib::abs 'lib','../lib';#, '../../AE-Cnn/lib'; use Test::AE::MD; use common::sense; do + lib::abs::path('.').'/check.pl'; $@ and die; exit; require Test::NoWarnings; AnyEvent-Memcached-0.06/t/00-load.t0000644000175000000120000000047012232302033015437 0ustar monswheel#!/usr/bin/env perl -w use lib::abs "../lib"; use Test::More tests => 2; use Test::NoWarnings; BEGIN { use_ok( 'AnyEvent::Memcached' ); } diag( "Testing AnyEvent::Memcached $AnyEvent::Memcached::VERSION, AnyEvent::Connection $AnyEvent::Connection::VERSION, using AnyEvent $AnyEvent::VERSION, Perl $], $^X" ); AnyEvent-Memcached-0.06/t/check.pl0000644000175000000120000001455312232302033015537 0ustar monswheeluse common::sense; runtest { my ($host,$port,%args) = @_; my $cv;$cv = AE::cv; diag "testing $host:$port"; require Test::NoWarnings;Test::NoWarnings->import; plan tests => 52+1; my $memd = AnyEvent::Memcached->new( servers => [ "$host:$port" ], cv => $cv, debug => 0, %args, namespace => "AE::Memd::t/$$/" . (time() % 100) . "/", ); isa_ok($memd, 'AnyEvent::Memcached'); $cv->begin; $memd->set('cas2','val2',cb => sub { ok(shift,"set cas2 as val1") or diag " Error: @_"; }); $memd->set('cas1','val1',cb => sub { ok(shift,"set cas as val1") or diag " Error: @_"; $memd->gets('cas1',cb => sub { my $value = shift; if ($value) { ok $value, 'got result' or diag " Error: @_"; is ref $value,'ARRAY', 'retval is array'; is $value->[1], 'val1', 'value correct'; # Now, break the value $memd->set('cas1','val2',cb => sub { ok(shift,"set cas as val2") or diag " Error: @_"; $memd->cas('cas1', $value->[0], 'val3',cb => sub { ok(!shift,"try cas as val3"); ok(!@_, 'cas have no errors') or diag " Error: @_"; $memd->gets('cas1',cb => sub { ok my $value = shift, 'gets again'; $memd->cas('cas1', $value->[0], 'val4',cb => sub { ok(shift,"set cas as val4"); ok(!@_, 'cas have no errors') or diag " Error: @_"; #Now, test 2 keys at once $memd->gets(['cas1','cas2'], cb => sub { ok my $values = shift, 'got gets* result' or diag " Error: @_"; is ref $values, 'HASH', 'retval is hash'; ok exists $values->{cas1}, 'have cas1'; ok exists $values->{cas2}, 'have cas2'; is ref $values->{cas1}, 'ARRAY', 'value 1 correct'; is ref $values->{cas2}, 'ARRAY', 'value 2 correct'; $memd->cas('cas1', $values->{cas1}[0], 'val5',cb => sub { ok(shift,"set cas1 as val5"); ok(!@_, 'cas1 have no errors') or diag " Error: @_"; }); $memd->cas('cas2', $values->{cas2}[0], 'val5',cb => sub { ok(shift,"set cas2 as val5"); ok(!@_, 'cas2 have no errors') or diag " Error: @_"; }); }); }); }); }); }); } else { my $error = shift; SKIP: { if ($error =~ /not enabled/) { skip "gets not enabled",19; } else { fail "gets failed"; diag "$error"; skip "gets failed",18; } } } }); }); $memd->set("key1", "val1", cb => sub { ok(shift,"set key1 as val1") or diag " Error: @_"; $memd->get("key1", cb => sub { is(shift, "val1", "get key1 is val1") or diag " Error: @_"; $memd->add("key1", "val-replace", cb => sub { ok(! shift, "add key1 properly failed"); $memd->add("key2", "val2", cb => sub { ok(shift, "add key2 as val2"); $memd->get("key2", cb => sub { is(shift, "val2", "get key2 is val2") or diag "@_"; $memd->replace("key2", "val-replace", cb => sub { ok(shift, "replace key2 as val-replace"); $memd->get("key2", cb => sub { is(shift, "val-replace", "get key2 is val-replace") or diag "@_"; $memd->set( key4 => {ref => 1}, cb => sub { ok shift, 'set ref' or diag "@_"; $memd->get( [qw(key2 key4)], cb => sub { ok(my $r = shift, 'get multi'); is_deeply $r, { qw(key2 val-replace key4 ), {ref => 1} }, 'get multi values'; }, ); }); $memd->rget('1','0', cb => sub { my ($r,$e) = @_; if (!$e) { $memd->set("key3", "val3", cb => sub { ok(shift,"set key3 as val3"); $memd->rget('key2','key3', cb => sub { # +left, +right my $r = shift; is( $r->{ 'key2' }, 'val-replace', 'rget[].key2' ); is( $r->{ 'key3' }, 'val3', 'rget[].key3' ); }); $memd->rget('key2','key3', '+right' => 0, cb => sub { my $r = shift; is( $r->{ 'key2' }, 'val-replace', 'rget[).key2' ); ok(! exists $r->{ 'key3' }, '!rget[).key3' ); }); $memd->rget('key2','key3', '+left' => 0, cb => sub { my $r = shift; ok(! exists $r->{ 'key2' }, '!rget(].key2' ); is( $r->{ 'key3' }, 'val3', 'rget(].key3' ); }); $memd->rget('key2','key3', rv => 'array', cb => sub { # +left, +right my $r = shift; is_deeply $r, [qw(key2 val-replace key3 val3)], 'rget[] array'; }); $memd->rget('key2','key3', '+right' => 0, rv => 'array', cb => sub { my $r = shift; is_deeply $r, [qw(key2 val-replace)], 'rget[) array'; }); $memd->rget('key2','key3', '+left' => 0, rv => 'array', cb => sub { my $r = shift; is_deeply $r, [qw(key3 val3)], 'rget(] array'; }); }); } else { like( $e, qr/rget not supported/, 'rget fails' ); SKIP: { skip "Have no rget",6+3 } } }); }); }); }); }); $memd->delete("key1", cb => sub { ok(shift, "delete key1"); $memd->get("key1", cb => sub { ok(! shift, "get key1 properly failed"); }); }); }); }); }); $memd->replace("key-noexist", "bogus", cb => sub { ok(!shift , "replace key-noexist properly failed"); }); my $need; $memd->set("ikey", $need = 3, cb => sub { ok(shift,"set ikey as 3") or diag " Error: @_"; #$memd->incr(ikey => 1, noreply => 1) and warn("norply ok"), ++$need; $memd->incr(ikey => 1, cb => sub { ++$need; my $igot = shift; is $igot, $need, 'incr ikey = '.$igot or diag " Error: @_"; $need = $igot-2; #$memd->decr(ikey => 2, noreply => 1);# or $need -= 2; $memd->decr(ikey => 2, cb => sub { my $dgot = shift; is $dgot, $need, 'decr ikey = '.$dgot or diag " Error: @_"; $memd->get('ikey', cb => sub { diag "get after incr/decr = ".shift; }); }); }); }); $memd->incadd(iakey => 42, cb => sub { is $_[0],42, 'incadd works as add'; $memd->get(iakey => cb => sub { is $_[0],42, 'incadd works as add (get check)'; $memd->incadd(iakey => 42, cb => sub { is $_[0], 42*2, 'incadd works as inc'; $memd->get(iakey => cb => sub { is $_[0],42*2, 'incadd works as inc (get check)'; }); }); }); }); $cv->end; $cv->recv; $memd->destroy(); }; AnyEvent-Memcached-0.06/MANIFEST.SKIP0000644000175000000120000000100512232302330015544 0ustar monswheel# Avoid version control files. \B\.git\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak ^MYMETA* \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ # Avoid Devel::Cover files. \bcover_db\b # Avoid local testing/dist files ^dist/ ^makeall\.sh$ ^tmp/ ^t/lib/Test/AE/tdb.* ^AnyEvent-Memcached-.*AnyEvent-Memcached-0.06/inc/0000755000175000000120000000000012232302511014424 5ustar monswheelAnyEvent-Memcached-0.06/inc/Module/0000755000175000000120000000000012232302511015651 5ustar monswheelAnyEvent-Memcached-0.06/inc/Module/Install.pm0000644000175000000120000003013512232302507017624 0ustar monswheel#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. AnyEvent-Memcached-0.06/inc/Module/Install/0000755000175000000120000000000012232302511017257 5ustar monswheelAnyEvent-Memcached-0.06/inc/Module/Install/Metadata.pm0000644000175000000120000004327712232302507021357 0ustar monswheel#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; AnyEvent-Memcached-0.06/inc/Module/Install/Makefile.pm0000644000175000000120000002743712232302507021354 0ustar monswheel#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 AnyEvent-Memcached-0.06/inc/Module/Install/Fetch.pm0000644000175000000120000000462712232302510020656 0ustar monswheel#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; AnyEvent-Memcached-0.06/inc/Module/Install/Include.pm0000644000175000000120000000101512232302507021202 0ustar monswheel#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; AnyEvent-Memcached-0.06/inc/Module/Install/Win32.pm0000644000175000000120000000340312232302510020516 0ustar monswheel#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; AnyEvent-Memcached-0.06/inc/Module/Install/Can.pm0000644000175000000120000000615712232302510020326 0ustar monswheel#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 AnyEvent-Memcached-0.06/inc/Module/Install/WriteAll.pm0000644000175000000120000000237612232302510021347 0ustar monswheel#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; AnyEvent-Memcached-0.06/inc/Module/Install/AutoInstall.pm0000644000175000000120000000416212232302507022064 0ustar monswheel#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; AnyEvent-Memcached-0.06/inc/Module/Install/Base.pm0000644000175000000120000000214712232302507020500 0ustar monswheel#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 AnyEvent-Memcached-0.06/inc/Module/AutoInstall.pm0000644000175000000120000006216212232302507020462 0ustar monswheel#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @installed; @installed = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1193 AnyEvent-Memcached-0.06/.gitignore0000644000175000000120000000021712232302033015642 0ustar monswheelblib* inc* Makefile Makefile.old Build _build* pm_to_blib* *.tar.gz .lwpcookies AnyEvent-Memcached-* !dist/*.tar.gz t/lib/Test/AE/tdb cover_db AnyEvent-Memcached-0.06/MANIFEST0000644000175000000120000000144012232302510015002 0ustar monswheel.gitignore Changes examples/test.pl inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/AnyEvent/Memcached.pm lib/AnyEvent/Memcached/Buckets.pm lib/AnyEvent/Memcached/Conn.pm lib/AnyEvent/Memcached/Hash.pm lib/AnyEvent/Memcached/Hash/WithNext.pm lib/AnyEvent/Memcached/Peer.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README t/00-load.t t/01-usage-memd.t t/02-usage-memdb.t t/03-storable.t t/04-hashing.t t/05-hashing-with-next.t t/check.pl t/lib/Test/AE/MC.pm t/lib/Test/AE/MD.pm t/pod.t xt/99-dist.t AnyEvent-Memcached-0.06/README0000644000175000000120000001754312232302507014552 0ustar monswheelNAME AnyEvent::Memcached - AnyEvent memcached client SYNOPSIS use AnyEvent::Memcached; my $memd = AnyEvent::Memcached->new( servers => [ "10.0.0.15:11211", "10.0.0.15:11212" ], # same as in Cache::Memcached debug => 1, compress_threshold => 10000, namespace => 'my-namespace:', # May use another hashing algo: hasher => 'AnyEvent::Memcached::Hash::WithNext', cv => $cv, # AnyEvent->condvar: group callback ); $memd->set_servers([ "10.0.0.15:11211", "10.0.0.15:11212" ]); # Basic methods are like in Cache::Memcached, but with additional cb => sub { ... }; # first argument to cb is return value, second is the error(s) $memd->set( key => $value, cb => sub { shift or warn "Set failed: @_" } ); # Single get $memd->get( 'key', cb => sub { my ($value,$err) = shift; $err and return warn "Get failed: @_"; warn "Value for key is $value"; } ); # Multi-get $memd->get( [ 'key1', 'key2' ], cb => sub { my ($values,$err) = shift; $err and return warn "Get failed: @_"; warn "Value for key1 is $values->{key1} and value for key2 is $values->{key2}" } ); # Additionally there is rget (see memcachedb-1.2.1-beta) $memd->rget( 'fromkey', 'tokey', cb => sub { my ($values,$err) = shift; $err and warn "Get failed: @_"; while (my ($key,$value) = each %$values) { # ... } } ); # Rget with sorted responce values $memd->rget( 'fromkey', 'tokey', rv => 'array' cb => sub { my ($values,$err) = shift; $err and warn "Get failed: @_"; for (0 .. $#values/2) { my ($key,$value) = @$values[$_*2,$_*2+1]; } } ); DESCRIPTION Asyncronous "memcached/memcachedb" client for AnyEvent framework NOTICE There is a notices in Cache::Memcached::AnyEvent related to this module. They all has been fixed Prerequisites We no longer need Object::Event and Devel::Leak::Cb. At all, the dependency list is like in Cache::Memcached + AnyEvent Binary protocol It seems to me, that usage of binary protocol from pure perl gives very little advantage. So for now I don't implement it Unimplemented Methods There is a note, that get_multi is not implementeted. In fact, it was implemented by method "get", but the documentation was wrong. In general, this module follows the spirit of AnyEvent rather than correspondence to Cache::Memcached interface. METHODS new %args Currently supported options: servers =item namespace =item debug =item cv =item compress_threshold =item compress_enable =item timeout =item hasher If set, will use instance of this class for hashing instead of default. For implementing your own hashing, see sources of AnyEvent::Memcached::Hash and AnyEvent::Memcached::Hash::With::Next noreply If true, additional connection will established for noreply commands. cas If true, will enable cas/gets commands (since they are not suppotred in memcachedb) set_servers Setup server list connect Establish connection to all servers and invoke event C, when ready set( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Unconditionally sets a key to a given value in the memcache. $rc is '1' Successfully stored '0' Item was not stored undef Error happens, see $err cas( $key, $cas, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) $memd->gets($key, cb => sub { my $value = shift; unless (@_) { # No errors my ($cas,$val) = @$value; # Change your value in $val $memd->cas( $key, $cas, $value, cb => sub { my $rc = shift; if ($rc) { # stored } else { # ... } }); } }) $rc is the same, as for "set" Store the $value on the server under the $key, but only if CAS value associated with this key is equal to $cas. See also "gets" add( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Like "set", but only stores in memcache if the key doesn't already exist. replace( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Like "set", but only stores in memcache if the key already exists. The opposite of add. append( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Append the $value to the current value on the server under the $key. append command first appeared in memcached 1.2.4. prepend( $key, $value, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Prepend the $value to the current value on the server under the $key. prepend command first appeared in memcached 1.2.4. get( $key, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Retrieve the value for a $key. $key should be a scalar get( $keys : ARRAYREF, [cv => $cv], [ expire => $expire ], cb => $cb->( $values_hash, $err ) ) Retrieve the values for a $keys. Return a hash with keys/values gets( $key, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Retrieve the value and its CAS for a $key. $key should be a scalar. $rc is a reference to an array [$cas, $value], or nothing for non-existent key gets( $keys : ARRAYREF, [cv => $cv], [ expire => $expire ], cb => $cb->( $rc, $err ) ) Retrieve the values and their CAS for a $keys. $rc is a hash reference with $rc->{$key} is a reference to an array [$cas, $value] delete( $key, [cv => $cv], [ noreply => 1 ], cb => $cb->( $rc, $err ) ) Delete $key and its value from the cache. If "noreply" is true, cb doesn't required del Alias for "delete" remove Alias for "delete" 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 "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. decr( $key, $decrement, [cv => $cv], [ noreply => 1 ], cb => $cb->( $rc, $err ) ) Opposite to "incr" 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 $from the starting key $till finishing key +left If true, then starting key will be included in results. true by default +right If true, then finishing key will be included in results. true by default max Maximum number of results to fetch. 100 is the maximum and is the default rv If passed rv => 'array', then the return value will be arrayref with values in order, returned by memcachedb. incadd ( $key, $increment, [cv => $cv], [ noreply => 1 ], cb => $cb->( $rc, $err ) ) Increment key, and if it not exists, add it with initial value. If add fails, try again to incr or fail destroy Shutdown object as much, as possible, incl cleaning of incapsulated objects BUGS Feature requests are welcome Bug reports are welcome AUTHOR Mons Anderson, "" COPYRIGHT & LICENSE Copyright 2009 Mons Anderson, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. AnyEvent-Memcached-0.06/examples/0000755000175000000120000000000012232302511015471 5ustar monswheelAnyEvent-Memcached-0.06/examples/test.pl0000644000175000000120000000103612232302033017004 0ustar monswheel#!/usr/bin/env perl use strict; use lib::abs '../lib'; use AnyEvent; use AnyEvent::Memcached; my $cv = AnyEvent->condvar; $cv->begin(sub { $cv->send }); my $memd = AnyEvent::Memcached->new( servers => [ '127.0.0.1:11211' ], cv => $cv, # debug => 1, namespace => "test:", ); $memd->set("key1", "val1", cb => sub { shift or warn "Set key1 failed: @_"; warn "Set ok"; $memd->get("key1", cb => sub { my ($v,$e) = @_; $e and return warn "Get failed: $e"; warn "Got value for key1: $v"; }); }); $cv->end; $cv->recv;