Catalyst-Plugin-Cache-0.12/000755 000765 000024 00000000000 12112674363 015325 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/.gitignore000644 000765 000024 00000000154 12112674152 017311 0ustar00t0mstaff000000 000000 MANIFEST.bak Catalyst-Plugin-Cache* MANIFEST META.yml MYMETA.json MYMETA.yml Makefile blib/ inc/ pm_to_blib Catalyst-Plugin-Cache-0.12/Changes000644 000765 000024 00000003117 12112674254 016621 0ustar00t0mstaff000000 000000 0.12 - Remove .git from MANIFEST. RT#78058 0.11 - Convert repository to git (fREW Schmidt) - Depend on Catalyst 5.8 and so lose un-declared dependencies on Class::Data::Inheritable and Class::Accessor::Fast. RT#74972 0.10 - Change to Module::Install - Drop test dep on ok - Split requires and test_requires - Fix bug when used in conjunction with ::Model::DBIC::Schema Caching trait by not trying to cache the curried cache instance when we don't have a request instance to cache it against 0.09 - Generate a warning if no config is specified, or config is specified using the old key. - Support the compute() method, and emulate it if the backend doesn't have it. 0.08 - Forgot to add MRO::Compat to Makefile.PL, fail. 0.07 - Switch from NEXT to MRO::Compat. - Change config key from 'cache' to 'Plugin::Cache', old key is still supported for backwards compatibility, but the new key is preferred (RT#40344). 0.06 - clarify the documentation on how to configure a backend - due to stacked evals, certain start up errors were quietly ignored until the first cache hit. These start up errors now correctly manifest themselves at start up time. 0.05 - change base class order to appease Class::C3 0.04 - ??? 0.03 - Be more compatible with ->set() convention of passing expiry 0.02 - Pass around a hash ref instead of a list of kvp. 0.01 - Initial release Catalyst-Plugin-Cache-0.12/inc/000755 000765 000024 00000000000 12112674363 016076 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/lib/000755 000765 000024 00000000000 12112674363 016073 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/Makefile.PL000644 000765 000024 00000000760 11727747552 017316 0ustar00t0mstaff000000 000000 use inc::Module::Install; name 'Catalyst-Plugin-Cache'; all_from 'lib/Catalyst/Plugin/Cache.pm'; requires 'Catalyst' => '5.8'; requires 'Storable' => 0; requires 'Task::Weaken' => 0; test_requires 'Test::Deep' => 0; test_requires 'Test::Exception' => 0; test_requires 'Test::More' => '0.88'; requires 'MRO::Compat' => 0; resources repository => 'git://git.shadowcat.co.uk/catagits/Catalyst-Plugin-Cache.git'; WriteAll; Catalyst-Plugin-Cache-0.12/MANIFEST000644 000765 000024 00000001364 12112674350 016456 0ustar00t0mstaff000000 000000 .gitignore Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Catalyst/Plugin/Cache.pm lib/Catalyst/Plugin/Cache/Backend.pm lib/Catalyst/Plugin/Cache/Backend/Memory.pm lib/Catalyst/Plugin/Cache/Choose/KeyRegexes.pm lib/Catalyst/Plugin/Cache/Curried.pm lib/Catalyst/Plugin/Cache/Store.pod lib/Catalyst/Plugin/Cache/Store/Memory.pm Makefile.PL MANIFEST This list of files META.yml MYMETA.json MYMETA.yml t/basic.t t/config_backend_class.t t/config_guess_backend.t t/currying_conf.t t/key_regexes.t t/lib/CacheTestApp.pm t/lib/CacheTestApp/Controller/Root.pm t/live_app.t Catalyst-Plugin-Cache-0.12/META.yml000644 000765 000024 00000001340 12112674345 016574 0ustar00t0mstaff000000 000000 --- abstract: 'Flexible caching support for Catalyst.' author: - 'Yuval Kogman, C' build_requires: ExtUtils::MakeMaker: 6.36 Test::Deep: 0 Test::Exception: 0 Test::More: 0.88 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Catalyst-Plugin-Cache no_index: directory: - inc - t requires: Catalyst: 5.8 MRO::Compat: 0 Storable: 0 Task::Weaken: 0 resources: license: http://dev.perl.org/licenses/ repository: git://git.shadowcat.co.uk/catagits/Catalyst-Plugin-Cache.git version: 0.12 Catalyst-Plugin-Cache-0.12/MYMETA.json000644 000765 000024 00000002441 12112674361 017213 0ustar00t0mstaff000000 000000 { "abstract" : "Flexible caching support for Catalyst.", "author" : [ "Yuval Kogman, C" ], "dynamic_config" : 0, "generated_by" : "Module::Install version 1.06, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Catalyst-Plugin-Cache", "no_index" : { "directory" : [ "inc", "t" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.36", "Test::Deep" : "0", "Test::Exception" : "0", "Test::More" : "0.88" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.36" } }, "runtime" : { "requires" : { "Catalyst" : "5.8", "MRO::Compat" : "0", "Storable" : "0", "Task::Weaken" : "0" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "git://git.shadowcat.co.uk/catagits/Catalyst-Plugin-Cache.git" } }, "version" : "0.12" } Catalyst-Plugin-Cache-0.12/MYMETA.yml000644 000765 000024 00000001356 12112674345 017051 0ustar00t0mstaff000000 000000 --- abstract: 'Flexible caching support for Catalyst.' author: - 'Yuval Kogman, C' build_requires: ExtUtils::MakeMaker: 6.36 Test::Deep: 0 Test::Exception: 0 Test::More: 0.88 configure_requires: ExtUtils::MakeMaker: 6.36 dynamic_config: 0 generated_by: 'Module::Install version 1.06, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Catalyst-Plugin-Cache no_index: directory: - inc - t requires: Catalyst: 5.8 MRO::Compat: 0 Storable: 0 Task::Weaken: 0 resources: license: http://dev.perl.org/licenses/ repository: git://git.shadowcat.co.uk/catagits/Catalyst-Plugin-Cache.git version: 0.12 Catalyst-Plugin-Cache-0.12/t/000755 000765 000024 00000000000 12112674363 015570 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/t/basic.t000644 000765 000024 00000006213 11727747517 017055 0ustar00t0mstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; use Test::Exception; use_ok "Catalyst::Plugin::Cache"; use Catalyst::Plugin::Cache::Backend::Memory; { package MockApp; use base qw/Catalyst::Plugin::Cache/; sub registered_plugins {} ### must register a backend class as of 0.06 ### the previous code simply ignored a croak ### this is still in line with the documentation. my %config = ( 'Plugin::Cache' => { backend => { class => 'Catalyst::Plugin::Cache::Backend::Memory', } } ); sub config { \%config }; } MockApp->setup; my $c = bless {}, "MockApp"; can_ok( $c, "register_cache_backend" ); can_ok( $c, "unregister_cache_backend" ); MockApp->register_cache_backend( default => Catalyst::Plugin::Cache::Backend::Memory->new ); MockApp->register_cache_backend( moose => Catalyst::Plugin::Cache::Backend::Memory->new ); can_ok( $c, "cache" ); ok( $c->cache, "->cache returns a value" ); can_ok( $c->cache, "get" ); #, "rv from cache" ); can_ok( $c->cache("default"), "get" ); #, "default backend" ); can_ok( $c->cache("moose"), "get" ); #, "moose backend" ); ok( !$c->cache("lalalala"), "no lalala backend"); MockApp->unregister_cache_backend( "moose" ); ok( !$c->cache("moose"), "moose backend unregistered"); dies_ok { MockApp->register_cache_backend( ding => undef ); } "can't register invalid backend"; dies_ok { MockApp->register_cache_backend( ding => bless {}, "SomeClass" ); } "can't register invalid backend"; can_ok( $c, "default_cache_backend" ); can_ok( $c, "choose_cache_backend_wrapper" ); can_ok( $c, "choose_cache_backend" ); can_ok( $c, "cache_set" ); can_ok( $c, "cache_get" ); can_ok( $c, "cache_remove" ); $c->cache_set( foo => "bar" ); is( $c->cache_get("foo"), "bar", "set" ); $c->cache_remove( "foo" ); is( $c->cache_get("foo"), undef, "remove" ); MockApp->register_cache_backend( elk => Catalyst::Plugin::Cache::Backend::Memory->new ); is( $c->choose_cache_backend_wrapper( key => "foo" ), $c->default_cache_backend, "choose default" ); is( $c->choose_cache_backend_wrapper( key => "foo", backend => "elk" ), $c->get_cache_backend("elk"), "override choice" ); $c->cache_set( foo => "gorch", backend => "elk" ); is( $c->cache_get("foo"), undef, "set to custom backend (get from non custom)" ); is( $c->cache_get("foo", backend => "elk"), "gorch", "set to custom backend (get from custom)" ); my $cache_elk = $c->cache( backend => "elk" ); my $cache_norm = $c->cache(); is( $cache_norm->get("foo"), undef, "default curried cache has no foo"); is( $cache_elk->get("foo"), "gorch", "curried custom backend has foo" ); is( $c->cache->get('compute_test'), undef, 'compute_test key is undef by default' ); is( $c->cache->compute('compute_test',sub{'monkey'}), 'monkey', 'compute returned code value' ); is( $c->cache->get('compute_test'), 'monkey', 'compute_test key is now set' ); is( $c->cache->compute('compute_test',sub{'donkey'}), 'monkey', 'compute returned cached value' ); $c->cache->remove('compute_test'); is( $c->cache->compute('compute_test',sub{'donkey'}), 'donkey', 'compute returned second code value' ); Catalyst-Plugin-Cache-0.12/t/config_backend_class.t000644 000765 000024 00000001237 11727747517 022076 0ustar00t0mstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use_ok "Catalyst::Plugin::Cache"; { package MockApp; use base qw/Catalyst::Plugin::Cache/; package MyCache; sub new { my ( $class, $p ) = @_; die unless ref $p; bless { %$p }, $class; } sub get {} sub set {} sub remove {} } MockApp->_cache_backends({}); MockApp->setup_generic_cache_backend( "foo", { class => "MyCache", param => "foo", }); my $registered = MockApp->get_cache_backend( "foo" ); ok( $registered, "registered a backend" ); is_deeply( $registered, MyCache->new({ param => "foo" }), "params sent correctly" ); done_testing; Catalyst-Plugin-Cache-0.12/t/config_guess_backend.t000644 000765 000024 00000002045 11727747517 022115 0ustar00t0mstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; use Test::Exception; { package ManyStores; use base qw/Catalyst::Plugin::Cache/; sub registered_plugins { qw/ Bar Cache Cache::Store::Foo Cache::Store::Bar MyApp::Plugin::Cache::Store::Moose Cheese /; } package OneStore; use base qw/Catalyst::Plugin::Cache/; sub registered_plugins { qw/ Aplugin Cache Cache::Store::Foo / } package NoStores; use base qw/Catalyst::Plugin::Cache/; sub registered_plugins { qw/ Bar Cache Lala / } } # store guessing lives_ok { OneStore->guess_default_cache_store } "can guess if only one plugin"; is( OneStore->guess_default_cache_store, "Foo", "guess is right" ); dies_ok { ManyStores->guess_default_cache_store } "can't guess if many"; dies_ok { NoStores->guess_default_cache_store } "can't guess if none"; Catalyst-Plugin-Cache-0.12/t/currying_conf.t000644 000765 000024 00000002663 11727747517 020650 0ustar00t0mstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Deep qw/superhashof cmp_deeply/; use Scalar::Util qw/refaddr/; use_ok "Catalyst::Plugin::Cache"; { package MockApp; use base qw/Catalyst::Plugin::Cache/; my %config = ( 'Plugin::Cache' => { profiles => { foo => { bah => "foo", }, bar => bless( {}, "SomeClass" ), }, ### as of 0.06, we need a specific backend ### specified backend => { class => 'SomeClass', } }, ); sub config { \%config }; package SomeClass; ### backend must have a constructor sub new { bless {}, shift }; sub get {} sub set {} sub remove {} } MockApp->setup; my $c = bless {}, "MockApp"; MockApp->register_cache_backend( default => bless({}, "SomeClass") ); can_ok( $c, "curry_cache" ); can_ok( $c, "get_preset_curried" ); isa_ok( $c->cache, "Catalyst::Plugin::Cache::Curried" ); is( refaddr($c->cache), refaddr($c->cache), "default cache is memoized, so it is =="); isa_ok( $c->cache("foo"), "Catalyst::Plugin::Cache::Curried", "cache('foo')" ); cmp_deeply( { @{ $c->cache("foo")->meta } }, superhashof({ bah => "foo" }), "meta is in place" ); is( refaddr( $c->cache("bar") ), refaddr( $c->cache("bar") ), "since bar is hard coded as an object it's always the same" ); done_testing; Catalyst-Plugin-Cache-0.12/t/key_regexes.t000644 000765 000024 00000004226 11727747517 020310 0ustar00t0mstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use_ok "Catalyst::Plugin::Cache"; use_ok "Catalyst::Plugin::Cache::Choose::KeyRegexes"; use Catalyst::Plugin::Cache::Backend::Memory; { package MockApp; use base qw/Catalyst::Plugin::Cache Catalyst::Plugin::Cache::Choose::KeyRegexes/; our %config = ( 'Plugin::Cache' => { key_regexes => [ qr/^foo/ => "foo_store", qr/^bar/ => "bar_store", ], ### as of 0.06, you must specify a backend backend => { class => 'Catalyst::Plugin::Cache::Backend::Memory', } }, ); sub config { \%config } } MockApp->setup; my $c = bless {}, "MockApp"; MockApp->register_cache_backend( default => Catalyst::Plugin::Cache::Backend::Memory->new ); MockApp->register_cache_backend( foo_store => Catalyst::Plugin::Cache::Backend::Memory->new ); MockApp->register_cache_backend( bar_store => Catalyst::Plugin::Cache::Backend::Memory->new ); is( $c->choose_cache_backend_wrapper( key => "baz" ), $c->default_cache_backend, "chose default" ); is( $c->choose_cache_backend_wrapper( key => "foo" ), $c->get_cache_backend("foo_store"), "chose foo" ); is( $c->choose_cache_backend_wrapper( key => "bar" ), $c->get_cache_backend("bar_store"), "chose bar" ); $c->cache_set( foo_laa => "laa" ); $c->cache_set( bar_laa => "laa" ); $c->cache_set( baz_laa => "laa" ); is( $c->default_cache_backend->get("baz_laa"), "laa", "non match stored in default" ); is( $c->default_cache_backend->get("foo_laa"), undef, "no foo key" ); is( $c->default_cache_backend->get("bar_laa"), undef, "no bar key" ); is( $c->get_cache_backend("foo_store")->get("baz_laa"), undef, "no non match in foo store" ); is( $c->get_cache_backend("foo_store")->get("foo_laa"), "laa", "has foo key" ); is( $c->get_cache_backend("foo_store")->get("bar_laa"), undef, "no bar key" ); is( $c->get_cache_backend("bar_store")->get("baz_laa"), undef, "no non match in bar store" ); is( $c->get_cache_backend("bar_store")->get("foo_laa"), undef, "no foo key" ); is( $c->get_cache_backend("bar_store")->get("bar_laa"), "laa", "has bar key" ); done_testing; Catalyst-Plugin-Cache-0.12/t/lib/000755 000765 000024 00000000000 12112674363 016336 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/t/live_app.t000644 000765 000024 00000001012 11727747517 017563 0ustar00t0mstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval { require Test::WWW::Mechanize::Catalyst } or plan skip_all => "Test::WWW::Mechanize::Catalyst is required for this test"; plan tests => 5; } use lib "t/lib"; use Test::WWW::Mechanize::Catalyst "CacheTestApp"; my $ua = Test::WWW::Mechanize::Catalyst->new; $ua->get_ok("http://localhost/bar"); $ua->content_is("not found"); $ua->get_ok("http://localhost//foo"); $ua->get_ok("http://localhost/bar"); $ua->content_is("Foo"); Catalyst-Plugin-Cache-0.12/t/lib/CacheTestApp/000755 000765 000024 00000000000 12112674363 020642 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/t/lib/CacheTestApp.pm000644 000765 000024 00000000246 11727747517 021217 0ustar00t0mstaff000000 000000 #!/usr/bin/perl package CacheTestApp; use strict; use warnings; use Catalyst qw/ Cache Cache::Store::Memory /; __PACKAGE__->setup; __PACKAGE__; __END__ Catalyst-Plugin-Cache-0.12/t/lib/CacheTestApp/Controller/000755 000765 000024 00000000000 12112674363 022765 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/t/lib/CacheTestApp/Controller/Root.pm000644 000765 000024 00000000572 11727747517 024267 0ustar00t0mstaff000000 000000 #!/usr/bin/perl package CacheTestApp::Controller::Root; use base qw/Catalyst::Controller/; use strict; use warnings; __PACKAGE__->config( namespace => "" ); sub foo : Local { my ( $self, $c ) = @_; $c->cache->set( foo => "Foo" ); } sub bar : Local { my ( $self, $c ) = @_; $c->res->body( $c->cache->get( "foo" ) || "not found" ); } __PACKAGE__; __END__ Catalyst-Plugin-Cache-0.12/lib/Catalyst/000755 000765 000024 00000000000 12112674363 017657 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/000755 000765 000024 00000000000 12112674363 021115 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/000755 000765 000024 00000000000 12112674363 022120 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache.pm000644 000765 000024 00000045120 12112674256 022461 0ustar00t0mstaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Cache; use Moose; with 'Catalyst::ClassData'; our $VERSION = "0.12"; use Scalar::Util (); use Catalyst::Utils (); use Carp (); use MRO::Compat; use Scalar::Util qw/ blessed /; use Catalyst::Plugin::Cache::Curried; __PACKAGE__->mk_classdata( "_cache_backends" ); has _default_curried_cache => ( is => 'rw', ); no Moose; sub setup { my $app = shift; # set it once per app, not once per plugin, # and don't overwrite if some plugin was wicked $app->_cache_backends({}) unless $app->_cache_backends; my $ret = $app->maybe::next::method( @_ ); $app->setup_cache_backends; $ret; } { my %has_warned_for; sub _get_cache_plugin_config { my ($app) = @_; my $config = $app->config->{'Plugin::Cache'}; if (!$config) { $config = $app->config->{cache}; my $appname = ref($app); if (! $has_warned_for{$appname}++ ) { $app->log->warn($config ? 'Catalyst::Plugin::Cache config found in deprecated $c->config->{cache}, please move to $c->config->{"Plugin::Cache"}.' : 'Catalyst::Plugin::Cache config not found, using empty config!' ); } } return $config || {}; } } sub get_default_cache_backend_config { my ( $app, $name ) = @_; $app->_get_cache_plugin_config->{backend} || $app->get_cache_backend_config("default"); } sub get_cache_backend_config { my ( $app, $name ) = @_; $app->_get_cache_plugin_config->{backends}{$name}; } sub setup_cache_backends { my $app = shift; # give plugins a chance to find things for themselves $app->maybe::next::method; # FIXME - Don't know why the _get_cache_plugin_config method doesn't work here! my $conf = $app->_get_cache_plugin_config->{backends}; foreach my $name ( keys %$conf ) { next if $app->get_cache_backend( $name ); $app->setup_generic_cache_backend( $name, $app->get_cache_backend_config( $name ) || {} ); } if ( !$app->get_cache_backend("default") ) { ### XXX currently we dont have a fallback scenario ### so die here with the error message. Once we have ### an in memory fallback, we may consider silently ### logging the error and falling back to that. ### If we dont die here, the app will silently start ### up and then explode at the first cache->get or ### cache->set request with a FIXME error #local $@; #eval { $app->setup_generic_cache_backend( default => $app->get_default_cache_backend_config || {} ); #}; } } sub default_cache_store { my $app = shift; $app->_get_cache_plugin_config->{default_store} || $app->guess_default_cache_store; } sub guess_default_cache_store { my $app = shift; my @stores = map { /Cache::Store::(.*)$/ ? $1 : () } $app->registered_plugins; if ( @stores == 1 ) { return $stores[0]; } else { Carp::croak "You must configure a default store type unless you use exactly one store plugin."; } } sub setup_generic_cache_backend { my ( $app, $name, $config ) = @_; my %config = %$config; if ( my $class = delete $config{class} ) { ### try as list and as hashref, collect the ### error if things go wrong ### if all goes well, exit the loop my @errors; for my $aref ( [%config], [\%config] ) { eval { $app->setup_cache_backend_by_class( $name, $class, @$aref ); } ? do { @errors = (); last } : push @errors, "\t$@"; } ### and die with the errors if we have any die "Couldn't construct $class with either list style or hash ref style param passing:\n @errors" if @errors; } elsif ( my $store = delete $config->{store} || $app->default_cache_store ) { my $method = lc("setup_${store}_cache_backend"); Carp::croak "You must load the $store cache store plugin (if it exists). ". "Please consult the Catalyst::Plugin::Cache documentation on how to configure hetrogeneous stores." unless $app->can($method); $app->$method( $name, \%config ); } else { $app->log->warn("Couldn't setup the cache backend named '$name'"); } } sub setup_cache_backend_by_class { my ( $app, $name, $class, @args ) = @_; Catalyst::Utils::ensure_class_loaded( $class ); $app->register_cache_backend( $name => $class->new( @args ) ); } # end of spaghetti setup DWIM sub cache { my ( $c, @meta ) = @_; if ( @meta == 1 ) { my $name = $meta[0]; return ( $c->get_preset_curried($name) || $c->get_cache_backend($name) ); } elsif ( !@meta && blessed $c ) { # be nice and always return the same one for the simplest case return ( $c->_default_curried_cache || $c->_default_curried_cache( $c->curry_cache( @meta ) ) ); } else { return $c->curry_cache( @meta ); } } sub construct_curried_cache { my ( $c, @meta ) = @_; return $c->curried_cache_class( @meta )->new( @meta ); } sub curried_cache_class { my ( $c, @meta ) = @_; $c->_get_cache_plugin_config->{curried_class} || "Catalyst::Plugin::Cache::Curried"; } sub curry_cache { my ( $c, @meta ) = @_; return $c->construct_curried_cache( $c, $c->_cache_caller_meta, @meta ); } sub get_preset_curried { my ( $c, $name ) = @_; if ( ref( my $preset = $c->_get_cache_plugin_config->{profiles}{$name} ) ) { return $preset if Scalar::Util::blessed($preset); my @meta = ( ( ref $preset eq "HASH" ) ? %$preset : @$preset ); return $c->curry_cache( @meta ); } return; } sub get_cache_backend { my ( $c, $name ) = @_; $c->_cache_backends->{$name}; } sub register_cache_backend { my ( $c, $name, $backend ) = @_; no warnings 'uninitialized'; Carp::croak("$backend does not look like a cache backend - " . "it must be an object supporting get, set and remove") unless eval { $backend->can("get") && $backend->can("set") && $backend->can("remove") }; $c->_cache_backends->{$name} = $backend; } sub unregister_cache_backend { my ( $c, $name ) = @_; delete $c->_cache_backends->{$name}; } sub default_cache_backend { my $c = shift; $c->get_cache_backend( "default" ) || $c->temporary_cache_backend; } sub temporary_cache_backend { my $c = shift; die "FIXME - make up an in memory cache backend, that hopefully works well for the current engine"; } sub _cache_caller_meta { my $c = shift; my ( $caller, $component, $controller ); for my $i ( 0 .. 15 ) { # don't look to far my @info = caller(2 + $i) or last; $caller ||= \@info unless $info[0] =~ /Plugin::Cache/; $component ||= \@info if $info[0]->isa("Catalyst::Component"); $controller ||= \@info if $info[0]->isa("Catalyst::Controller"); last if $caller && $component && $controller; } my ( $caller_pkg, $component_pkg, $controller_pkg ) = map { $_ ? $_->[0] : undef } $caller, $component, $controller; return ( 'caller' => $caller_pkg, component => $component_pkg, controller => $controller_pkg, caller_frame => $caller, component_frame => $component, controller_frame => $controller, ); } # this gets a shit name so that the plugins can override a good name sub choose_cache_backend_wrapper { my ( $c, @meta ) = @_; Carp::croak("metadata must be an even sized list") unless @meta % 2 == 0; my %meta = @meta; unless ( exists $meta{'caller'} ) { my %caller = $c->_cache_caller_meta; @meta{keys %caller} = values %caller; } # allow the cache client to specify who it wants to cache with (but loeave room for a hook) if ( exists $meta{backend} ) { if ( Scalar::Util::blessed($meta{backend}) ) { return $meta{backend}; } else { return $c->get_cache_backend( $meta{backend} ) || $c->default_cache_backend; } }; if ( my $chosen = $c->choose_cache_backend( %meta ) ) { $chosen = $c->get_cache_backend( $chosen ) unless Scalar::Util::blessed($chosen); # if it's a name find it return $chosen if Scalar::Util::blessed($chosen); # only return if it was an object or name lookup worked # FIXME # die "no such backend"? # currently, we fall back to default } return $c->default_cache_backend; } sub choose_cache_backend { shift->maybe::next::method( @_ ) } # a convenient fallback sub cache_set { my ( $c, $key, $value, %meta ) = @_; $c->choose_cache_backend_wrapper( key => $key, value => $value, %meta ) ->set( $key, $value, exists $meta{expires} ? $meta{expires} : () ); } sub cache_get { my ( $c, $key, @meta ) = @_; $c->choose_cache_backend_wrapper( key => $key, @meta )->get( $key ); } sub cache_remove { my ( $c, $key, @meta ) = @_; $c->choose_cache_backend_wrapper( key => $key, @meta )->remove( $key ); } sub cache_compute { my ($c, $key, $code, %meta) = @_; my $backend = $c->choose_cache_backend_wrapper( key => $key, %meta ); if ($backend->can('compute')) { return $backend->compute( $key, $code, exists $meta{expires} ? $meta{expires} : () ); } Carp::croak "must specify key and code" unless defined($key) && defined($code); my $value = $c->cache_get( $key, %meta ); if ( !defined $value ) { $value = $code->(); $c->cache_set( $key, $value, %meta ); } return $value; } __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Cache - Flexible caching support for Catalyst. =head1 SYNOPSIS use Catalyst qw/ Cache /; # configure a backend or use a store plugin __PACKAGE__->config->{'Plugin::Cache'}{backend} = { class => "Cache::Bounded", # ... params for Cache::Bounded... }; # typical example for Cache::Memcached::libmemcached __PACKAGE__->config->{'Plugin::Cache'}{backend} = { class => "Cache::Memcached::libmemcached", servers => ['127.0.0.1:11211'], debug => 2, }; # In a controller: sub foo : Local { my ( $self, $c, $id ) = @_; my $cache = $c->cache; my $result; unless ( $result = $cache->get( $id ) ) { # ... calculate result ... $c->cache->set( $id, $result ); } }; =head1 DESCRIPTION This plugin gives you access to a variety of systems for caching data. It allows you to use a very simple configuration API, while maintaining the possibility of flexibility when you need it later. Among its features are support for multiple backends, segmentation based on component or controller, keyspace partitioning, and so more, in various subsidiary plugins. =head1 METHODS =over 4 =item cache $profile_name =item cache %meta Return a curried object with metadata from C<$profile_name> or as explicitly specified. If a profile by the name C<$profile_name> doesn't exist, but a backend object by that name does exist, the backend will be returned instead, since the interface for curried caches and backends is almost identical. This method can also be called without arguments, in which case is treated as though the C<%meta> hash was empty. See L for details. =item curry_cache %meta Return a L object, curried with C<%meta>. See L for details. =item cache_set $key, $value, %meta =item cache_get $key, %meta =item cache_remove $key, %meta =item cache_compute $key, $code, %meta These cache operations will call L with %meta, and then call C, C, C, or C on the resulting backend object. If the backend object does not support C then we emulate it by calling L, and if the returned value is undefined we call the passed code reference, stores the returned value with L, and then returns the value. Inspired by L. =item choose_cache_backend %meta Select a backend object. This should return undef if no specific backend was selected - its caller will handle getting C on its own. This method is typically used by plugins. =item get_cache_backend $name Get a backend object by name. =item default_cache_backend Return the default backend object. =item temporary_cache_backend When no default cache backend is configured this method might return a backend known to work well with the current L. This is a stub. =item =back =head1 METADATA =head2 Introduction Whenever you set or retrieve a key you may specify additional metadata that will be used to select a specific backend. This metadata is very freeform, and the only key that has any meaning by default is the C key which can be used to explicitly choose a backend by name. The C method can be overridden in order to facilitate more intelligent backend selection. For example, L overrides that method to select a backend based on key regexes. Another example is a L, which wraps backends in objects that perform key mangling, in order to keep caches namespaced per controller. However, this is generally left as a hook for larger, more complex applications. Most configurations should make due XXXX The simplest way to dynamically select a backend is based on the L configuration. =head2 Meta Data Keys C is called with some default keys. =over 4 =item key Supplied by C, C, and C. =item value Supplied by C. =item caller The package name of the innermost caller that doesn't match C. =item caller_frame The entire C frame of C. =item component The package name of the innermost caller who C L. =item component_frame This entire C frame of C. =item controller The package name of the innermost caller who C L. =item controller_frame This entire C frame of C. =back =head2 Metadata Currying In order to avoid specifying C<%meta> over and over again you may call C or C with C<%meta> once, and get back a B. This object responds to the methods C, C, and C, by appending its captured metadata and delegating them to C, C, and C. This is simpler than it sounds. Here is an example using currying: my $cache = $c->cache( %meta ); # cache is curried $cache->set( $key, $value ); $cache->get( $key ); And here is an example without using currying: $c->cache_set( $key, $value, %meta ); $c->cache_get( $key, %meta ); See L for details. =head1 CONFIGURATION $c->config->{'Plugin::Cache'} = { ... }; All configuration parameters should be provided in a hash reference under the C key in the C hash. =head2 Backend Configuration Configuring backend objects is done by adding hash entries under the C key in the main config. A special case is that the hash key under the C (singular) key of the main config is assumed to be the backend named C. =over 4 =item class Instantiate a backend from a L compatible class. E.g. $c->config->{'Plugin::Cache'}{backends}{small_things} = { class => "Cache::Bounded", interval => 1000, size => 10000, }; $c->config->{'Plugin::Cache'}{backends}{large_things} = { class => "Cache::Memcached", data => '1.2.3.4:1234', }; The options in the hash are passed to the class's C method. The class will be C as necessary during setup time. =item store Instantiate a backend using a store plugin, e.g. $c->config->{'Plugin::Cache'}{backend} = { store => "FastMmap", }; Store plugins typically require less configuration because they are specialized for L applications. For example L will specify a default C, and additionally use a subclass of L that can also store non reference data. The store plugin must be loaded. =back =head2 Cache Profiles =over 4 =item profiles Supply your own predefined profiles for cache metadata, when using the C method. For example when you specify $c->config->{'Plugin::Cache'}{profiles}{thumbnails} = { backend => "large_things", }; And then get a cache object like this: $c->cache("thumbnails"); It is the same as if you had done: $c->cache( backend => "large_things" ); =back =head2 Miscellaneous Configuration =over 4 =item default_store When you do not specify a C parameter in the backend configuration this one will be used instead. This configuration parameter is not necessary if only one store plugin is loaded. =back =head1 TERMINOLOGY =over 4 =item backend An object that responds to the methods detailed in L (or more). =item store A plugin that provides backends of a certain type. This is a bit like a factory. =item cache Stored key/value pairs of data for easy re-access. =item metadata "Extra" information about the item being stored, which can be used to locate an appropriate backend. =item curried cache my $cache = $c->cache(type => 'thumbnails'); $cache->set('pic01', $thumbnaildata); A cache which has been pre-configured with a particular set of namespacing data. In the example the cache returned could be one specifically tuned for storing thumbnails. An object that responds to C, C, and C, and will automatically add metadata to calls to C<< $c->cache_get >>, etc. =back =head1 SEE ALSO L - the generic cache API on CPAN. L - how to write a store plugin. L - the interface for curried caches. L - choose a backend based on regex matching on the keys. Can be used to partition the keyspace. L - wrap backend objects in a name mangler so that every controller gets its own keyspace. =head1 AUTHOR Yuval Kogman, C Jos Boumans, C =head1 COPYRIGHT & LICENSE Copyright (c) Yuval Kogman, 2006. All rights reserved. This library is free software, you can redistribute it and/or modify it under the same terms as Perl itself, as well as under the terms of the MIT license. =cut Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Backend/000755 000765 000024 00000000000 12112674363 023447 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Backend.pm000644 000765 000024 00000000706 11727747517 024025 0ustar00t0mstaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Cache::Backend; use strict; use warnings; sub set { my ( $self, $key, $value ) = @_; } sub get { my ( $self, $key ) = @_; } sub remove { my ( $self, $key ) = @_; } __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Cache::Backend - Bare minimum backend interface. =head1 SYNOPSIS use Catalyst::Plugin::Cache::Backend; =head1 DESCRIPTION This is less than L. =cut Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Choose/000755 000765 000024 00000000000 12112674363 023340 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Curried.pm000644 000765 000024 00000004127 11727747517 024074 0ustar00t0mstaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Cache::Curried; use strict; use warnings; use base qw/Class::Accessor::Fast/; use Scalar::Util (); __PACKAGE__->mk_accessors(qw/c meta/); sub new { my ( $class, $c, @meta ) = @_; my $self = $class->SUPER::new({ c => $c, meta => \@meta, }); Scalar::Util::weaken( $self->{c} ) if ref( $self->{c} ); return $self; } sub backend { my ( $self, @meta ) = @_; $self->c->choose_cache_backend( @{ $self->meta }, @meta ) } sub set { my ( $self, $key, $value, @meta ) = @_; @meta = ( expires => $meta[0] ) if @meta == 1; $self->c->cache_set( $key, $value, @{ $self->meta }, @meta ); } sub get { my ( $self, $key ) = @_; $self->c->cache_get( $key, @{ $self->meta } ); } sub remove { my ( $self, $key ) = @_; $self->c->cache_remove( $key, @{ $self->meta } ); } sub compute { my ($self, $key, $code, @meta) = @_; @meta = ( expires => $meta[0] ) if @meta == 1; $self->c->cache_compute( $key, $code, @{ $self->meta }, @meta ); } __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Cache::Curried - Curried versions of C, C and C that look more like a backend. =head1 SYNOPSIS my $curried = $c->cache( %meta ); $curried->get( $key, $value ); # no need to specify %meta =head1 DESCRIPTION See L for details. =head1 METHODS =over 4 =item new %meta Create a new curried cache, that captures C<%meta>. =item backend %additional_meta This calls C on the $c object with the captured meta and the additional meta. =item set $key, $value, %additional_meta =item get $key, %additional_meta =item remove $key, %additional_meta =item compute $key, $code, %additional_meta Dellegate to the C object's C, C, C or C with the arguments, then the captured meta from C, and then the additional meta. =item meta Returns the array ref that captured %meta from C. =item c The captured $c object to delegate to. =back =cut Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Store/000755 000765 000024 00000000000 12112674363 023214 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Store.pod000644 000765 000024 00000002127 11727747517 023737 0ustar00t0mstaff000000 000000 =pod =head1 NAME Catalyst::Plugin::Cache::Store - how to write a Cache store plugin. =head1 SYNOPSIS package Catalyst::Plugin::Cache::Store::Frobnicator; sub setup_frobnicator_cache_backend { my ( $app, $name, $config ) = @_; .... $app->register_cache_backend( $name => $cache_object ); } =head1 DESCRIPTION In order to write a cache store plugin, all you need is to implement a method following the naming convention: setup_<>_cache_backend { } For example C for L. and call C from within that. The method will get the backend name and configuration as it's first and second arguments. All invokation of the setup methods will be automatic, based on the configuration. However, the plugin must be loaded by the user. Note that store plugins are only necessary if some configuration defaults that are catalyst specific need to be provided. For most cases simply using a cache class instead of a plugin is sufficient. =cut Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Store/Memory.pm000644 000765 000024 00000000777 11727747517 025052 0ustar00t0mstaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Cache::Store::Memory; use strict; use warnings; use Catalyst::Plugin::Cache::Backend::Memory; sub setup_memory_cache_backend { my ( $app, $name ) = @_; $app->register_cache_backend( $name => Catalyst::Plugin::Cache::Backend::Memory->new ); } __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Cache::Store::Memory - Stupid memory based cache store plugin. =head1 SYNOPSIS use Catalyst::Plugin::Cache::Store::Memory; =head1 DESCRIPTION =cut Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Choose/KeyRegexes.pm000644 000765 000024 00000001760 11727747517 025772 0ustar00t0mstaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Cache::Choose::KeyRegexes; use strict; use warnings; use MRO::Compat; sub setup { my $app = shift; my $ret = $app->maybe::next::method( @_ ); my $regexes = $app->_get_cache_plugin_config->{key_regexes} ||= []; die "the regex list must be an array containing regexex/backend pairs" unless ref $regexes eq "ARRAY"; $ret; } sub get_cache_key_regexes { my ( $c, %meta ) = @_; @{ $c->_get_cache_plugin_config->{key_regexes} }; } sub choose_cache_backend { my ( $c, %meta ) = @_; my @regexes = $c->get_cache_key_regexes( %meta ); while ( @regexes and my ( $re, $backend ) = splice( @regexes, 0, 2 ) ) { return $backend if $meta{key} =~ $re; } $c->maybe::next::method( %meta ); } __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Cache::Choose::KeyRegex - Choose a cache backend based on key regexes. =head1 SYNOPSIS use Catalyst::Plugin::Cache::Choose::KeyRegex; =head1 DESCRIPTION =cut Catalyst-Plugin-Cache-0.12/lib/Catalyst/Plugin/Cache/Backend/Memory.pm000644 000765 000024 00000001471 11727747517 025275 0ustar00t0mstaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Cache::Backend::Memory; use Storable; use strict; use warnings; use Storable qw/freeze thaw/; sub new { bless {}, shift } sub get { ${thaw($_[0]{$_[1]}) || return} }; sub set { $_[0]{$_[1]} = freeze(\$_[2]) }; sub remove { delete $_[0]{$_[1]} }; __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Cache::Backend::Memory - Stupid memory based caching backend. =head1 SYNOPSIS use Catalyst::Plugin::Cache::Backend::Memory; my $m = Catalyst::Plugin::Cache::Backend::Memory->new; $m->set( foo => "thing" ); =head1 DESCRIPTION This backend uses L to cache data in memory. In combination with an engine like FastCGI/mod_perl/prefork which calls fork() your cache will get async because child processes don't share cache in memory. =cut Catalyst-Plugin-Cache-0.12/inc/Module/000755 000765 000024 00000000000 12112674363 017323 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/inc/Module/Install/000755 000765 000024 00000000000 12112674363 020731 5ustar00t0mstaff000000 000000 Catalyst-Plugin-Cache-0.12/inc/Module/Install.pm000644 000765 000024 00000030135 12112674345 021271 0ustar00t0mstaff000000 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.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Catalyst-Plugin-Cache-0.12/inc/Module/Install/Base.pm000644 000765 000024 00000002147 12112674345 022145 0ustar00t0mstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Catalyst-Plugin-Cache-0.12/inc/Module/Install/Can.pm000644 000765 000024 00000006157 12112674345 022001 0ustar00t0mstaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Catalyst-Plugin-Cache-0.12/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 12112674345 022331 0ustar00t0mstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Catalyst-Plugin-Cache-0.12/inc/Module/Install/Makefile.pm000644 000765 000024 00000027437 12112674345 023021 0ustar00t0mstaff000000 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.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Catalyst-Plugin-Cache-0.12/inc/Module/Install/Metadata.pm000644 000765 000024 00000043277 12112674345 023024 0ustar00t0mstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Catalyst-Plugin-Cache-0.12/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 12112674345 022171 0ustar00t0mstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Catalyst-Plugin-Cache-0.12/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 12112674345 023022 0ustar00t0mstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;