Cache-Memcached-libmemcached-0.04001/000750 000766 000024 00000000000 12211354577 017400 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/Changes000644 000766 000024 00000013074 12211354447 020701 0ustar00timbostaff000000 000000 Changes ======= 0.04001 - 3rd Sept 2013 - Require Memcached::libmemcached 1.001701 - Fixed incr and decr methods to return undef on failure. 0.03001 - 29 Oct 2010 - Require Memcached::libmemcached 0.4405 - Documented available libmemcached behaviours. - All libmemcached behaviours can now be set via new({ behaviour_... => ... })! - Optimized namespace support via libmemcached 'prefix key' mechanism. - Fixed methods like incr() and decr() that didn't apply the namespace. - Added namespace() method for Cache::Memcached::Fast compatibility. - Added support for Cache::Memcached::Fast style hashref server specification. - Added support for server weights. - Added $keys parameter to stats() - Removed malloc, sizes, and self from default stats() $keys. - Added server_versions() method for Cache::Memcached::Fast compatibility. - Added the documented enable_compress() method for Cache::Memcached compatibility. - Removed undocumented version() method. - Assorted documentation additions and cleanups. 0.02011 - 27 May 2011 - ** NOTE DUPLICATE VERSION ** - Fix usage of foreach qw() which emits warnings under perl 5.14 (rt #68487) ** This version has only these changes over 0.02010 ** 0.02011 - 26 Oct 2010 - Many more libmemcached behaviours are now accessible. - stats() now returns many more items in the totals hash - Fixed compression, thanks to Ask Bjørn Hansen, RT#46985 - Require Memcached::libmemcached 0.4402 0.02010 - 07 Sep 2009 - overhaul tests - require Memcached::libmemcached 0.3102 0.02009 - 03 Jul 2008 - Correct get_multi() interaction with namespaces (Faylan Lim) 0.02008 - 03 Jul 2008 - Offsets passed to decr() and incr() weren't properly handled. Pointed out by Taro Funaki 0.02007 - 27 May 2008 - Arrayref arguments for get/set/add/et al have been properly implemented. Now you can use master keys. Yey! - fix incr()/decr() to respect namespace - Respect PERL_LIBMEMCACHED_OPTIMIZE - Require Memcached::libmemcached 0.2101 (now consistent hashing should work properly!) 0.02006 - 09 May 2008 - Namespace support was ot properly working. fixed. 0.02005 - 18 Apr 2008 - Explicitly require version of Test::More - Treat expiration time / time as a special case and don't proxy undef to memcached_* method calls. 0.02004 - 17 Apr 2008 - Require Memcached::libmemcached 0.1902 - Explcitly weaken reference to self in the callbacks 0.02003 - 13 Apr 2008 - Add stats() method - Require Memcached::libmemcached 0.1901 0.02002 - 30 Mar 2008 - Auto-generate accessors. - Add docs and tests for hashing_algorithm and distribution_method. They can also be specified in the constructor. - Add more docs that deals with libmemcached-specific features 0.02001 - 27 Mar 2008 - Require bytes pragma, just in case it wasn't loaded elsewhere. Should clear rt #34460 0.02000 - 04 Mar 2008 - Use Memcached::libmemcached 0.1701 - Subclass Memcached::libmemcached instead of containing it - Fix problem where detecting host:port wasn't properly working - Update benchmarks 0.01000 - 29 Jan 2008 - Use Memcached::libmemcached as the underlying library, instead of hooking directly to the C library. - (get|set)_compress_enabled has been renamed to (get|set)_compress_enable - stats() and cas() are currently disabled. - add behavior_set() / behavior_get() 0.00007 - Never released? - Added prepend(), append() - Added first cut support for CAS * cas() * gets() * get_cas() * get_cas_multi() - Implement accessors: * set_support_cas - Use code references instead of code invocation via sub names. - Tweak tests for more coverage 0.00006 - 19 Jan 2008 - Makefile.PL now uses Devel::CheckLib - Fix replace(), which was doing set() underneath instead of a real replace - Fix t/03_compress.t which wasn't respecting MEMCACHED_SERVER - Update benchmark to run more set() tests, and to report version number for each modules being used. 0.00005 - 17 Jan 2008 - Fix typo in POD. - Implement stats() -- it's a half-baked implementation. Please send patches! - Implement disconnect_all() - Implement some methods that allows you to tweak libmemcached behavior (NOTE: API may not be permanent!) * set_no_block() / is_no_block() * set_distribution_method() / get_distribution_method() * set_hashing_algorithm() / get_hashing_algorithm() 0.00004 - 13 Jan 2008 - No code change. - Note in POD what the differences between other memcached clients are. rt #32277 - Update tools/benchmark.pl to include the following: * comparisons between get() for small scalar, complex data structures, and compressed data * comparisons between set() for small scalar, complex data structures, and compressed data 0.00003 - 13 Jan 2008 - Revert back to go without using backend proxy. - Fix segmentation fault when using get_multi() without debugging enabled. - Implement set() as a pure C function. - Implement add(). - Implement replace(). - Implement flush_all(). - Implement accessors: * set_compress_threshold * get_compress_threshold * set_compress_enabled * get_compress_enabled * set_compress_savings * get_compress_savings * compress_enabled - Fix behavior of set_servers() to actually replace the server list. - Add tools/benchmark.pl to compare against vanilla Cache::Memcached. 0.00002 - 13 Jan 2008 - Implement get_multi(), delete(), incr(), decr() - Implement connecting to memcached via unix socket. - Add ::Constants package. 0.00001 - 11 Jan 2008 - Initial release. - Only supportes get()/set() Cache-Memcached-libmemcached-0.04001/inc/000750 000766 000024 00000000000 12211354577 020151 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/lib/000750 000766 000024 00000000000 12211354577 020146 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/Makefile.PL000644 000766 000024 00000000517 12211354473 021355 0ustar00timbostaff000000 000000 use strict; use inc::Module::Install; name('Cache-Memcached-libmemcached'); all_from('lib/Cache/Memcached/libmemcached.pm'); requires('Memcached::libmemcached', '1.001701'); requires('Storable'); requires('Carp'); requires('Task::Weaken'); recommends('Compress::Zlib'); build_requires('Test::More', 0.80); auto_include; WriteAll; Cache-Memcached-libmemcached-0.04001/MANIFEST000644 000766 000024 00000001341 11461577164 020542 0ustar00timbostaff000000 000000 Changes inc/Module/Install.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 inc/Test/More.pm lib/Cache/Memcached/libmemcached.pm Makefile.PL MANIFEST This list of files META.yml t/01_load.t t/02_basic.t t/03_compress.t t/04_get_multi.t t/05_sequence.t t/06_flush.t t/07_add-replace.t t/08_stats.t t/09_disconnect.t t/10_interop.t t/11_prepend.t t/12_append.t t/13_cas.t t/14_no_block.t t/15_distribution_method.t t/16_hashing_algorithm.t t/17_namespace.t t/18_incr_decr.t t/99_pod-coverage.t t/99_pod.t t/lib/libmemcached_test.pm tools/benchmark.pl Cache-Memcached-libmemcached-0.04001/META.yml000644 000766 000024 00000001221 11462543411 020644 0ustar00timbostaff000000 000000 --- abstract: 'Cache interface to Memcached::libmemcached' author: - 'Copyright (c) 2008 Daisuke Maki ' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Cache-Memcached-libmemcached no_index: directory: - inc - t recommends: Compress::Zlib: 0 requires: Carp: 0 Memcached::libmemcached: 0.4405 Storable: 0 Task::Weaken: 0 resources: license: http://dev.perl.org/licenses/ version: 0.03001 Cache-Memcached-libmemcached-0.04001/t/000750 000766 000024 00000000000 12211354577 017643 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/tools/000750 000766 000024 00000000000 12211354577 020540 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/tools/benchmark.pl000644 000766 000024 00000015313 11462543357 023042 0ustar00timbostaff000000 000000 use strict; use Benchmark qw(cmpthese); use Cache::Memcached; use Cache::Memcached::Fast; use Cache::Memcached::libmemcached; use Memcached::libmemcached qw(MEMCACHED_BEHAVIOR_BINARY_PROTOCOL); use Getopt::Long; my $no_block = 0; my $server = ''; my %modes = ( simple_get => 1, simple_get_multi => 1, serialize_get => 0, simple_set => 0, ); GetOptions( "no_block!" => \$no_block, "server=s" => \$server, "simple-get!" => \$modes{simple_get}, "simple-get_multi!" => \$modes{simple_get_multi}, "serialize-get!" => \$modes{serialize_get}, "compress-get!" => \$modes{compress_get}, "simple-set!" => \$modes{simple_set}, "serialize-set!" => \$modes{serialize_set}, "compress-set!" => \$modes{compress_set}, ) or exit 1; my $repetitions = shift || 50_000; $server ||= $ENV{MEMCACHED_SERVER} || '127.0.0.1:11211'; print "Module Information:\n"; foreach my $module qw(Cache::Memcached Cache::Memcached::Fast Cache::Memcached::libmemcached Memcached::libmemcached) { no strict 'refs'; print " + $module => " . ${ "${module}::VERSION" }, "\n"; } print "\n"; print "Server Information:\n"; { my $memd = Cache::Memcached::Fast->new({servers => [$server]}); my $versions = $memd->server_versions; while (my ($server, $version) = each %$versions) { print " + $server => $version\n"; } } print "\n"; print "Options:\n"; print " + Memcached server: $server\n"; print " + Include no block mode (where applicable)? :", $no_block ? "YES" : "NO", "\n"; my %args = ( servers => [ $server ], compress_threshold => 1_000, ); my $data; print "\n"; print "Prepping clients...\n"; my %clients = ( perl_memcached => Cache::Memcached->new(\%args), memcached_fast => Cache::Memcached::Fast->new(\%args), libmemcached => Cache::Memcached::libmemcached->new(\%args), memcached_plain => do { my $memd = Memcached::libmemcached->new(); if ($server =~ /^([^:]+):([^:]+)$/) { $memd->memcached_server_add($1, $2); } else { $memd->memcached_server_add_unix_socket($server); } $memd; }, ); if (0) { $clients{libmemcached_binary} = Cache::Memcached::libmemcached->new({ %args, binary_protocol => 1 }); $clients{memcached_plain_binary} = do { my $memd = Memcached::libmemcached->new(); if ($server =~ /^([^:]+):([^:]+)$/) { $memd->memcached_server_add($1, $2); } else { $memd->memcached_server_add_unix_socket($server); } $memd->memcached_behavior_set( MEMCACHED_BEHAVIOR_BINARY_PROTOCOL, 1 ); $memd; }; } # Include non-blocking client modes if ($no_block) { $clients{libmemcached_no_block} = Cache::Memcached::libmemcached->new({ %args, no_block => 1 }); } print "\n"; if ($modes{simple_get}) { print qq|==== Benchmark "Simple get() (scalar)" ====\n|; $data = '0123456789' x 10; $clients{perl_memcached}->set( 'foo', $data ); cmpthese($repetitions, +{ map { my $client = $clients{$_}; ($_ => sub { my $value = ref $client eq 'Memcached::libmemcached' ? $client->memcached_get('foo') : $client->get('foo'); die "$client did not return proper value (wanted '$data', got '$value')" if $value ne $data; }) } keys %clients }); } if ($modes{simple_get_multi}) { print qq|==== Benchmark "Simple get_multi() (scalar)" ====\n|; my @keys = ('a'..'z'); for (@keys) { $clients{perl_memcached}->set($_, $_); } cmpthese($repetitions, +{ map { my $client = $clients{$_}; $_ => sub { $client->get_multi(@keys) } } keys %clients }); } if ($modes{serialize_get}) { print qq|==== Benchmark "Serialization with get()" ====\n|; $data = { foo => [ qw(1 2 3) ] }; $clients{perl_memcached}->set( 'foo', $data ); cmpthese($repetitions, { map { my $client = $clients{$_}; $_ => sub { my $h = $client->get('foo'); ref($h) eq 'HASH' or die "$client did not return a hash"; ref($h->{foo}) eq 'ARRAY' or die "$client did not return an array in hash"; } } keys %clients }); } if ($modes{compress_get}) { print qq|==== Benchmark "Simple get() (w/compression)" ====\n|; $data = '0123456789' x 500; $clients{perl_memcached}->set( 'foo', $data ); cmpthese($repetitions, { map { my $client = $clients{$_}; $_ => sub { my $h = $client->get('foo'); length($h) == 5000 or die "$client did not return 5000 bytes"; } } keys %clients }); } if ($modes{simple_set}) { print qq|==== Benchmark "Simple set() (scalar)" ====\n|; $data = '0123456789' x 10; cmpthese($repetitions, { map { my $client = $clients{$_}; $_ => sub { $client->set('foo', $data); } } keys %clients }); } if ($modes{serialize_set}) { print qq|==== Benchmark "Simple set() (w/seriale)" ====\n|; $data = { foo => [ qw( 1 2 3 ) ] }; cmpthese($repetitions, { map { my $client = $clients{$_}; $_ => sub { $client->set('foo', $data); } } keys %clients }); } if ($modes{compress_set}) { print qq|==== Benchmark "Simple set() (w/compress)" ====\n|; $data = '0123456789' x 500; cmpthese($repetitions, { map { my $client = $clients{$_}; $_ => sub { $client->set('foo', $data); } } keys %clients }); } __END__ { print qq|==== Benchmark "Simple set() (w/serialize)" ====\n|; $data = { foo => [ qw(1 2 3) ] }; cmpthese(100_000, { perl_memcahed => sub { $memd->set( 'foo', $data ); }, memcached_fast => sub { $memd_fast->set( 'foo', $data ); }, libmemcached => sub { $libmemd->set( 'foo', $data ); }, # libmemcached_no_block => sub { # $libmemd_no_block->set( 'foo', $data ); # }, }); } { print qq|==== Benchmark "Simple set() (w/compress)" ====\n|; $data = '0123456789' x 500; cmpthese(100_000, { perl_memcahed => sub { $memd->set( 'foo', $data ); }, memcached_fast => sub { $memd_fast->set( 'foo', $data ); }, libmemcached => sub { $libmemd->set( 'foo', $data ); }, # libmemcached_no_block => sub { # $libmemd_no_block->set( 'foo', $data ); # }, }); } Cache-Memcached-libmemcached-0.04001/t/01_load.t000644 000766 000024 00000000124 11461531153 021242 0ustar00timbostaff000000 000000 use strict; use Test::More (tests => 1); use_ok("Cache::Memcached::libmemcached"); Cache-Memcached-libmemcached-0.04001/t/02_basic.t000644 000766 000024 00000004333 12100533171 021404 0ustar00timbostaff000000 000000 use strict; use lib "t/lib"; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create(); plan(tests => 24); isa_ok($cache, "Cache::Memcached::libmemcached"); { $cache->set("foo", "bar", 300); my $val = $cache->get("foo"); is($val, "bar", "simple value"); } { $cache->set("foo", { bar => 1 }, 300); my $val = $cache->get("foo"); is_deeply($val, { bar => 1 }, "got complex values"); } { ok( $cache->get("foo"), "before delete returns ok"); ok( $cache->delete("foo") ); ok( ! $cache->get("foo"), "delete works"); ok( ! $cache->delete("foo") ); } { ok( $cache->set("foo", 1), "prep for incr" ); is( $cache->incr("foo"), 2, "incr returns 1 more than previous" ); is( $cache->decr("foo"), 1, "decr returns 1 less than previous" ); } { # test accessors foreach my $threshold (10_000, 5_000, 0) { $cache->set_compress_threshold($threshold); is( $cache->get_compress_threshold(), $threshold ); } foreach my $savings (qw(0.2 0.5 0.8)) { $cache->set_compress_savings($savings); is( $cache->get_compress_savings(), $savings ); } foreach my $enabled (0, 1, 0, 1) { $cache->set_compress_enable($enabled); is( !!$cache->get_compress_enable(), !!$enabled ); } } { # bad constructor call $cache = eval { Cache::Memcached::libmemcached->new() }; like($@, qr/No servers specified/); } { # default value in constructor $cache = libmemcached_test_create( { compress_enable => 1 } ); my $explicit = $cache->get_compress_enable; $cache = libmemcached_test_create(); my $implicit = $cache->get_compress_enable; is($explicit, $implicit); $cache = libmemcached_test_create( { compress_enable => 0, }); ok(!$cache->get_compress_enable, "check explicit compress_enable => 0"); } SKIP: { if (&Cache::Memcached::libmemcached::OPTIMIZE) { skip("OPTIMIZE flag is enabled", 1); } $cache = libmemcached_test_create( { compress_enable => 1, }); my $master_key = 'dummy_master'; my $key = 'foo_with_master'; $cache->set([ $master_key, $key ], 100); is( $cache->get([ $master_key, $key ]), 100, "get with master key" ); } Cache-Memcached-libmemcached-0.04001/t/03_compress.t000644 000766 000024 00000000542 11461531153 022164 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create( { compress_threshold => 1_000 } ); plan(tests => 2); isa_ok($cache, "Cache::Memcached::libmemcached"); { my $data = "1" x 5_000; $cache->set("foo", $data, 30); my $val = $cache->get("foo"); is($val, $data, "simple value"); }Cache-Memcached-libmemcached-0.04001/t/04_get_multi.t000644 000766 000024 00000002070 12100607646 022323 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create(); plan(tests => 9); isa_ok($cache, "Cache::Memcached::libmemcached"); { my @keys = ('a' .. 'z'); foreach my $key (@keys) { $cache->set($key, $key); } my $h = $cache->get_multi(@keys); ok($h); isa_ok($h, 'HASH'); my %expected = map { ($_ => $_) } @keys; is_deeply( $h, \%expected, "got all the expected values"); } { my $key = 'complex-get_multi'; my %data = (foo => [ qw(1 2 3) ]); $cache->set($key, \%data); my $h = $cache->get_multi($key); is_deeply($h->{$key}, \%data); } { my $cache2 = libmemcached_test_create( { namespace => "t$$" } ); isa_ok($cache, "Cache::Memcached::libmemcached"); my @keys = ('A' .. 'Z'); foreach my $key (@keys) { $cache2->set($key, $key); } my $h = $cache2->get_multi(@keys); ok($h); isa_ok($h, 'HASH'); my %expected = map { ($_ => $_) } @keys; is_deeply( $h, \%expected, "got all the expected values"); } Cache-Memcached-libmemcached-0.04001/t/05_sequence.t000644 000766 000024 00000001066 11461531153 022145 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create(); plan(tests => 22); isa_ok($cache, "Cache::Memcached::libmemcached"); { $cache->set("num", 0); for my $i (1..10) { my $num = $cache->incr("num"); is($num, $i); } } { $cache->remove("num"); ok( ! $cache->incr("num") ); } { $cache->set("num", 10); for my $i (reverse (1..9) ){ my $num = $cache->decr("num"); is($num, $i); } } { $cache->remove("num"); ok( ! $cache->decr("num") ); } Cache-Memcached-libmemcached-0.04001/t/06_flush.t000644 000766 000024 00000001021 11461531153 021446 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create(); plan(tests => 7); isa_ok($cache, "Cache::Memcached::libmemcached"); my @keys = ('a' .. 'z'); foreach my $key (@keys) { $cache->set($key, $key); } my $h = $cache->get_multi(@keys); ok($h); isa_ok($h, 'HASH'); my %expected = map { ($_ => $_) } @keys; is_deeply( $h, \%expected, "got all the expected values"); $cache->flush_all; $h = $cache->get_multi(@keys); ok($h); isa_ok($h, 'HASH'); is(scalar keys %$h, 0); Cache-Memcached-libmemcached-0.04001/t/07_add-replace.t000644 000766 000024 00000001705 11461531153 022500 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create(); plan(tests => 6); isa_ok($cache, "Cache::Memcached::libmemcached"); { $cache->set("foo", "bar"); my $val = $cache->get("foo"); is($val, "bar", "simple value"); # add() shouldn't update $cache->add("foo", "baz"); is( $cache->get("foo"), "bar", "simple value shouldn't have changed via add()"); # replace() should update $cache->replace("foo", "baz"); is( $cache->get("foo"), "baz", "simple value should have changed via replace()"); $cache->delete("foo"); # add() should update $cache->add("foo", "bar", 300); is( $cache->get("foo"), "bar", "simple value should have changed via add()"); $cache->delete("foo"); # replace() shouldn't update $cache->replace("foo", "baz"); is( $cache->get("foo"), undef, "keys that don't exist on the server shouldn't have changed via replace()"); }Cache-Memcached-libmemcached-0.04001/t/08_stats.t000644 000766 000024 00000000313 11461552710 021472 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create(); plan tests => 1; { my $h1 = $cache->stats(); ok( scalar keys %{$h1->{hosts}} > 0 ); }Cache-Memcached-libmemcached-0.04001/t/09_disconnect.t000644 000766 000024 00000000256 11461531153 022472 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create(); plan(tests => 1); { $cache->disconnect_all; ok(1); } 1;Cache-Memcached-libmemcached-0.04001/t/10_interop.t000644 000766 000024 00000001423 11461531153 022006 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; eval "use Cache::Memcached"; if ($@) { plan( skip_all => "Cache::Memcached not available" ); } my $libmemcached = libmemcached_test_create({ compress_threshold => 1_000 } ); plan (tests => 2); my $memcached = Cache::Memcached->new({ servers => [ libmemcached_test_servers() ], compress_threshold => 1_000 }); { my $data = "1" x 10_000; eval { $memcached->set("foo", $data); is( $libmemcached->get("foo"), $data, "set via Cache::Memcached, retrieve via Cache::Memcached::libmemcached"); }; eval { $libmemcached->set("foo", $data); is( $memcached->get("foo"), $data, "set via Cache::Memcached::libmemcached, retrieve via Cache::Memcached"); }; } Cache-Memcached-libmemcached-0.04001/t/11_prepend.t000644 000766 000024 00000000367 11462264776 022011 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create({ min_version => '1.2.4' }); plan tests => 1; $cache->set("foo", "abc"); $cache->prepend("foo", "0123"); is($cache->get("foo"), "0123abc"); Cache-Memcached-libmemcached-0.04001/t/12_append.t000644 000766 000024 00000000367 11462264770 021616 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create({ min_version => '1.2.4' }); plan tests => 1; $cache->set("foo", "abc"); $cache->append("foo", "0123"); is($cache->get("foo"), "abc0123"); Cache-Memcached-libmemcached-0.04001/t/13_cas.t000644 000766 000024 00000001066 11462265106 021105 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create({ min_version => '1.4.4', behavior_support_cas => 1, }); plan skip_all => "cas() unimplemented"; plan tests => 5; my @keys = ('a' .. 'z'); $cache->set($_, $_) for @keys; my $cas = $cache->get_cas('a'); ok($cas); my $h = $cache->get_cas_multi(@keys); ok($h); isa_ok($h, 'HASH'); is($h->{a}, $cas); TODO: { local $TODO = "cas() unconfirmed"; my $newvalue = 'this used to be a'; $cache->cas('a', $cas, $newvalue); is($cache->get('a'), $newvalue); } Cache-Memcached-libmemcached-0.04001/t/14_no_block.t000644 000766 000024 00000001511 11461531153 022116 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; libmemcached_test_create(); plan(tests => 8); { my $cache = libmemcached_test_create(); isa_ok($cache, "Cache::Memcached::libmemcached"); ok( ! $cache->is_no_block ); $cache->set_no_block(1); ok( $cache->is_no_block ); my $value = "non-block via accessor"; $cache->remove(__FILE__); $cache->set(__FILE__, $value); is($cache->get(__FILE__), $value); } { my $cache = libmemcached_test_create({ no_block => 1, } ); isa_ok($cache, "Cache::Memcached::libmemcached"); ok( $cache->is_no_block ); $cache->set_no_block(0); ok( !$cache->is_no_block ); my $value = "non-block via constructor"; $cache->remove(__FILE__); $cache->set(__FILE__, $value); is($cache->get(__FILE__), $value); } Cache-Memcached-libmemcached-0.04001/t/15_distribution_method.t000644 000766 000024 00000002511 11461531153 024411 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; libmemcached_test_create(); plan(tests => 8); { my $cache = libmemcached_test_create(); isa_ok($cache, "Cache::Memcached::libmemcached"); is( $cache->get_distribution_method, Memcached::libmemcached::MEMCACHED_DISTRIBUTION_MODULA ); $cache->set_distribution_method(Memcached::libmemcached::MEMCACHED_DISTRIBUTION_CONSISTENT); is( $cache->get_distribution_method, Memcached::libmemcached::MEMCACHED_DISTRIBUTION_CONSISTENT ); my $value = "non-block via accessor"; $cache->remove(__FILE__); $cache->set(__FILE__, $value); is($cache->get(__FILE__), $value); } { my $cache = libmemcached_test_create( { distribution_method => Memcached::libmemcached::MEMCACHED_DISTRIBUTION_CONSISTENT(), } ); isa_ok($cache, "Cache::Memcached::libmemcached"); is( $cache->get_distribution_method, Memcached::libmemcached::MEMCACHED_DISTRIBUTION_CONSISTENT ); $cache->set_distribution_method(Memcached::libmemcached::MEMCACHED_DISTRIBUTION_MODULA); is( $cache->get_distribution_method, Memcached::libmemcached::MEMCACHED_DISTRIBUTION_MODULA ); my $value = "non-block via constructor"; $cache->remove(__FILE__); $cache->set(__FILE__, $value); is($cache->get(__FILE__), $value); } Cache-Memcached-libmemcached-0.04001/t/16_hashing_algorithm.t000644 000766 000024 00000002352 11461531153 024025 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; libmemcached_test_create(); plan(tests => 8); { my $cache = libmemcached_test_create(); isa_ok($cache, "Cache::Memcached::libmemcached"); is( $cache->get_hashing_algorithm, Memcached::libmemcached::MEMCACHED_HASH_DEFAULT ); $cache->set_hashing_algorithm(Memcached::libmemcached::MEMCACHED_HASH_MD5); is( $cache->get_hashing_algorithm, Memcached::libmemcached::MEMCACHED_HASH_MD5 ); my $value = "non-block via accessor"; $cache->remove(__FILE__); $cache->set(__FILE__, $value); is($cache->get(__FILE__), $value); } { my $cache = libmemcached_test_create( { hashing_algorithm => Memcached::libmemcached::MEMCACHED_HASH_MD5(), } ); isa_ok($cache, "Cache::Memcached::libmemcached"); is( $cache->get_hashing_algorithm, Memcached::libmemcached::MEMCACHED_HASH_MD5 ); $cache->set_hashing_algorithm(Memcached::libmemcached::MEMCACHED_HASH_DEFAULT); is( $cache->get_hashing_algorithm, Memcached::libmemcached::MEMCACHED_HASH_DEFAULT ); my $value = "non-block via constructor"; $cache->remove(__FILE__); $cache->set(__FILE__, $value); is($cache->get(__FILE__), $value); } Cache-Memcached-libmemcached-0.04001/t/17_namespace.t000644 000766 000024 00000002726 11462262536 022307 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $namespace = "fooblabaz"; my $cache = libmemcached_test_create( { namespace => $namespace } ); my $cache_nons = libmemcached_test_create( { } ); plan(tests => 13); isa_ok($cache, "Cache::Memcached::libmemcached"); { $cache->set("foo", "bar", 300); my $val = $cache->get("foo"); is($val, "bar", "simple value"); is($cache_nons->get("${namespace}foo"), "bar", "simple value via nons"); } { $cache->set("foo", { bar => 1 }, 300); my $val = $cache->get("foo"); is_deeply($val, { bar => 1 }, "got complex values"); } { ok( $cache->get("foo"), "before delete returns ok"); ok( $cache->delete("foo") ); ok( ! $cache->get("foo"), "delete works"); ok( ! $cache->delete("foo") ); } { ok( $cache->set("foo", 1), "prep for incr" ); is( $cache->incr("foo"), 2, "incr returns 1 more than previous" ); is($cache_nons->get("${namespace}foo"), 2, "simple value via nons"); is( $cache->decr("foo"), 1, "decr returns 1 less than previous" ); } SKIP: { if (Cache::Memcached::libmemcached::OPTIMIZE) { skip("OPTIMIZE flag is enabled", 1); } $cache = libmemcached_test_create( { compress_enable => 1, namespace => "fooblabaz", }); my $master_key = 'dummy_master'; my $key = 'foo_with_master'; $cache->set([ $master_key, $key ], 100); is( $cache->get([ $master_key, $key ]), 100, "get with master key" ); } Cache-Memcached-libmemcached-0.04001/t/18_incr_decr.t000644 000766 000024 00000001243 11461531153 022266 0ustar00timbostaff000000 000000 use strict; use lib 't/lib'; use libmemcached_test; use Test::More; my $cache = libmemcached_test_create( { namespace => join('_', 'Cache::Memcached::libmemcached', 'test', rand(), $$) } ); plan(tests => 5); isa_ok($cache, "Cache::Memcached::libmemcached"); { my $key = 'foo'; { $cache->set($key, 0); is( $cache->get($key), 0, "value is 0 initially"); } { my $rv = $cache->incr($key); is( $rv, 1, "return value is $rv"); } { my $rv = $cache->incr($key); is( $rv, 2, "return value is $rv"); } { my $rv = $cache->decr($key); is( $rv, 1, "return value is $rv"); } } Cache-Memcached-libmemcached-0.04001/t/99_pod-coverage.t000644 000766 000024 00000000463 11462233707 022732 0ustar00timbostaff000000 000000 use strict; use Test::More; plan skip_all => "Enable TEST_POD environment variable to test POD" if not $ENV{TEST_POD} and not -d '.git'; plan skip_all => "Test::Pod::Coverage required for testing pod coverage" if not eval "use Test::Pod::Coverage; 1"; Test::Pod::Coverage::all_pod_coverage_ok(); Cache-Memcached-libmemcached-0.04001/t/99_pod.t000644 000766 000024 00000000422 11462233717 021135 0ustar00timbostaff000000 000000 use strict; use Test::More; plan skip_all => "Enable TEST_POD environment variable to test POD" if not $ENV{TEST_POD} and not -d '.git'; plan skip_all => "Test::Pod required for testing pod coverage" if not eval "use Test::Pod; 1"; Test::Pod::all_pod_files_ok(); Cache-Memcached-libmemcached-0.04001/t/lib/000750 000766 000024 00000000000 12211354577 020411 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/t/lib/libmemcached_test.pm000644 000766 000024 00000003451 11462543357 024416 0ustar00timbostaff000000 000000 package libmemcached_test; use strict; use warnings; use base 'Exporter'; use Cache::Memcached::libmemcached; use Test::More; our @EXPORT = qw( libmemcached_test_create libmemcached_test_key libmemcached_version_ge libmemcached_test_servers ); sub libmemcached_test_servers { my $servers = $ENV{PERL_LIBMEMCACHED_TEST_SERVERS}; # XXX add the default port as well to stop uninit # warnings from the test suite $servers ||= 'localhost:11211'; return split(/\s*,\s*/, $servers); } sub libmemcached_test_create { my ($args) = @_; my $min_version = delete $args->{min_version}; $args->{ servers } = [ libmemcached_test_servers() ]; if ($ENV{LIBMEMCACHED_BINARY_PROTOCOL}) { $args->{binary_protocol} = 1; } my $cache = Cache::Memcached::libmemcached->new($args); my $time = time(); $cache->set( foo => $time ); my $value = $cache->get( 'foo' ); plan skip_all => "Can't talk to any memcached servers" if (! defined $value || $time ne $value); plan skip_all => "memcached server version less than $min_version" if $min_version && not libmemcached_version_ge($cache, $min_version); return $cache; } sub libmemcached_version_ge { my ($memc, $min_version) = @_; my @min_version = split /\./, $min_version; my @memcached_version = $memc->memcached_version; for (0,1,2) { return 1 if $memcached_version[$_] > $min_version[$_]; return 0 if $memcached_version[$_] < $min_version[$_]; } return 1; # identical versions } sub libmemcached_test_key { # return a value suitable for use as a memcached key # that is unique for each run of the script # but returns the same value for the life of the script our $time_rand ||= ($^T + rand()); return $time_rand; } 1; Cache-Memcached-libmemcached-0.04001/lib/Cache/000750 000766 000024 00000000000 12211354577 021151 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/lib/Cache/Memcached/000750 000766 000024 00000000000 12211354577 023017 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/lib/Cache/Memcached/libmemcached.pm000644 000766 000024 00000061103 12211354305 025745 0ustar00timbostaff000000 000000 package Cache::Memcached::libmemcached; require bytes; use strict; use warnings; use Memcached::libmemcached 1.001701, qw( MEMCACHED_CALLBACK_PREFIX_KEY MEMCACHED_PREFIX_KEY_MAX_SIZE ); use base qw(Memcached::libmemcached); use Carp qw(croak carp); use Scalar::Util qw(weaken); use Storable (); our $VERSION = '0.04001'; use constant HAVE_ZLIB => eval { require Compress::Zlib } && !$@; use constant F_STORABLE => 1; use constant F_COMPRESS => 2; use constant OPTIMIZE => $ENV{PERL_LIBMEMCACHED_OPTIMIZE} ? 1 : 0; my %behavior; BEGIN { # Make sure to load bytes.pm if HAVE_ZLIB is enabled if (HAVE_ZLIB) { require bytes; } # accessors foreach my $field (qw(compress_enable compress_threshold compress_savings)) { eval sprintf(<<" EOSUB", $field, $field, $field, $field); sub set_%s { \$_[0]->{%s} = \$_[1] } sub get_%s { \$_[0]->{%s} } EOSUB die if $@; } # for Cache::Memcached compatibility sub enable_compress { shift->set_compress_enable(@_) } # XXX this should be done via subclasses if (OPTIMIZE) { # If the optimize flag is enabled, we do not support master key # generation, cause we really care about the speed. foreach my $method (qw(get set add replace prepend append cas delete)) { eval <<" EOSUB"; sub $method { shift->SUPER::memcached_${method}(\@_) } EOSUB die if $@; } } else { # Regular case. # Mental note. We only do this cause while we're faster than # Cache::Memcached::Fast, *even* when the above optimization isn't # toggled. foreach my $method (qw(get set add replace prepend append cas delete)) { eval <<" EOSUB"; sub $method { my \$self = shift; my \$key = shift; return \$self->SUPER::memcached_${method}(\$key, \@_) unless ref \$key; (my \$master_key, \$key) = @\$key; if (\$master_key) { \$self->SUPER::memcached_${method}_by_key(\$master_key, \$key, \@_); } else { \$self->SUPER::memcached_${method}(\$key, \@_); } } EOSUB die if $@; } } # Create get_*/is_*/set_* methods for some libmemcached behaviors. # We only do this for some because there are many and it's easy for # the user to use memcached_behavior_set() etc directly. # %behavior = ( # non-boolean behaviors that are renamed (to be more descriptive) distribution_method => [ 0, 'distribution' ], hashing_algorithm => [ 0, 'hash' ], # boolean behaviors that are not renamed: no_block => [ 1 ], binary_protocol => [ 1 ], ); while ( my ($method, $field_info) = each %behavior ) { my $is_bool = $field_info->[0]; my $field = $field_info->[1] || $method; my $behavior = "Memcached::libmemcached::MEMCACHED_BEHAVIOR_\U$field"; warn "$behavior doesn't exist\n" # sanity check unless do { no strict 'refs'; defined &$behavior }; my ($set, $get) = ("set_$method", "get_$method"); $get = "is_$method" if $is_bool; my $code = "sub $set { \$_[0]->memcached_behavior_set($behavior(), \$_[1]) }\n" . "sub $get { \$_[0]->memcached_behavior_get($behavior()) }"; eval $code; die "$@ while executing $code" if $@; } } sub import { my $class = shift; Memcached::libmemcached->export_to_level(1, undef, @_) ; } sub new { my $class = shift; my %args = %{ shift || {} }; my $self = $class->SUPER::new(); $self->trace_level(delete $args{debug}) if exists $args{debug}; $self->namespace(delete $args{namespace}) if exists $args{namespace}; $self->{compress_threshold} = delete $args{compress_threshold}; # Add support for Cache::Memcache::Fast's compress_ratio $self->{compress_savingsS} = delete $args{compress_savings} || 0.20; $self->{compress_enable} = exists $args{compress_enable} ? delete $args{compress_enable} : 1; # servers $args{servers} || croak "No servers specified"; $self->set_servers(delete $args{servers}); # old-style behavior options (see behavior_ block below) foreach my $option (qw(no_block hashing_algorithm distribution_method binary_protocol)) { my $behavior = $behavior{$option}->[1] || $option; $args{"behavior_$behavior"} = delete $args{$option} if exists $args{$option}; } # allow any libmemcached behavior to be set via args to new() for my $name (grep { /^behavior_/ } keys %args) { my $value = delete $args{$name}; my $behavior = "Memcached::libmemcached::MEMCACHED_\U$name"; no strict 'refs'; if (not defined &$behavior) { carp "$name ($behavior) isn't available"; # sanity check next; } $self->memcached_behavior_set(&$behavior(), $value); } delete $args{readonly}; delete $args{no_rehash}; carp "Unrecognised options: @{[ sort keys %args ]}" if %args; # Set compression/serialization callbacks $self->set_callback_coderefs( # Closures so we have reference to $self $self->_mk_callbacks() ); # behavior options foreach my $option (qw(no_block hashing_algorithm distribution_method binary_protocol)) { my $method = "set_$option"; $self->$method( $args{$option} ) if exists $args{$option}; } return $self; } sub namespace { my $self = shift; my $old_namespace = $self->memcached_callback_get(MEMCACHED_CALLBACK_PREFIX_KEY); if (@_) { my $namespace = shift; $self->memcached_callback_set(MEMCACHED_CALLBACK_PREFIX_KEY, $namespace) or carp $self->errstr; } return $old_namespace; } sub set_servers { my $self = shift; my $servers = shift || []; # $self->{servers} = []; # for compatibility with Cache::Memcached # XXX should delete any existing servers from libmemcached foreach my $server (@$servers) { $self->server_add($server); } } sub server_add { my $self = shift; my $server = shift or Carp::confess("server not specified"); my $weight = 0; if (ref $server eq 'ARRAY') { my @ary = @$server; $server = shift @ary; $weight = shift @ary || 0 if @ary; } elsif (ref $server eq 'HASH') { # Cache::Memcached::Fast my $h = $server; $server = $h->{address}; $weight = $h->{weight} if exists $h->{weight}; # noreply is not supported } if ($server =~ /^([^:]+):([^:]+)$/) { my ($hostname, $port) = ($1, $2); $self->memcached_server_add_with_weight($hostname, $port, $weight); } else { $self->memcached_server_add_unix_socket_with_weight( $server, $weight ); } # for compatibility with Cache::Memcached # push @{$self->{servers}}, $server; } sub _mk_callbacks { my $self = shift; weaken($self); my $inflate = sub { my ($key, $flags) = @_; if ($flags & F_COMPRESS) { if (! HAVE_ZLIB) { croak("Data for $key is compressed, but we have no Compress::Zlib"); } $_ = Compress::Zlib::memGunzip($_); } if ($flags & F_STORABLE) { $_ = Storable::thaw($_); } return (); }; my $deflate = sub { # Check if we have a complex structure if (ref $_) { $_ = Storable::nfreeze($_); $_[1] |= F_STORABLE; } # Check if we need compression if (HAVE_ZLIB && $self->{compress_enable} && $self->{compress_threshold}) { # Find the byte length my $length = bytes::length($_); if ($length > $self->{compress_threshold}) { my $tmp = Compress::Zlib::memGzip($_); if (bytes::length($tmp) / $length < 1 - $self->{compress_savingsS}) { $_ = $tmp; $_[1] |= F_COMPRESS; } } } return (); }; return ($deflate, $inflate); } sub incr { my $self = shift; my $key = shift; my $offset = shift || 1; my $val = 0; $self->memcached_increment($key, $offset, $val) || return undef; return $val; } sub decr { my $self = shift; my $key = shift; my $offset = shift || 1; my $val = 0; $self->memcached_decrement($key, $offset, $val) || return undef; return $val; } sub flush_all { $_[0]->memcached_flush(0); } *remove = \&delete; sub disconnect_all { $_[0]->memcached_quit(); } sub server_versions { my $self = shift; my %versions; # XXX not optimal, libmemcached knows these values without having to send a stats request $self->walk_stats('', sub { my ($key, $value, $hostport) = @_; $versions{$hostport} = $value if $key eq 'version'; return; }); return \%versions; } sub stats { my $self = shift; my ($stats_args) = @_; # http://github.com/memcached/memcached/blob/master/doc/protocol.txt $stats_args = [ $stats_args ] if $stats_args and not ref $stats_args; $stats_args ||= [ '' ]; # stats keys that aren't matched by the prefix and suffix regexes below # but which we want to accumulate in totals my %total_misc_keys = map { ($_ => 1) } qw( bytes evictions connection_structures curr_connections total_connections ); my %h; for my $type (@$stats_args) { my $code = sub { my ($key, $value, $hostport) = @_; # XXX - This is hardcoded in the callback cause r139 in perl-memcached # removed the magic of "misc" $type ||= 'misc'; $h{hosts}{$hostport}{$type}{$key} = $value; #warn "$_ ($key, $value, $hostport, $type)\n"; # accumulate overall totals for some items if ($type eq 'misc') { if ($total_misc_keys{$key} or $key =~ /^(?:cmd|bytes)_/ # prefixes or $key =~ /_(?:hits|misses|errors|yields|badval|items|read|written)$/ # suffixes ) { $h{total}{$key} += $value; } } elsif ($type eq 'malloc' or $type eq 'sizes') { $h{total}{"${type}_$key"} += $value; } return; }; $self->walk_stats($type, $code); } return \%h; } # for compatability with Cache::Memcached and Cache::Memcached::Managed 0.20: # https://rt.cpan.org/Ticket/Display.html?id=62512 # sub sock_to_host { undef } # sub get_sock { undef } # sub forget_dead_hosts { undef } 1; __END__ =head1 NAME Cache::Memcached::libmemcached - Cache interface to Memcached::libmemcached =head1 SYNOPSIS use Cache::Memcached::libmemcached; my $memd = Cache::Memcached::libmemcached->new({ servers => [ "10.0.0.15:11211", [ "10.0.0.15:11212", 2 ], # weight "/var/sock/memcached" ], compress_threshold => 10_000, # ... many more options supported }); $memd->set("my_key", "Some value"); $memd->set("object_key", { 'complex' => [ "object", 2, 4 ]}); $val = $memd->get("my_key"); $val = $memd->get("object_key"); print $val->{complex}->[2] if $val; $memd->incr("key"); $memd->decr("key"); $memd->incr("key", 2); $memd->delete("key"); $memd->remove("key"); # Alias to delete my $hashref = $memd->get_multi(@keys); # Import Memcached::libmemcached constants - explicitly by name or by tags # see Memcached::libmemcached::constants for a list use Cache::Memcached::libmemcached qw(MEMCACHED_DISTRIBUTION_CONSISTENT); use Cache::Memcached::libmemcached qw( :defines :memcached_allocated :memcached_behavior :memcached_callback :memcached_connection :memcached_hash :memcached_return :memcached_server_distribution ); my $memd = Cache::Memcached::libmemcached->new({ distribution_method => MEMCACHED_DISTRIBUTION_CONSISTENT, hashing_algorithm => MEMCACHED_HASH_FNV1A_32, behavior_... => ..., ... }); =head1 DESCRIPTION This is the Cache::Memcached compatible interface to libmemcached, a C library to interface with memcached. Cache::Memcached::libmemcached is built on top of Memcached::libmemcached. While Memcached::libmemcached aims to port libmemcached API to perl, Cache::Memcached::libmemcached attempts to be API compatible with Cache::Memcached, so it can be used as a drop-in replacement. Cache::Memcached::libmemcached I from Memcached::libmemcached. While you are free to use the Memcached::libmemcached specific methods directly on the object, doing so will mean that your code is no longer compatible with the original Cache::Memcached API therefore losing some of the portability in case you want to replace it with some other package. =head1 Cache::Memcached COMPATIBLE METHODS Except for the minor incompatiblities, below methods are compatible with Cache::Memcached. =head2 new Takes one parameter, a hashref of options. =head3 Cache::Memcached options: =head3 servers The value is passed to the L method. =head3 compress_threshold Set a compression threshold, in bytes. Values larger than this threshold will be compressed by set and decompressed by get. =head3 namespace The value is passed to the L method. =head3 debug Sets the C for the Memcached::libmemcached object. =head3 readonly, no_rehash These Cache::Memcached options are not supported. =head3 Options specific to Cache::Memcached::libmemcached: =head3 compress_savings =head3 behavior_* Any of the I behaviors documented in L can be specified by using argument key names that start with C. For example: behavior_ketama_weighted => 1, behavior_noreply => 1, behavior_number_of_replicas => 2, behavior_server_failure_limit => 3, behavior_auto_eject_hosts => 1, =head3 no_block =head3 hashing_algorithm =head3 distribution_method =head3 binary_protocol These are equivalent to the same options prefixed with C. =head2 set_servers $memd->set_servers( [ 'serv1:port1', 'serv2:port2', ... ]); Calls L for each element of the supplied arrayref. See L for details of valid values, including how to specify weights. =head2 namespace $memd->namespace; $memd->namespace($string); Without the argument return the current namespace prefix. With the argument set the namespace prefix to I<$string>, and return the old prefix. The effect is to pefix all keys with the provided namespace value. That is, if you set namespace to "app1:" and later do a set of "foo" to "bar", memcached is actually seeing you set "app1:foo" to "bar". The namespace string must be less than 128 bytes (MEMCACHED_PREFIX_KEY_MAX_SIZE). =head2 get my $val = $memd->get($key); Retrieves a key from the memcached. Returns the value (automatically thawed with Storable, if necessary) or undef. Currently the arrayref form of $key is NOT supported. Perhaps in the future. =head2 get_multi my $hashref = $memd->get_multi(@keys); Retrieves multiple keys from the memcache doing just one query. Returns a hashref of key/value pairs that were available. =head2 set $memd->set($key, $value[, $expires]); Unconditionally sets a key to a given value in the memcache. Returns true if it was stored successfully. Currently the arrayref form of $key is NOT supported. Perhaps in the future. =head2 add $memd->add($key, $value[, $expires]); Like set(), but only stores in memcache if they key doesn't already exist. =head2 replace $memd->replace($key, $value[, $expires]); Like set(), but only stores in memcache if they key already exist. =head2 append $memd->append($key, $value); Appends $value to whatever value associated with $key. Only available for memcached > 1.2.4 =head2 prepend $memd->prepend($key, $value); Prepends $value to whatever value associated with $key. Only available for memcached > 1.2.4 =head2 incr =head2 decr my $newval = $memd->incr($key); my $newval = $memd->decr($key); my $newval = $memd->incr($key, $offset); my $newval = $memd->decr($key, $offset); Atomically increments or decrements the specified the integer value specified by $key. Returns undef if the key doesn't exist on the server. =head2 delete =head2 remove $memd->delete($key); $memd->delete($key, $time); Deletes a key. If $time is non-zero then the item is marked for later expiration. Expiration works by placing the item into a delete queue, which means that it won't possible to retrieve it by the "get" command, but "add" and "replace" command with this key will also fail (the "set" command will succeed, however). After the time passes, the item is finally deleted from server memory. =head2 flush_all $memd->fush_all; Runs the memcached "flush_all" command on all configured hosts, emptying all their caches. =head2 set_compress_threshold $memd->set_compress_threshold($threshold); Set the compress threshold. =head2 enable_compress $memd->enable_compress($bool); This is actually an alias to set_compress_enable(). The original version from Cache::Memcached is, despite its naming, a setter as well. =head2 stats my $h = $memd->stats(); my $h = $memd->stats($keys); Returns a hashref of statistical data regarding the memcache server(s), the $memd object, or both. $keys can be an arrayref of keys wanted, a single key wanted, or absent (in which case the default value is C<[ '' ]>). For each key the C command is run on each server. For example C<<$memd->stats([ '', 'sizes' ])>> would return a structure like this: { hosts => { 'N.N.N.N:P' => { misc => { ... }, sizes => { ... }, }, ..., }, totals => { ... } } The general stats (where the key is "") are returned with a key of C. The C element contains the aggregate totals for all hosts of some of the statistics. =head2 disconnect_all Disconnects from servers =head2 cas $memd->cas($key, $cas, $value[, $exptime]); Overwrites data in the server as long as the "cas" value is still the same in the server. You can get the cas value of a result by calling memcached_result_cas() on a memcached_result_st(3) structure. Support for "cas" is disabled by default as there is a slight performance penalty. To enable it use the C option to L. =head1 Cache::Memcached::Fast COMPATIBLE METHODS =head2 server_versions $href = $memd->server_versions; Returns a reference to hash, where $href->{$server} holds corresponding server version string, e.g. "1.4.4". $server is either host:port or /path/to/unix.sock. =head1 Cache::Memcached::libmemcached SPECIFIC METHODS These methods are libmemcached-specific. =head2 server_add $self->server_add( $server_host_port ); # 10.10.10.10:11211 $self->server_add( $server_socket_path ); # /path/to/socket $self->server_add( [ $server, $weight ] ); $self->server_add( { address => $server, weight => $weight } ); Adds a memcached server address with an optional weight (default 0). =head1 UTILITY METHODS WARNING: Please do not consider the existance for these methods to be final. They may be renamed or may entirely disappear from future releases. =head2 get_compress_threshold Return the current value of compress_threshold =head2 set_compress_enable Set the value of compress_enable =head2 get_compress_enable Return the current value of compress_enable =head2 set_compress_savings Set the value of compress_savings =head2 get_compress_savings Return the current value of compress_savings =head1 BEHAVIOR CUSTOMIZATION Memcached::libmemcached supports I 'behaviors' that can be used to configure the behavior of the library and its interaction with the servers. Certain libmemcached behaviors can be configured with the following methods. (NOTE: This API is not fixed yet) =head2 set_no_block $memd->set_no_block( 1 ); Set to use blocking/non-blocking I/O. When this is in effect, get() becomes flaky, so don't attempt to call it. This has the most effect for set() operations, because libmemcached stops waiting for server response after writing to the socket (set() will also always return success). Please consult the man page for C for details before setting. =head2 is_no_block Get the current value of no_block behavior. =head2 set_distribution_method $memd->set_distribution_method( MEMCACHED_DISTRIBUTION_CONSISTENT ); Set the distribution behavior. =head2 get_distribution_method Get the distribution behavior. =head2 set_hashing_algorithm $memd->set_hashing_algorithm( MEMCACHED_HASH_KETAMA ); Set the hashing algorithm used. =head2 get_hashing_algorithm Get the hashing algorithm used. =head2 set_binary_protocol =head2 is_binary_protocol $memd->set_binary_protocol( 1 ); $binary = $memd->is_binary_protocol(); Use C to enable/disable binary protocol. Use C to determine the current setting. =head1 OPTIMIZE FLAG If you are 100% sure that you won't be using the master key support (where you provide an arrayref as the key) you can get about 4~5% performance boost by setting the environment variable named PERL_LIBMEMCACHED_OPTIMIZE to a true value I loading the module. This is an EXPERIMENTAL optimization and will possibly be replaced by implementing the methods in C in Memcached::libmemcached. =head1 VARIOUS MEMCACHED MODULES Below are the various memcached modules available on CPAN. Please check tool/benchmark.pl for a live comparison of these modules. (except for Cache::Memcached::XS, which I wasn't able to compile under my main dev environment) =head2 Cache::Memcached This is the "original" module. It's mostly written in Perl, is slow, and lacks significant features like support for the binary protocol. =head2 Cache::Memcached::libmemcached Cache::Memcached::libmemcached, this module, is a perl binding for libmemcached (http://tangent.org/552/libmemcached.html). Not to be confused with libmemcache (see below). =head2 Cache::Memcached::Fast Cache::Memcached::Fast is a memcached client written in XS from scratch. As of this writing benchmarks shows that Cache::Memcached::Fast is faster on get_multi(), and Cache::Memcached::libmemcached is faster on regular get()/set(). Cache::Memcached::Fast doesn't support the binary protocol. =head2 Memcached::libmemcached Memcached::libmemcached is a thin binding to the libmemcached C library and provides access to most of the libmemcached API. If you don't care about a drop-in replacement for Cache::Memcached, and want to benefit from the feature-rich efficient API that libmemcached offers, this is the way to go. Since the Memcached::libmemcached module is also the parent class of this module you can call Memcached::libmemcached methods directly. =head2 Cache::Memcached::XS Cache::Memcached::XS is a binding for libmemcache (http://people.freebsd.org/~seanc/libmemcache/). The main memcached site at http://danga.com/memcached/apis.bml seems to indicate that the underlying libmemcache is no longer in active development. The module hasn't been updated since 2006. =head1 TODO Check and improve compatibility with Cache::Memcached::Fast. Add forget_dead_hosts() for greater Cache::Memcached compatibility? Treat PERL_LIBMEMCACHED_OPTIMIZE as the default and add a subclass that handles the arrayref master key concept. Then the custom methods (get set add replace prepend append cas delete) can then all be removed and the libmemcached ones used directly. Alternatively, add master key via array ref support to the methods in ::libmemcached. Either way the effect on performance should be significant. Redo tools/benchmarks.pl performance tests (ensuring that methods are not called in void context unless it's appropriate). Try using Cache::Memcached::Fast's test suite to test this module. Via private lib/Cache/Memcached/libmemcachedAsFast.pm wrapper. Implement automatic no-reply on calls in void context (like Cache::Memcached::Fast). That should yield a signigicant performance boost. =head1 AUTHOR Copyright (c) 2008 Daisuke Maki Edaisuke@endeworks.jpE With contributions by Tim Bunce. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Cache-Memcached-libmemcached-0.04001/inc/Module/000750 000766 000024 00000000000 12211354577 021376 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/inc/Test/000750 000766 000024 00000000000 12211354577 021070 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/inc/Test/More.pm000644 000766 000024 00000041061 11462543410 022330 0ustar00timbostaff000000 000000 #line 1 package Test::More; use 5.006; use strict; use warnings; #---- perlcritic exemptions. ----# # We use a lot of subroutine prototypes ## no critic (Subroutines::ProhibitSubroutinePrototypes) # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my( $file, $line ) = ( caller(1) )[ 1, 2 ]; return warn @_, " at $file line $line\n"; } our $VERSION = '0.94'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan done_testing can_ok isa_ok new_ok diag note explain subtest BAIL_OUT ); #line 164 sub plan { my $tb = Test::More->builder; return $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } else { push @other, $item; } $idx++; } @$list = @other; return; } #line 217 sub done_testing { my $tb = Test::More->builder; $tb->done_testing(@_); } #line 289 sub ok ($;$) { my( $test, $name ) = @_; my $tb = Test::More->builder; return $tb->ok( $test, $name ); } #line 367 sub is ($$;$) { my $tb = Test::More->builder; return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; return $tb->isnt_eq(@_); } *isn't = \&isnt; #line 411 sub like ($$;$) { my $tb = Test::More->builder; return $tb->like(@_); } #line 426 sub unlike ($$;$) { my $tb = Test::More->builder; return $tb->unlike(@_); } #line 471 sub cmp_ok($$$;$) { my $tb = Test::More->builder; return $tb->cmp_ok(@_); } #line 506 sub can_ok ($@) { my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless(@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } my $name = (@methods == 1) ? "$class->can('$methods[0]')" : "$class->can(...)" ; my $ok = $tb->ok( !@nok, $name ); $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } #line 572 sub isa_ok ($$;$) { my( $object, $class, $obj_name ) = @_; my $tb = Test::More->builder; my $diag; if( !defined $object ) { $obj_name = 'The thing' unless defined $obj_name; $diag = "$obj_name isn't defined"; } else { my $whatami = ref $object ? 'object' : 'class'; # We can't use UNIVERSAL::isa because we want to honor isa() overrides my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); if($error) { if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { # Its an unblessed reference $obj_name = 'The reference' unless defined $obj_name; if( !UNIVERSAL::isa( $object, $class ) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } elsif( $error =~ /Can't call method "isa" without a package/ ) { # It's something that can't even be a class $obj_name = 'The thing' unless defined $obj_name; $diag = "$obj_name isn't a class or reference"; } else { die <isa on your $whatami and got some weird error. Here's the error. $error WHOA } } else { $obj_name = "The $whatami" unless defined $obj_name; if( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } } my $name = "$obj_name isa $class"; my $ok; if($diag) { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } else { $ok = $tb->ok( 1, $name ); } return $ok; } #line 651 sub new_ok { my $tb = Test::More->builder; $tb->croak("new_ok() must be given at least a class") unless @_; my( $class, $args, $object_name ) = @_; $args ||= []; $object_name = "The object" unless defined $object_name; my $obj; my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); if($success) { local $Test::Builder::Level = $Test::Builder::Level + 1; isa_ok $obj, $class, $object_name; } else { $tb->ok( 0, "new() died" ); $tb->diag(" Error was: $error"); } return $obj; } #line 719 sub subtest($&) { my ($name, $subtests) = @_; my $tb = Test::More->builder; return $tb->subtest(@_); } #line 743 sub pass (;$) { my $tb = Test::More->builder; return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; return $tb->ok( 0, @_ ); } #line 806 sub use_ok ($;@) { my( $module, @imports ) = @_; @imports = () unless @imports; my $tb = Test::More->builder; my( $pack, $filename, $line ) = caller; my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. $code = <ok( $eval_result, "use $module;" ); unless($ok) { chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(<builder; my $pack = caller; # Try to deterine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); my $code = <ok( $eval_result, "require $module;" ); unless($ok) { chomp $eval_error; $tb->diag(<builder; unless( @_ == 2 or @_ == 3 ) { my $msg = <<'WARNING'; is_deeply() takes two or three args, you gave %d. This usually means you passed an array or hash instead of a reference to it WARNING chop $msg; # clip off newline so carp() will put in line/file _carp sprintf $msg, scalar @_; return $tb->ok(0); } my( $got, $expected, $name ) = @_; $tb->_unoverload_str( \$expected, \$got ); my $ok; if( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq( $got, $expected, $name ); } elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } else { # both references local @Data_Stack = (); if( _deep_check( $got, $expected ) ) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack(@Data_Stack) ); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars = (); ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : _dne($val) ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { return $type if UNIVERSAL::isa( $thing, $type ); } return ''; } #line 1112 sub diag { return Test::More->builder->diag(@_); } sub note { return Test::More->builder->note(@_); } #line 1138 sub explain { return Test::More->builder->explain(@_); } #line 1204 ## no critic (Subroutines::RequireFinalReturn) sub skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } if( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for( 1 .. $how_many ) { $tb->skip($why); } no warnings 'exiting'; last SKIP; } #line 1288 sub todo_skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1 .. $how_many ) { $tb->todo_skip($why); } no warnings 'exiting'; last TODO; } #line 1343 sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } #line 1382 #'# sub eq_array { local @Data_Stack = (); _deep_check(@_); } sub _eq_array { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for( 0 .. $max ) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { # Quiet uninitialized value warnings when comparing undefs. no warnings 'uninitialized'; $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. my $same_ref = !( !ref $e1 xor !ref $e2 ); my $not_ref = ( !ref $e1 and !ref $e2 ); if( defined $e1 xor defined $e2 ) { $ok = 0; } elsif( !defined $e1 and !defined $e2 ) { # Shortcut if they're both defined. $ok = 1; } elsif( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif( $same_ref and( $e1 eq $e2 ) ) { $ok = 1; } elsif($not_ref) { push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; $ok = 0; } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { $ok = _eq_array( $e1, $e2 ); } elsif( $type eq 'HASH' ) { $ok = _eq_hash( $e1, $e2 ); } elsif( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif($type) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } else { _whoa( 1, "No type in _deep_check" ); } } } return $ok; } sub _whoa { my( $check, $desc ) = @_; if($check) { die <<"WHOA"; WHOA! $desc This should never happen! Please contact the author immediately! WHOA } } #line 1515 sub eq_hash { local @Data_Stack = (); return _deep_check(@_); } sub _eq_hash { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k ( keys %$bigger ) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } #line 1572 sub eq_set { my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; no warnings 'uninitialized'; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } #line 1774 1; Cache-Memcached-libmemcached-0.04001/inc/Module/Install/000750 000766 000024 00000000000 12211354577 023004 5ustar00timbostaff000000 000000 Cache-Memcached-libmemcached-0.04001/inc/Module/Install.pm000644 000766 000024 00000030135 11462543410 023342 0ustar00timbostaff000000 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.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.00'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # 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 - 2010 Adam Kennedy. Cache-Memcached-libmemcached-0.04001/inc/Module/Install/Base.pm000644 000766 000024 00000002147 11462543410 024216 0ustar00timbostaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # 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 Cache-Memcached-libmemcached-0.04001/inc/Module/Install/Can.pm000644 000766 000024 00000003333 11462543411 024044 0ustar00timbostaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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 ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Cache-Memcached-libmemcached-0.04001/inc/Module/Install/Fetch.pm000644 000766 000024 00000004627 11462543411 024403 0ustar00timbostaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Cache-Memcached-libmemcached-0.04001/inc/Module/Install/Include.pm000644 000766 000024 00000001015 11462543410 024720 0ustar00timbostaff000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Cache-Memcached-libmemcached-0.04001/inc/Module/Install/Makefile.pm000644 000766 000024 00000027032 11462543410 025061 0ustar00timbostaff000000 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.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } 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.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # 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 $DB::single = 1; 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 541 Cache-Memcached-libmemcached-0.04001/inc/Module/Install/Metadata.pm000644 000766 000024 00000043020 11462543410 025057 0ustar00timbostaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } 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 reall 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' => '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<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://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+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Cache-Memcached-libmemcached-0.04001/inc/Module/Install/Win32.pm000644 000766 000024 00000003403 11462543411 024243 0ustar00timbostaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Cache-Memcached-libmemcached-0.04001/inc/Module/Install/WriteAll.pm000644 000766 000024 00000002376 11462543411 025074 0ustar00timbostaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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;