AnyEvent-Memcached-0.08/000755 000766 000024 00000000000 13017337646 015170 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/.gitignore000644 000766 000024 00000000217 13017337314 017150 0ustar00monsstaff000000 000000 blib* 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.08/Changes000644 000766 000024 00000001753 13017337365 016467 0ustar00monsstaff000000 000000 Revision history for AnyEvent-Memcached 0.08 2016-11-29 * Fix cv-begin/end 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.08/examples/000755 000766 000024 00000000000 13017337646 017006 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/inc/000755 000766 000024 00000000000 13017337646 015741 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/lib/000755 000766 000024 00000000000 13017337646 015736 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/LICENSE000644 000766 000024 00000000252 13017337314 016164 0ustar00monsstaff000000 000000 LICENSE 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.08/Makefile.PL000644 000766 000024 00000001047 13017337314 017134 0ustar00monsstaff000000 000000 use 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.08/MANIFEST000644 000766 000024 00000001463 13017337641 016320 0ustar00monsstaff000000 000000 .gitignore Changes examples/incadd.pl 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.08/MANIFEST.SKIP000644 000766 000024 00000001005 13017337314 017052 0ustar00monsstaff000000 000000 # 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.08/META.yml000644 000766 000024 00000001607 13017337641 016440 0ustar00monsstaff000000 000000 --- 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.17' 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.08' 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.08' AnyEvent-Memcached-0.08/README000644 000766 000024 00000017543 13017337641 016055 0ustar00monsstaff000000 000000 NAME 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.08/t/000755 000766 000024 00000000000 13017337646 015433 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/xt/000755 000766 000024 00000000000 13017337646 015623 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/xt/99-dist.t000644 000766 000024 00000001125 13017337314 017201 0ustar00monsstaff000000 000000 #!/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.08/t/00-load.t000644 000766 000024 00000000470 13017337314 016745 0ustar00monsstaff000000 000000 #!/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.08/t/01-usage-memd.t000644 000766 000024 00000000303 13017337314 020046 0ustar00monsstaff000000 000000 #!/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.08/t/02-usage-memdb.t000644 000766 000024 00000000304 13017337314 020212 0ustar00monsstaff000000 000000 #!/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.08/t/03-storable.t000644 000766 000024 00000001715 13017337314 017647 0ustar00monsstaff000000 000000 #!/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.08/t/04-hashing.t000644 000766 000024 00000006154 13017337314 017460 0ustar00monsstaff000000 000000 #!/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.08/t/05-hashing-with-next.t000644 000766 000024 00000007471 13017337314 021411 0ustar00monsstaff000000 000000 #!/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.08/t/check.pl000644 000766 000024 00000014553 13017337314 017045 0ustar00monsstaff000000 000000 use 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.08/t/lib/000755 000766 000024 00000000000 13017337646 016201 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/t/pod.t000644 000766 000024 00000000440 13017337314 016370 0ustar00monsstaff000000 000000 #!/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.08/t/lib/Test/000755 000766 000024 00000000000 13017337646 017120 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/t/lib/Test/AE/000755 000766 000024 00000000000 13017337646 017405 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/t/lib/Test/AE/MC.pm000644 000766 000024 00000002757 13017337314 020245 0ustar00monsstaff000000 000000 package #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.08/t/lib/Test/AE/MD.pm000644 000766 000024 00000003317 13017337314 020237 0ustar00monsstaff000000 000000 package #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 memcachedb: $!"; 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.08/lib/AnyEvent/000755 000766 000024 00000000000 13017337646 017467 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/lib/AnyEvent/Memcached/000755 000766 000024 00000000000 13017337646 021335 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/lib/AnyEvent/Memcached.pm000644 000766 000024 00000053421 13017337325 021672 0ustar00monsstaff000000 000000 package AnyEvent::Memcached; use 5.8.8; =head1 NAME AnyEvent::Memcached - AnyEvent memcached client =cut our $VERSION = '0.08'; =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("Have no Compress::Zlib installed, but have compress_enable option"); carp "@{[ keys %args ]} options are not supported yet" if %args; Carp::confess "Invalid characters in 'namespace' option: '$self->{namespace}'" if $self->{namespace} =~ /[\x00-\x20\x7F]/; $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 ($key =~ /[\x00-\x20\x7F]/) { carp "Invalid characters in key '$key'"; return $args{cb} ? $args{cb}(undef, "Invalid key") : 0; } 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}; }; $cv->begin; 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; } ); } } $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}; if ($cas =~ /\D/) { carp "Invalid characters in cas '$cas'"; return $args{cb}(undef, "Invalid cas"); } #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; } if (my ($key) = grep { /[\x00-\x20\x7F]/ } $array ? @$keys : $keys) { carp "Invalid characters in key '$key'"; return $args{cb} ? $args{cb}(undef, "Invalid key") : 0; } $_ and $_->begin for $self->{cv}, $args{cv}; my $servers = $self->{hash}->servers($keys, for => 'get'); my %res; my $cv = AE::cv { $self->_deflate(\%res); $args{cb}( $array ? \%res : $res{ $keys } ); $_ and $_->end for $args{cv}, $self->{cv}; }; for my $srv ( keys %$servers ) { #warn "server for $key = $srv, $self->{peers}{$srv}"; $cv->begin; my $keys = join(' ',map "$self->{namespace}$_", @{ $servers->{$srv} }); $self->{peers}{$srv}{con}->request( "$cmd $keys" ); $self->{peers}{$srv}{con}->reader( id => $srv.'+'.$keys, res => \%res, namespace => $self->{namespace}, cb => sub { # cb { $cv->end; }); } return; } sub get { shift->_get(get => @_) } sub gets { my $self = shift; unless ($self->{cas}) { shift;my %args = @_;return $args{cb}(undef, "CAS not enabled") } $self->_get(gets => @_) } =head2 delete( $key, [cv => $cv], [ noreply => 1 ], cb => $cb->( $rc, $err ) ) Delete $key and its value from the cache. If C 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.08/lib/AnyEvent/Memcached/Buckets.pm000644 000766 000024 00000004511 13017337314 023264 0ustar00monsstaff000000 000000 package #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.08/lib/AnyEvent/Memcached/Conn.pm000644 000766 000024 00000003615 13017337314 022565 0ustar00monsstaff000000 000000 package #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.08/lib/AnyEvent/Memcached/Hash/000755 000766 000024 00000000000 13017337646 022220 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/lib/AnyEvent/Memcached/Hash.pm000644 000766 000024 00000001704 13017337314 022550 0ustar00monsstaff000000 000000 package #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.08/lib/AnyEvent/Memcached/Peer.pm000644 000766 000024 00000006274 13017337314 022567 0ustar00monsstaff000000 000000 package #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.08/lib/AnyEvent/Memcached/Hash/WithNext.pm000644 000766 000024 00000002005 13017337314 024315 0ustar00monsstaff000000 000000 package 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.08/inc/Module/000755 000766 000024 00000000000 13017337646 017166 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/inc/Module/AutoInstall.pm000644 000766 000024 00000062311 13017337641 021761 0ustar00monsstaff000000 000000 #line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.17'; } # 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::getcwd(); $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 compatibility 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, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } 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} = $opt eq 'urllist' ? [$arg] : $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::getcwd() ); 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 1197 AnyEvent-Memcached-0.08/inc/Module/Install/000755 000766 000024 00000000000 13017337646 020574 5ustar00monsstaff000000 000000 AnyEvent-Memcached-0.08/inc/Module/Install.pm000644 000766 000024 00000027145 13017337641 021136 0ustar00monsstaff000000 000000 #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.006; 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.17'; # 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::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); 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::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $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( {no_chdir => 1, wanted => 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($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $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; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } 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; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _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.08/inc/Module/Install/AutoInstall.pm000644 000766 000024 00000004162 13017337641 023367 0ustar00monsstaff000000 000000 #line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @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.08/inc/Module/Install/Base.pm000644 000766 000024 00000002147 13017337641 022003 0ustar00monsstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.17'; } # 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.08/inc/Module/Install/Can.pm000644 000766 000024 00000006405 13017337641 021633 0ustar00monsstaff000000 000000 #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.17'; @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; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } 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 245 AnyEvent-Memcached-0.08/inc/Module/Install/Fetch.pm000644 000766 000024 00000004627 13017337641 022167 0ustar00monsstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @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.08/inc/Module/Install/Include.pm000644 000766 000024 00000001015 13017337641 022505 0ustar00monsstaff000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @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.08/inc/Module/Install/Makefile.pm000644 000766 000024 00000027437 13017337641 022657 0ustar00monsstaff000000 000000 #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.17'; @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-separated 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.08/inc/Module/Install/Metadata.pm000644 000766 000024 00000043302 13017337641 022647 0ustar00monsstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @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 hashes 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.08/inc/Module/Install/Win32.pm000644 000766 000024 00000003403 13017337641 022027 0ustar00monsstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @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.08/inc/Module/Install/WriteAll.pm000644 000766 000024 00000002376 13017337641 022660 0ustar00monsstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @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.08/examples/incadd.pl000644 000766 000024 00000003521 13017337314 020556 0ustar00monsstaff000000 000000 #!/usr/bin/env perl use strict; use lib::abs '../lib'; use AnyEvent; use AnyEvent::Memcached; my $cv = AnyEvent->condvar; my @clients; for (1..100) { my $memd = AnyEvent::Memcached->new( servers => [ '127.0.0.1:11211' ], namespace => "test:", ); push @clients,$memd; } my $t;$t = AE::timer 0,1,sub { # every secons one clients will delete a key $clients[0]->delete('key1', cb => sub { defined $_[0] or warn "delete failed: $_[1]"; warn $_[0]; }); } if 0; # prepare a work. # delete key and make sure all clients get connected my $next = AE::cv; $clients[0]->delete('key1', cb => sub { defined $_[0] or warn "delete failed: $_[1]"; warn "old value was: $_[0]"; $next->begin; for my $memd (@clients) { $next->begin; $memd->get('key1',cb => sub { $next->end }); } $next->end; }); $next->cb(sub { # now we have no this key in database, and get all clients connected my $reqno = 0; $cv->begin(sub { $cv->send }); for my $id (1..$#clients) { # now, we ask every client to make repeatedly incadd, 1000 times for each; my $memd = $clients[$id]; my $count = 10; $cv->begin; my $op;$op = sub { my $no = ++$reqno; $count-- == 0 and return $cv->end; $memd->incadd('key1',1, expire => 1, cb => sub { defined $_[0] or warn "@_"; warn "$id $no -> @_"; $op->(); }); };$op->(); } $cv->end; # and we run deleter, that will make thing "bad" my $deleter;$deleter = sub { $clients[0]->delete('key1',cb => sub { warn "deleted = @_"; my $wait;$wait = AE::timer 0,0,sub { undef $wait; $deleter->(); }; }); };$deleter->(); }); $cv->recv; __END__ $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; AnyEvent-Memcached-0.08/examples/test.pl000644 000766 000024 00000001036 13017337314 020312 0ustar00monsstaff000000 000000 #!/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;