Catalyst-Plugin-Session-0.40/000755 000765 000024 00000000000 12461562414 020140 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/Changes000644 000765 000024 00000020375 12461562141 021437 0ustar00jnapiorkowskistaff000000 000000 Revision history for Perl extension Catalyst::Plugin::Session 0.40 2015-01-26 - Add a flag so that a storage can finalize during finalize_header rather than finalize_body. This is to enable storages that need to write to the HTTP header (such as the cookie based store). 0.39 2013-10-16 - Fixed a bug when "expiry_threshold" is non-zero, where changes to the session were not saved. 0.38 2013-09-18 - New feature: "expiry_threshold" which allows you more control over when this plugin checks and updates the expiration date for the session. This is useful when you have high traffic and need to reduce the number of session expiration hits (like if you are using a database for sessions and your db is getting pounded). 0.37 2013-02-25 - Fix t/live_verify_address.t to skip if Catalyst::Plugin::Authentication is not installed, fixing RT#81506. 0.36 2012-10-19 - Re-pack with new Module::Install which doesn't get MYMETA.yaml wrong. - Remove use of Plack::Middleware::ForceEnv from the tests as it was not used / needed 0.35 2012-04-24 - Implement a 'change_session_expires' method (gshank) - Fixed bug from last version where session does not persist across a redirect 0.34 2012-03-30 - Fixed up t/live_verify_address.t per https://rt.cpan.org/Ticket/Display.html?id=71142 - Merged in dpetrov's 0.32 changes (extend_session_expire) 0.33 2012-03-08 - Note that flash is deprecated / not recommended due to it's inherent races. Point out Catalyst::Plugin::StatusMessage instead 0.32 2011-06-08 - Fix handling with enables verify_address and add related test 0.31 2010-10-08 - Fix session being loaded by call to dump_these in debug mode (RT#58856) 0.30 2010-06-24 - Fix Makefile.PL's is_upgrading_needed() routine (RT #58771) 0.29 2009-11-04 - Fix session being deleted when you have a new session after session expiry when calling session_is_valid method. Tests for this. - Allow ->session to be used as a setter method so that you can say ->session( key => $value ); 0.28 2009-10-29 - Fix session fixation test with LWP 5.833 by calling $cookie_jar->set_cookie rather than manually stuffing the cookie in the request. 0.27 2009-10-08 - Release 0.26_01 as stable without further changes. 0.26_01 2009-10-06 - Move actions out of the root application class in tests as this is deprecated. - Change configuration key to 'Plugin::Session' by default. The old 'session' key is still supported, but will issue a warning in a future release. 0.26 2009-08-19 - Remove Test::MockObject from the test suite as prone to failing on some platforms and perl versions due to it's UNIVERSAL:: package dependencies. 0.25 2009-07-08 - Add the a change_session_id method which can be called after authentication to change the user's session cookie whilst preserving their session data. This can be used to provide protection from Session Fixation attacks. (kmx) 0.24 2009-06-23 - Be more paranoid about getting values of $c->req to avoid issues with old Test::WWW::Mechanize::Catalyst. - Check we have a modern version of TWMC before doing the tests which need it. 0.23 2009-06-16 - Add the verify_user_agent config parameter (kmx) - Add a test case to prove that logging in with a session cookie still causes a new cookie to be issued for you, proving that the code is not vulnerable to a session fixation attack. (t0m) 0.22 2009-05-13 - INSANE HACK to ensure B::Hooks::EndOfScope inlines us a new method right now in Catalyst::Plugin::Session::Test::Store for Catalyst 5.80004 compatibility. This change does not in any way affect normal users - it is just due to the fairly crazy way that Catalyst::Plugin::Session::Test::Store works, and that module is _only_ used for unit testing session store plugins pre-installation. Session::Test::Store should be replaced with a more sane solution, and other CPAN modules using it moved away from using it, but this change keeps stops new Catalyst breaking other distributions right now. 0.21 2009-04-30 - Hide the internal packages in Catalyst::Plugin::Session::Test::Store from PAUSE. - Convert from CAF to Moose with Moosex::Emulate::Class::Accessor::Fast 0.20 2009-02-05 - No code changes since 0.19_01 dev release. - Add IDEAS.txt which is an irc log of discussion about the next-generation session plugin from discussion on #catalyst-dev - Remove TODO file, which is no longer relevant. 0.19_01 2009-01-09 - Switch from using NEXT to Class::C3 for method re-dispatch. - Use shipit to package the dist. - Switch to Module::install. - Flash data is now stored inside the session (key "__flash") to avoid duplicate entry errors caused by simultaneous select/insert/delete of flash rows when using DBI as a Store. (Sergio Salvi) - Fix session finalization order that caused HTTP responses to be sent before the session is actually finalized and stored in its Store. (Sergio Salvi) 0.19 2007-10-08 0.18 2007-08-15 - Fix Apache engine issue (RT #28845) 0.17 2007-07-16 - Skip a test if Cookie is not installed (RT #28137) 0.16 2007-07-03 - Stupid makefile 0.15 2007-06-24 - Fix the bug that caused sessions to expire immediately when another session was deleted previously in the same request cycle - Changed finalize() to redispatch before saving session so other finalize methods still have access to it. 0.14 2007-01-31 - Disable verify_address. - update flash to work like session 0.13 2006-10-12 - Rerelease with slightly changed test due to a behavior change in Test::MockObject - add `clear_flash` - improve debug logging 0.12 2006-08-26 - refactor out a hookable finalize_session method, for plugins - make _clear_session_instance_data call NEXT::, so that plugins can hook on to that too 0.11 2006-08-10 - Lazify expiry calculation and store it in a different instance data slot. This provides greater flexibility for implementing hooks like DynamicExpiry the "right" way. 0.10 2006-08-01 - Implement a more well defined finalization order for Session stuff. This solves a problem that was introduced by some value cleanups in the 0.06 release. 0.09 2006-07-31 - Fix Catalyst::Plugin::Session::Test::Store 0.08 2006-07-31 - rerelease because Module::Bane broke the META.yml. HURAAH 0.07 2006-07-30 - Make build tool complain loudly on incompatible versions of state plugins. 0.06 2006-07-29 - Change State plugin API to be pull oriented - Lazify more correctly (mostly performance improvements) - Don't try to compute digest of hash when there is no hash 0.05 2006-01-01 - Un-workaround the Cache::FastMmap (actually Storable) limitation - it's not C::P::Session's business. - add $c->session_expires - refactor guts - improve semantics of session deletion (now deletes flash data too) - improve lazy-load-ness of session data in the light of expiration 0.04 2005-12-28 09:42:00 - Work around a limitation in Cache::FastMmap - must store only references, while expiration was an NV. 0.03 2005-12-26 10:22:00 - Lazify loading of session data for better performance and less chance of race conditions - support for $c->flash a la Ruby on Rails - Fixed bug in sessionid algorithm detection. - Separate __expires from the session data - we write it every time - Lazify saving of session data for better performance and less chance of race conditions 0.02 2005-11-23 09:40:00 - Doc fixes - No more -Engine=Test 0.01 2005-11-14 12:41:00 - Initial release. Catalyst-Plugin-Session-0.40/inc/000755 000765 000024 00000000000 12461562414 020711 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/lib/000755 000765 000024 00000000000 12461562414 020706 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/Makefile.PL000644 000765 000024 00000003202 12461526004 022102 0ustar00jnapiorkowskistaff000000 000000 use inc::Module::Install 0.87; use Module::Install::AuthorTests; if ( -e 'MANIFEST.SKIP' ) { system( 'pod2text lib/Catalyst/Plugin/Session.pm > README' ) and die("Could not run pod2text on lib/Catalyst/Plugin/Session.pm"); } is_upgrading_needed(); perl_version '5.008'; name 'Catalyst-Plugin-Session'; all_from 'lib/Catalyst/Plugin/Session.pm'; requires 'Catalyst::Runtime' => '5.71001'; requires 'namespace::clean' => '0.10'; requires 'Digest'; requires 'File::Spec'; requires 'File::Temp'; requires 'List::Util'; requires 'Object::Signature'; requires 'MRO::Compat'; requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00801'; requires 'Moose' => '0.76'; # an indirect dep. needs a certain version. requires 'Tie::RefHash' => '1.34'; # for Test::Store requires 'Test::More' => '0.88'; test_requires 'Test::Deep'; test_requires 'Test::Exception'; test_requires 'Test::WWW::Mechanize::PSGI'; resources repository => 'git://git.shadowcat.co.uk/catagits/Catalyst-Plugin-Session.git'; author_tests 't/author'; WriteAll; sub is_upgrading_needed { my %state = ( Cookie => 0.03, URI => 0.02, ); foreach my $module (keys %state) { my $package = 'Catalyst::Plugin::Session::State::' . $module; next if not eval "require $package;"; if( not eval { $package->VERSION( $state{ $module } ); } ) { warn <req->param("item"); # $c->session is a hash ref, a bit like $c->stash # the difference is that it' preserved across requests push @{ $c->session->{items} }, $item_id; $c->forward("MyView"); } sub display_items : Local { my ( $self, $c ) = @_; # values in $c->session are restored $c->stash->{items_to_display} = [ map { MyModel->retrieve($_) } @{ $c->session->{items} } ]; $c->forward("MyView"); } DESCRIPTION The Session plugin is the base of two related parts of functionality required for session management in web applications. The first part, the State, is getting the browser to repeat back a session key, so that the web application can identify the client and logically string several requests together into a session. The second part, the Store, deals with the actual storage of information about the client. This data is stored so that the it may be revived for every request made by the same client. This plugin links the two pieces together. RECOMENDED BACKENDS Session::State::Cookie The only really sane way to do state is using cookies. Session::Store::File A portable backend, based on Cache::File. Session::Store::FastMmap A fast and flexible backend, based on Cache::FastMmap. METHODS sessionid An accessor for the session ID value. session Returns a hash reference that might contain unserialized values from previous requests in the same session, and whose modified value will be saved for future requests. This method will automatically create a new session and session ID if none exists. You can also set session keys by passing a list of key/value pairs or a hashref. $c->session->{foo} = "bar"; # This works. $c->session(one => 1, two => 2); # And this. $c->session({ answer => 42 }); # And this. session_expires This method returns the time when the current session will expire, or 0 if there is no current session. If there is a session and it already expired, it will delete the session and return 0 as well. flash This is like Ruby on Rails' flash data structure. Think of it as a stash that lasts for longer than one request, letting you redirect instead of forward. The flash data will be cleaned up only on requests on which actually use $c->flash (thus allowing multiple redirections), and the policy is to delete all the keys which haven't changed since the flash data was loaded at the end of every request. Note that use of the flash is an easy way to get data across requests, but it's also strongly disrecommended, due it it being inherently plagued with race conditions. This means that it's unlikely to work well if your users have multiple tabs open at once, or if your site does a lot of AJAX requests. Catalyst::Plugin::StatusMessage is the recommended alternative solution, as this doesn't suffer from these issues. sub moose : Local { my ( $self, $c ) = @_; $c->flash->{beans} = 10; $c->response->redirect( $c->uri_for("foo") ); } sub foo : Local { my ( $self, $c ) = @_; my $value = $c->flash->{beans}; # ... $c->response->redirect( $c->uri_for("bar") ); } sub bar : Local { my ( $self, $c ) = @_; if ( exists $c->flash->{beans} ) { # false } } clear_flash Zap all the keys in the flash regardless of their current state. keep_flash @keys If you want to keep a flash key for the next request too, even if it hasn't changed, call "keep_flash" and pass in the keys as arguments. delete_session REASON This method is used to invalidate a session. It takes an optional parameter which will be saved in "session_delete_reason" if provided. NOTE: This method will also delete your flash data. session_delete_reason This accessor contains a string with the reason a session was deleted. Possible values include: * "address mismatch" * "session expired" session_expire_key $key, $ttl Mark a key to expire at a certain time (only useful when shorter than the expiry time for the whole session). For example: __PACKAGE__->config('Plugin::Session' => { expires => 10000000000 }); # "forever" (NB If this number is too large, Y2K38 breakage could result.) # later $c->session_expire_key( __user => 3600 ); Will make the session data survive, but the user will still be logged out after an hour. Note that these values are not auto extended. change_session_id By calling this method you can force a session id change while keeping all session data. This method might come handy when you are paranoid about some advanced variations of session fixation attack. If you want to prevent this session fixation scenario: 0) let us have WebApp with anonymous and authenticated parts 1) a hacker goes to vulnerable WebApp and gets a real sessionid, just by browsing anonymous part of WebApp 2) the hacker inserts (somehow) this values into a cookie in victim's browser 3) after the victim logs into WebApp the hacker can enter his/her session you should call change_session_id in your login controller like this: if ($c->authenticate( { username => $user, password => $pass } )) { # login OK $c->change_session_id; ... } else { # login FAILED ... } change_session_expires $expires You can change the session expiration time for this session; $c->change_session_expires( 4000 ); Note that this only works to set the session longer than the config setting. INTERNAL METHODS setup This method is extended to also make calls to "check_session_plugin_requirements" and "setup_session". check_session_plugin_requirements This method ensures that a State and a Store plugin are also in use by the application. setup_session This method populates "$c->config('Plugin::Session')" with the default values listed in "CONFIGURATION". prepare_action This method is extended. Its only effect is if the (off by default) "flash_to_stash" configuration parameter is on - then it will copy the contents of the flash to the stash at prepare time. finalize_headers This method is extended and will extend the expiry time before sending the response. finalize_body This method is extended and will call finalize_session before the other finalize_body methods run. Here we persist the session data if a session exists. initialize_session_data This method will initialize the internal structure of the session, and is called by the "session" method if appropriate. create_session_id Creates a new session ID using "generate_session_id" if there is no session ID yet. validate_session_id SID Make sure a session ID is of the right format. This currently ensures that the session ID string is any amount of case insensitive hexadecimal characters. generate_session_id This method will return a string that can be used as a session ID. It is supposed to be a reasonably random string with enough bits to prevent collision. It basically takes "session_hash_seed" and hashes it using SHA-1, MD5 or SHA-256, depending on the availability of these modules. session_hash_seed This method is actually rather internal to generate_session_id, but should be overridable in case you want to provide more random data. Currently it returns a concatenated string which contains: * A counter * The current time * One value from "rand". * The stringified value of a newly allocated hash reference * The stringified value of the Catalyst context object in the hopes that those combined values are entropic enough for most uses. If this is not the case you can replace "session_hash_seed" with e.g. sub session_hash_seed { open my $fh, "<", "/dev/random"; read $fh, my $bytes, 20; close $fh; return $bytes; } Or even more directly, replace "generate_session_id": sub generate_session_id { open my $fh, "<", "/dev/random"; read $fh, my $bytes, 20; close $fh; return unpack("H*", $bytes); } Also have a look at Crypt::Random and the various openssl bindings - these modules provide APIs for cryptographically secure random data. finalize_session Clean up the session during "finalize". This clears the various accessors after saving to the store. dump_these See "dump_these" in Catalyst - ammends the session data structure to the list of dumped objects if session ID is defined. calculate_extended_session_expires calculate_initial_session_expires create_session_id_if_needed delete_session_id extend_session_expires Note: this is *not* used to give an individual user a longer session. See 'change_session_expires'. extend_session_id get_session_id reset_session_expires session_is_valid set_session_id initial_session_expires USING SESSIONS DURING PREPARE The earliest point in time at which you may use the session data is after Catalyst::Plugin::Session's "prepare_action" has finished. State plugins must set $c->session ID before "prepare_action", and during "prepare_action" Catalyst::Plugin::Session will actually load the data from the store. sub prepare_action { my $c = shift; # don't touch $c->session yet! $c->NEXT::prepare_action( @_ ); $c->session; # this is OK $c->sessionid; # this is also OK } CONFIGURATION $c->config('Plugin::Session' => { expires => 1234, }); All configuation parameters are provided in a hash reference under the "Plugin::Session" key in the configuration hash. expires The time-to-live of each session, expressed in seconds. Defaults to 7200 (two hours). expiry_threshold Only update the session expiry time if it would otherwise expire within this many seconds from now. The purpose of this is to keep the session store from being updated when nothing else in the session is updated. Defaults to 0 (in which case, the expiration will always be updated). verify_address When true, "$c->request->address" will be checked at prepare time. If it is not the same as the address that initiated the session, the session is deleted. Defaults to false. verify_user_agent When true, "$c->request->user_agent" will be checked at prepare time. If it is not the same as the user agent that initiated the session, the session is deleted. Defaults to false. flash_to_stash This option makes it easier to have actions behave the same whether they were forwarded to or redirected to. On prepare time it copies the contents of "flash" (if any) to the stash. SPECIAL KEYS The hash reference returned by "$c->session" contains several keys which are automatically set: __expires This key no longer exists. Use "session_expires" instead. __updated The last time a session was saved to the store. __created The time when the session was first created. __address The value of "$c->request->address" at the time the session was created. This value is only populated if "verify_address" is true in the configuration. __user_agent The value of "$c->request->user_agent" at the time the session was created. This value is only populated if "verify_user_agent" is true in the configuration. CAVEATS Round the Robin Proxies "verify_address" could make your site inaccessible to users who are behind load balanced proxies. Some ISPs may give a different IP to each request by the same client due to this type of proxying. If addresses are verified these users' sessions cannot persist. To let these users access your site you can either disable address verification as a whole, or provide a checkbox in the login dialog that tells the server that it's OK for the address of the client to change. When the server sees that this box is checked it should delete the "__address" special key from the session hash when the hash is first created. Race Conditions In this day and age where cleaning detergents and Dutch football (not the American kind) teams roam the plains in great numbers, requests may happen simultaneously. This means that there is some risk of session data being overwritten, like this: 1. request a starts, request b starts, with the same session ID 2. session data is loaded in request a 3. session data is loaded in request b 4. session data is changed in request a 5. request a finishes, session data is updated and written to store 6. request b finishes, session data is updated and written to store, overwriting changes by request a For applications where any given user's session is only making one request at a time this plugin should be safe enough. AUTHORS Andy Grundman Christian Hansen Yuval Kogman, "nothingmuch@woobling.org" Sebastian Riedel Tomas Doran (t0m) "bobtfish@bobtfish.net" (current maintainer) Sergio Salvi kmx "kmx@volny.cz" Florian Ragwitz (rafl) "rafl@debian.org" Kent Fredric (kentnl) And countless other contributers from #catalyst. Thanks guys! Contributors Devin Austin (dhoss) Robert Rothenberg (on behalf of Foxtons Ltd.) COPYRIGHT & LICENSE Copyright (c) 2005 the aforementioned authors. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Catalyst-Plugin-Session-0.40/t/000755 000765 000024 00000000000 12461562414 020403 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/00_basic_sanity.t000644 000765 000024 00000000306 12461526004 023531 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 4; my $m; BEGIN { use_ok($m = "Catalyst::Plugin::Session") } can_ok($m, $_) for qw/sessionid session session_delete_reason/; Catalyst-Plugin-Session-0.40/t/01_setup.t000644 000765 000024 00000003570 12461526004 022230 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 10; use Class::MOP; use Test::Deep; my $m; BEGIN { use_ok( $m = "Catalyst::Plugin::Session" ) } my %config; my $log_meta = Class::MOP::Class->create_anon_class(superclasses => ['Moose::Object']); my $log = $log_meta->name->new; my @mock_isa = (); my $calls = 0; $log_meta->add_method("fatal" => sub { $calls++; 1; }); { package MockCxt; use MRO::Compat; use base $m; sub new { bless {}, $_[0] } sub config { \%config } sub log { $log } sub isa { my $self = shift; my $class = shift; grep { $_ eq $class } @mock_isa or $self->SUPER::isa($class); } } can_ok( $m, "setup" ); eval { MockCxt->new->setup }; # throws OK is not working with NEXT like( $@, qr/requires.*((?:State|Store).*){2}/i, "can't setup an object that doesn't use state/store plugins" ); is $calls, 1, 'Fatal error logged'; @mock_isa = qw/Catalyst::Plugin::Session::State/; eval { MockCxt->new->setup }; like( $@, qr/requires.*(?:Store)/i, "can't setup an object that doesn't use state/store plugins" ); @mock_isa = qw/Catalyst::Plugin::Session::Store/; eval { MockCxt->new->setup }; like( $@, qr/requires.*(?:State)/i, "can't setup an object that doesn't use state/store plugins" ); $calls = 0; @mock_isa = qw/Catalyst::Plugin::Session::State Catalyst::Plugin::Session::Store/; eval { MockCxt->new->setup }; ok( !$@, "setup() lives with state/store plugins in use" ); is( $calls, 0, "no fatal error logged either" ); cmp_deeply( [ keys %{ $config{'Plugin::Session'} } ], bag(qw/expires verify_address verify_user_agent expiry_threshold/), "default values for config were populated in successful setup", ); %config = ( session => { expires => 1234 } ); MockCxt->new->setup; is( $config{session}{expires}, 1234, "user values are not overwritten in config" ); Catalyst-Plugin-Session-0.40/t/03_flash.t000644 000765 000024 00000004045 12461526004 022165 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 12; use Test::Exception; use Test::Deep; my $m; BEGIN { use_ok( $m = "Catalyst::Plugin::Session" ) } my $c_meta = Class::MOP::Class->create_anon_class( superclasses => [ $m, 'Moose::Object', ], ); my $c = $c_meta->name->new; my $flash = {}; $c_meta->add_method( get_session_data => sub { my ( $c, $key ) = @_; return $key =~ /expire/ ? time() + 1000 : $flash; }, ); $c->meta->add_method("debug" => sub { 0 }); $c->meta->add_method("store_session_data" => sub { $flash = $_[2] }); $c->meta->add_method("delete_session_data" => sub { $flash = {} }); $c->meta->add_method( _sessionid => sub { "deadbeef" }); my $config = { expires => 1000 }; $c->meta->add_method( config => sub { { session => $config } }); my $stash = {}; $c->meta->add_method( stash => sub { $stash } ); is_deeply( $c->session, {}, "nothing in session" ); is_deeply( $c->flash, {}, "nothing in flash" ); $c->flash->{foo} = "moose"; $c->finalize_body; is_deeply( $c->flash, { foo => "moose" }, "one key in flash" ); cmp_deeply( $c->session, { __updated => re('^\d+$'), __flash => $c->flash }, "session has __flash with flash data" ); $c->flash(bar => "gorch"); is_deeply( $c->flash, { foo => "moose", bar => "gorch" }, "two keys in flash" ); cmp_deeply( $c->session, { __updated => re('^\d+$'), __flash => $c->flash }, "session still has __flash with flash data" ); $c->finalize_body; is_deeply( $c->flash, { bar => "gorch" }, "one key in flash" ); $c->finalize_body; $c->flash->{test} = 'clear_flash'; $c->finalize_body; $c->clear_flash(); is_deeply( $c->flash, {}, "nothing in flash after clear_flash" ); $c->finalize_body; is_deeply( $c->flash, {}, "nothing in flash after finalize after clear_flash" ); cmp_deeply( $c->session, { __updated => re('^\d+$'), }, "session has empty __flash after clear_flash + finalize" ); $c->flash->{bar} = "gorch"; $config->{flash_to_stash} = 1; $c->finalize_body; $c->prepare_action; is_deeply( $c->stash, { bar => "gorch" }, "flash copied to stash" ); Catalyst-Plugin-Session-0.40/t/05_semi_persistent_flash.t000644 000765 000024 00000002570 12461526004 025465 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More; BEGIN { eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie version 0.03 or higher is required for this test"; eval { require Test::WWW::Mechanize::Catalyst; Test::WWW::Mechanize::Catalyst->VERSION(0.51); } or plan skip_all => 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; plan tests => '10'; } use lib "t/lib"; use Test::WWW::Mechanize::Catalyst 'FlashTestApp'; my $ua = Test::WWW::Mechanize::Catalyst->new; # flash absent for initial request $ua->get_ok( "http://localhost/first"); $ua->content_contains( "flash is not set", "not set"); # present for 1st req. $ua->get_ok( "http://localhost/second"); $ua->content_contains( "flash set first time", "set first"); # should be the same 2nd req. $ua->get_ok( "http://localhost/third"); $ua->content_contains( "flash set second time", "set second"); # and the third request, flash->{is_set} has the same value as 2nd. $ua->get_ok( "http://localhost/fourth"); $ua->content_contains( "flash set 3rd time, same val as prev.", "set third"); # and should be absent again for the 4th req. $ua->get_ok( "http://localhost/fifth"); $ua->content_contains( "flash is not", "flash has gone"); Catalyst-Plugin-Session-0.40/t/author/000755 000765 000024 00000000000 12461562414 021705 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/cat_test.t000644 000765 000024 00000003751 12461526004 022377 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More; use HTTP::Request::Common; # setup library path use FindBin qw($Bin); use lib "$Bin/lib"; # this test was copied from CatalystX::SimpleLogin BEGIN { plan skip_all => "Need Catalyst::Plugin::Session::State::Cookie" unless do { local $@; eval { require Catalyst::Plugin::Session::State::Cookie; } }; plan skip_all => "Need Catalyst::Plugin::Authentication" unless do { local $@; eval { require Catalyst::Plugin::Authentication; } }; } use Catalyst::Test 'SessionTestApp'; my ($res, $c); ($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 's00p3r', remember => 1]); is($res->code, 200, 'succeeded'); my $cookie = $res->header('Set-Cookie'); ok($cookie, 'Have a cookie'); # cookie is changed by the get sleep(1); ($res, $c) = ctx_request(GET 'http://localhost/page', Cookie => $cookie); like($c->res->body, qr/logged in/, 'logged in'); my $new_cookie = $res->header('Set-Cookie'); isnt( $cookie, $new_cookie, 'cookie expires has been updated' ); # request with no cookie ($res, $c) = ctx_request(GET 'http://localhost/page' ); like($c->res->body, qr/please login/, 'not logged in'); $new_cookie = $res->header('Set-Cookie'); ok( ! defined $new_cookie, 'no cookie created' ); # check that cookie is reset by reset_session_expires ($res, $c) = ctx_request(GET 'http://localhost/reset_session_expires', Cookie => $cookie); my $reset_cookie = $res->header('Set-Cookie'); isnt( $cookie, $reset_cookie, 'Cookie has been changed by reset_session' ); # this checks that cookie exists after a logout and redirect # Catalyst::Plugin::Authentication removes the user session (remove_persisted_user) ($res, $c) = ctx_request(GET 'http://localhost/logout_redirect', Cookie => $cookie); is($res->code, 302, 'redirected'); is($res->header('Location'), 'http://localhost/from_logout_redirect', 'Redirected after logout_redirect'); ok($res->header('Set-Cookie'), 'Cookie is there after redirect'); done_testing; Catalyst-Plugin-Session-0.40/t/lib/000755 000765 000024 00000000000 12461562414 021151 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/live_accessor.t000644 000765 000024 00000001646 12461526004 023413 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl # use strict; use warnings; use Test::More; BEGIN { eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; eval { require Test::WWW::Mechanize::Catalyst; Test::WWW::Mechanize::Catalyst->VERSION(0.51); } or plan skip_all => 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; plan tests => 4; } use lib "t/lib"; use Test::WWW::Mechanize::Catalyst "SessionTestApp"; my $ua = Test::WWW::Mechanize::Catalyst->new; $ua->get_ok("http://localhost/accessor_test", "Set session vars okay"); $ua->content_contains("two: 2", "k/v list setter works okay"); $ua->content_contains("four: 4", "hashref setter works okay"); $ua->content_contains("five: 5", "direct access works okay"); Catalyst-Plugin-Session-0.40/t/live_app.t000644 000765 000024 00000007734 12461526004 022375 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; eval { require Test::WWW::Mechanize::Catalyst; Test::WWW::Mechanize::Catalyst->VERSION(0.51); } or plan skip_all => 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; } use lib "t/lib"; use Test::WWW::Mechanize::Catalyst "SessionTestApp"; my $ua1 = Test::WWW::Mechanize::Catalyst->new; my $ua2 = Test::WWW::Mechanize::Catalyst->new; $_->get_ok( "http://localhost/page", "initial get" ) for $ua1, $ua2; $ua1->content_contains( "please login", "ua1 not logged in" ); $ua2->content_contains( "please login", "ua2 not logged in" ); $ua1->get_ok( "http://localhost/login", "log ua1 in" ); $ua1->content_contains( "logged in", "ua1 logged in" ); $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; $ua1->content_contains( "you are logged in", "ua1 logged in" ); $ua2->content_contains( "please login", "ua2 not logged in" ); $ua2->get_ok( "http://localhost/login", "get main page" ); $ua2->content_contains( "logged in", "log ua2 in" ); $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; $ua1->content_contains( "you are logged in", "ua1 logged in" ); $ua2->content_contains( "you are logged in", "ua2 logged in" ); my ( $u1_expires ) = ($ua1->content =~ /(\d+)$/); my ( $u2_expires ) = ($ua2->content =~ /(\d+)$/); sleep 1; $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; $ua1->content_contains( "you are logged in", "ua1 logged in" ); $ua2->content_contains( "you are logged in", "ua2 logged in" ); my ( $u1_expires_updated ) = ($ua1->content =~ /(\d+)$/); my ( $u2_expires_updated ) = ($ua2->content =~ /(\d+)$/); cmp_ok( $u1_expires, "<", $u1_expires_updated, "expiry time updated"); cmp_ok( $u2_expires, "<", $u2_expires_updated, "expiry time updated"); $ua2->get_ok( "http://localhost/logout", "log ua2 out" ); $ua2->content_like( qr/logged out/, "ua2 logged out" ); $ua2->content_like( qr/after 2 request/, "ua2 made 2 requests for page in the session" ); $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; $ua1->content_contains( "you are logged in", "ua1 logged in" ); $ua2->content_contains( "please login", "ua2 not logged in" ); $ua1->get_ok( "http://localhost/logout", "log ua1 out" ); $ua1->content_like( qr/logged out/, "ua1 logged out" ); $ua1->content_like( qr/after 4 requests/, "ua1 made 4 request for page in the session" ); $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; $ua1->content_contains( "please login", "ua1 not logged in" ); $ua2->content_contains( "please login", "ua2 not logged in" ); my $ua3 = Test::WWW::Mechanize::Catalyst->new; $ua3->get_ok( "http://localhost/login", "log ua3 in" ); $ua3->get_ok( "http://localhost/dump_these_loads_session"); $ua3->content_contains('NOT'); my $ua4 = Test::WWW::Mechanize::Catalyst->new; $ua4->get_ok( "http://localhost/page", "initial get" ); $ua4->content_contains( "please login", "ua4 not logged in" ); $ua4->get_ok( "http://localhost/login", "log ua4 in" ); $ua4->content_contains( "logged in", "ua4 logged in" ); $ua4->get( "http://localhost/page", "get page" ); my ( $ua4_expires1 ) = ($ua4->content =~ /(\d+)$/); $ua4->get( "http://localhost/page", "get page" ); my ( $ua4_expires2 ) = ($ua4->content =~ /(\d+)$/); is( $ua4_expires1, $ua4_expires2, 'expires has not changed' ); $ua4->get( "http://localhost/change_session_expires", "get page" ); $ua4->get( "http://localhost/page", "get page" ); my ( $ua4_expires3 ) = ($ua4->content =~ /(\d+)$/); ok( $ua4_expires3 > ( $ua4_expires1 + 30000000), 'expires has been extended' ); diag("Testing against Catalyst $Catalyst::VERSION"); diag("Testing Catalyst::Plugin::Session $Catalyst::Plugin::Session::VERSION"); done_testing; Catalyst-Plugin-Session-0.40/t/live_expiry_threshold.t000644 000765 000024 00000004522 12461526004 025201 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; eval { require Test::WWW::Mechanize::Catalyst; Test::WWW::Mechanize::Catalyst->VERSION(0.51); } or plan skip_all => 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; } use lib "t/lib"; use Test::WWW::Mechanize::Catalyst "SessionExpiry"; my $ua = Test::WWW::Mechanize::Catalyst->new; my $res = $ua->get( "http://localhost/session_data_expires" ); ok($res->is_success, "session_data_expires"); my $expiry = $res->decoded_content + 0; $res = $ua->get( "http://localhost/session_expires" ); ok($res->is_success, "session_expires"); is($res->decoded_content, $expiry, "session_expires == session_data_expires"); sleep(1); $res = $ua->get( "http://localhost/session_data_expires" ); ok($res->is_success, "session_data_expires"); is($res->decoded_content, $expiry, "expiration not updated"); $res = $ua->get( "http://localhost/session_expires" ); ok($res->is_success, "session_expires"); is($res->decoded_content, $expiry, "session_expires == session_data_expires"); # $res = $ua->get( "http://localhost/update_session" ); ok($res->is_success, "update_session"); $res = $ua->get( "http://localhost/session_data_expires" ); ok($res->is_success, "session_data_expires"); my $updated = $res->decoded_content + 0; ok($updated > $expiry, "expiration updated"); $expiry = $updated; $res = $ua->get( "http://localhost/session_data_expires" ); ok($res->is_success, "session_data_expires"); is($res->decoded_content, $expiry, "expiration not updated"); $res = $ua->get( "http://localhost/session_expires" ); ok($res->is_success, "session_expires"); is($res->decoded_content, $expiry, "session_expires == session_data_expires"); sleep(10); $res = $ua->get( "http://localhost/session_data_expires" ); ok($res->is_success, "session_data_expires"); $updated = $res->decoded_content + 0; ok($updated > $expiry, "expiration updated"); $res = $ua->get( "http://localhost/session_expires" ); ok($res->is_success, "session_expires"); is($res->decoded_content, $updated, "session_expires == session_data_expires"); done_testing; Catalyst-Plugin-Session-0.40/t/live_session_fixation.t000644 000765 000024 00000006136 12461526004 025174 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use Data::Dumper; BEGIN { eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; eval { require Test::WWW::Mechanize::Catalyst; Test::WWW::Mechanize::Catalyst->VERSION(0.51); } or plan skip_all => 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; plan tests => 10; } use lib "t/lib"; use Test::WWW::Mechanize::Catalyst "SessionTestApp"; #try completely random cookie unknown for our application; should be rejected my $cookie_name = 'sessiontestapp_session'; my $cookie_value = '89c3a019866af6f5a305e10189fbb23df3f4772c'; my ( @injected_cookie ) = ( 1, $cookie_name , $cookie_value ,'/', undef, 0, undef, undef, undef, {} ); my $injected_cookie_str = "${cookie_name}=${cookie_value}"; my $ua1 = Test::WWW::Mechanize::Catalyst->new; $ua1->cookie_jar->set_cookie( @injected_cookie ); my $res = $ua1->get( "http://localhost/login" ); my $cookie1 = $res->header('Set-Cookie'); ok $cookie1, "Set-Cookie 1"; isnt $cookie1, qr/$injected_cookie_str/, "Logging in generates us a new cookie"; $ua1->get( "http://localhost/get_sessid" ); my $sid1 = $ua1->content; #set session variable var1 before session id change $ua1->get( "http://localhost/set_session_variable/var1/set_before_change"); $ua1->get( "http://localhost/get_session_variable/var1"); $ua1->content_is("VAR_var1=set_before_change"); #just diagnostic dump $ua1->get( "http://localhost/dump_session" ); #diag "Before-change:".$ua1->content; #change session id; all session data should be kept; old session id invalidated my $res2 = $ua1->get( "http://localhost/change_sessid" ); my $cookie2 = $res2->header('Set-Cookie'); ok $cookie2, "Set-Cookie 2"; isnt $cookie2, $cookie1, "Cookie changed"; $ua1->get( "http://localhost/get_sessid" ); my $sid2 = $ua1->content; isnt $sid2, $sid1, 'SID changed'; #just diagnostic dump $ua1->get( "http://localhost/dump_session" ); #diag "After-change:".$ua1->content; #set session variable var2 after session id change $ua1->get( "http://localhost/set_session_variable/var2/set_after_change"); #check if var1 and var2 contain expected values $ua1->get( "http://localhost/get_session_variable/var1"); $ua1->content_is("VAR_var1=set_before_change"); $ua1->get( "http://localhost/get_session_variable/var2"); $ua1->content_is("VAR_var2=set_after_change"); #just diagnostic dump $ua1->get( "http://localhost/dump_session" ); #diag "End1:".$ua1->content; #try to use old cookie value (before session_id_change) my $ua2 = Test::WWW::Mechanize::Catalyst->new; $ua2->cookie_jar->set_cookie( @injected_cookie ); #if we take old cookie we should not be able to get any old session data $ua2->get( "http://localhost/get_session_variable/var1"); $ua2->content_is("VAR_var1=n.a."); $ua2->get( "http://localhost/get_session_variable/var2"); $ua2->content_is("VAR_var2=n.a."); #just diagnostic dump $ua2->get( "http://localhost/dump_session" ); #diag "End2:".$ua2->content; Catalyst-Plugin-Session-0.40/t/live_verify_address.t000644 000765 000024 00000003455 12461526004 024622 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; eval { require Test::WWW::Mechanize::PSGI; #Test::WWW::Mechanize::Catalyst->VERSION(0.51); } or plan skip_all => 'Test::WWW::Mechanize::PSGI is required for this test'; eval { require Catalyst::Plugin::Authentication; 1 } or plan skip_all => "Catalyst::Plugin::Authentication is required for this test"; plan tests => 12; } use lib "t/lib"; use Test::WWW::Mechanize::PSGI; use SessionTestApp; my $ua = Test::WWW::Mechanize::PSGI->new( app => SessionTestApp->psgi_app(@_), cookie_jar => {} ); # Test without delete __address local $ENV{REMOTE_ADDR} = "192.168.1.1"; $ua->get_ok( "http://localhost/login" ); $ua->content_contains('logged in'); $ua->get_ok( "http://localhost/set_session_variable/logged/in" ); $ua->content_contains('session variable set'); # Change Client use Plack::Builder; my $app = SessionTestApp->psgi_app(@_); my $ua2 = Test::WWW::Mechanize::PSGI->new( app => $app, cookie_jar => {} ); $ua2->get_ok( "http://localhost/get_session_variable/logged"); $ua2->content_contains('VAR_logged=n.a.'); # Inital Client local $ENV{REMOTE_ADDR} = "192.168.1.1"; $ua->get_ok( "http://localhost/login_without_address" ); $ua->content_contains('logged in (without address)'); $ua->get_ok( "http://localhost/set_session_variable/logged/in" ); $ua->content_contains('session variable set'); # Change Client local $ENV{REMOTE_ADDR} = "192.168.1.2"; $ua->get_ok( "http://localhost/get_session_variable/logged" ); $ua->content_contains('VAR_logged=in'); Catalyst-Plugin-Session-0.40/t/live_verify_user_agent.t000644 000765 000024 00000002760 12461526004 025327 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; eval { require Test::WWW::Mechanize::Catalyst; Test::WWW::Mechanize::Catalyst->VERSION(0.51); } or plan skip_all => 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; plan tests => 12; } use lib "t/lib"; use Test::WWW::Mechanize::Catalyst "SessionTestApp"; my $ua = Test::WWW::Mechanize::Catalyst->new( { agent => 'Initial user_agent'} ); $ua->get_ok( "http://localhost/user_agent", "get initial user_agent" ); $ua->content_contains( "UA=Initial user_agent", "test initial user_agent" ); $ua->get_ok( "http://localhost/page", "initial get main page" ); $ua->content_contains( "please login", "ua not logged in" ); $ua->get_ok( "http://localhost/login", "log ua in" ); $ua->content_contains( "logged in", "ua logged in" ); $ua->get_ok( "http://localhost/page", "get main page" ); $ua->content_contains( "you are logged in", "ua logged in" ); $ua->agent('Changed user_agent'); $ua->get_ok( "http://localhost/user_agent", "get changed user_agent" ); $ua->content_contains( "UA=Changed user_agent", "test changed user_agent" ); $ua->get_ok( "http://localhost/page", "test deleted session" ); $ua->content_contains( "please login", "ua not logged in" ); Catalyst-Plugin-Session-0.40/t/session_valid.t000644 000765 000024 00000001730 12461526004 023426 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; eval { require Test::WWW::Mechanize::Catalyst; Test::WWW::Mechanize::Catalyst->VERSION(0.51); } or plan skip_all => 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; plan tests => 4; } use FindBin qw/$Bin/; use lib "$Bin/lib"; use Test::WWW::Mechanize::Catalyst "SessionValid"; my $ua = Test::WWW::Mechanize::Catalyst->new; $ua->get_ok( "http://localhost/", "initial get" ); $ua->content_contains( "value set", "page contains expected value" ); sleep 2; $ua->get_ok( "http://localhost/", "grab the page again, after the session has expired" ); $ua->content_contains( "value set", "page contains expected value" ); Catalyst-Plugin-Session-0.40/t/lib/FlashTestApp/000755 000765 000024 00000000000 12461562414 023507 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/lib/FlashTestApp.pm000644 000765 000024 00000000261 12461526004 024037 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/env perl package FlashTestApp; use Catalyst qw/Session Session::Store::Dummy Session::State::Cookie/; use strict; use warnings; __PACKAGE__->setup; __PACKAGE__; Catalyst-Plugin-Session-0.40/t/lib/SessionExpiry/000755 000765 000024 00000000000 12461562414 023775 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/lib/SessionExpiry.pm000644 000765 000024 00000000456 12461526004 024333 0ustar00jnapiorkowskistaff000000 000000 package SessionExpiry; use Catalyst qw/Session Session::Store::Dummy Session::State::Cookie Authentication/; use strict; use warnings; __PACKAGE__->config( 'Plugin::Session' => { expires => 20, expiry_threshold => 10, }, ); __PACKAGE__->setup; __PACKAGE__; Catalyst-Plugin-Session-0.40/t/lib/SessionTestApp/000755 000765 000024 00000000000 12461562414 024075 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/lib/SessionTestApp.pm000644 000765 000024 00000001670 12461526004 024432 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/env perl package SessionTestApp; use Catalyst qw/Session Session::Store::Dummy Session::State::Cookie Authentication/; use strict; use warnings; __PACKAGE__->config('Plugin::Session' => { # needed for live_verify_user_agent.t; should be harmless for other tests verify_user_agent => 1, verify_address => 1, }, 'Plugin::Authentication' => { default => { credential => { class => 'Password', password_field => 'password', password_type => 'clear' }, store => { class => 'Minimal', users => { bob => { password => "s00p3r", }, william => { password => "s3cr3t", }, }, }, }, }, ); __PACKAGE__->setup; __PACKAGE__; Catalyst-Plugin-Session-0.40/t/lib/SessionValid/000755 000765 000024 00000000000 12461562414 023554 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/lib/SessionValid.pm000644 000765 000024 00000000367 12461526004 024113 0ustar00jnapiorkowskistaff000000 000000 package SessionValid; use Catalyst qw/Session Session::Store::Dummy Session::State::Cookie/; use strict; use warnings; __PACKAGE__->config('Plugin::Session' => { cookie_expires => 0, expires => 1, }); __PACKAGE__->setup; __PACKAGE__; Catalyst-Plugin-Session-0.40/t/lib/SessionValid/Controller/000755 000765 000024 00000000000 12461562414 025677 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/lib/SessionValid/Controller/Root.pm000644 000765 000024 00000000470 12461526004 027154 0ustar00jnapiorkowskistaff000000 000000 package SessionValid::Controller::Root; use strict; use warnings; use base qw/Catalyst::Controller/; __PACKAGE__->config( namespace => '' ); sub index :Path :Args(0) { my ( $self, $c ) = @_; $c->session('value' => 'value set'); $c->session_is_valid; $c->res->body($c->session->{value}); } 1; Catalyst-Plugin-Session-0.40/t/lib/SessionTestApp/Controller/000755 000765 000024 00000000000 12461562414 026220 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/lib/SessionTestApp/Controller/Root.pm000644 000765 000024 00000005564 12461526004 027506 0ustar00jnapiorkowskistaff000000 000000 package SessionTestApp::Controller::Root; use strict; use warnings; use Data::Dumper; use base qw/Catalyst::Controller/; __PACKAGE__->config( namespace => '' ); sub login : Global { my ( $self, $c ) = @_; $c->session; $c->res->output("logged in"); } sub login_without_address : Global { my ( $self, $c ) = @_; $c->session; $c->log->debug($c->request->address); delete $c->session->{__address}; $c->res->output("logged in (without address)"); } sub logout : Global { my ( $self, $c ) = @_; $c->res->output( "logged out after " . $c->session->{counter} . " requests" ); $c->delete_session("logout"); } sub logout_redirect : Global { my ( $self, $c ) = @_; $c->logout; $c->res->output("redirect from here"); $c->res->redirect( $c->uri_for('from_logout_redirect') ); } sub from_logout_redirect : Global { my ( $self, $c ) = @_; $c->res->output( "got here from logout_redirect" ); } sub set_session_variable : Global { my ( $self, $c, $var, $val ) = @_; $c->session->{$var} = $val; $c->res->output("session variable set"); } sub get_session_variable : Global { my ( $self, $c, $var ) = @_; my $val = $c->session->{$var} || 'n.a.'; $c->res->output("VAR_$var=$val"); } sub get_sessid : Global { my ( $self, $c ) = @_; my $sid = $c->sessionid || 'n.a.'; $c->res->output("SID=$sid"); } sub dump_session : Global { my ( $self, $c ) = @_; my $sid = $c->sessionid || 'n.a.'; my $dump = Dumper($c->session || 'n.a.'); $c->res->output("[SID=$sid]\n$dump"); } sub change_sessid : Global { my ( $self, $c ) = @_; $c->change_session_id; $c->res->output("session id changed"); } sub page : Global { my ( $self, $c ) = @_; if ( $c->session_is_valid ) { $c->res->output("you are logged in, session expires at " . $c->session_expires); $c->session->{counter}++; } else { $c->res->output("please login"); } } sub user_agent : Global { my ( $self, $c ) = @_; $c->res->output('UA=' . $c->req->user_agent); } sub accessor_test : Global { my ( $self, $c ) = @_; $c->session( one => 1, two => 2, ); $c->session( { three => 3, four => 4, }, ); $c->session->{five} = 5; for my $key (keys %{ $c->session }) { $c->res->write("$key: " . $c->session->{$key} . "\n"); } } sub dump_these_loads_session : Global { my ($self, $c) = @_; $c->dump_these(); if ($c->_session) { $c->res->write('LOADED') } else { $c->res->write('NOT'); } } sub change_session_expires : Global { my ($self, $c) = @_; $c->change_session_expires(31536000); $c->res->output($c->session_expires); } sub reset_session_expires : Global { my ($self, $c) = @_; $c->reset_session_expires; $c->res->output($c->session_expires); } 1; Catalyst-Plugin-Session-0.40/t/lib/SessionExpiry/Controller/000755 000765 000024 00000000000 12461562414 026120 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/lib/SessionExpiry/Controller/Root.pm000644 000765 000024 00000001200 12461526004 027365 0ustar00jnapiorkowskistaff000000 000000 package SessionExpiry::Controller::Root; use strict; use warnings; use base qw/Catalyst::Controller/; __PACKAGE__->config( namespace => '' ); sub session_data_expires : Global { my ( $self, $c ) = @_; $c->session; if (my $sid = $c->sessionid) { $c->finalize_headers(); # force expiration to be updated $c->res->output($c->get_session_data("expires:$sid")); } } sub session_expires : Global { my ($self, $c) = @_; $c->session; $c->res->output($c->session_expires); } sub update_session : Global { my ($self, $c) = @_; $c->session->{foo} ++; $c->res->output($c->session->{foo}); } Catalyst-Plugin-Session-0.40/t/lib/FlashTestApp/Controller/000755 000765 000024 00000000000 12461562414 025632 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/t/lib/FlashTestApp/Controller/Root.pm000644 000765 000024 00000002163 12461526004 027110 0ustar00jnapiorkowskistaff000000 000000 package FlashTestApp::Controller::Root; use strict; use warnings; use Data::Dumper; use base qw/Catalyst::Controller/; __PACKAGE__->config( namespace => '' ); no warnings 'uninitialized'; sub default : Private { my ($self, $c) = @_; $c->session; } sub first : Global { my ( $self, $c ) = @_; if ( ! $c->flash->{is_set}) { $c->stash->{message} = "flash is not set"; $c->flash->{is_set} = 1; } } sub second : Global { my ( $self, $c ) = @_; if ($c->flash->{is_set} == 1){ $c->stash->{message} = "flash set first time"; $c->flash->{is_set}++; } } sub third : Global { my ( $self, $c ) = @_; if ($c->flash->{is_set} == 2) { $c->stash->{message} = "flash set second time"; $c->keep_flash("is_set"); } } sub fourth : Global { my ( $self, $c ) = @_; if ($c->flash->{is_set} == 2) { $c->stash->{message} = "flash set 3rd time, same val as prev." } } sub fifth : Global { my ( $self, $c ) = @_; $c->forward('/first'); } sub end : Private { my ($self, $c) = @_; $c->res->output($c->stash->{message}); } 1; Catalyst-Plugin-Session-0.40/t/author/pod.t000644 000765 000024 00000000276 12461526004 022654 0ustar00jnapiorkowskistaff000000 000000 use Test::More; eval "use Test::Pod 1.14"; plan skip_all => 'Test::Pod 1.14 required' if $@; plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; all_pod_files_ok(); Catalyst-Plugin-Session-0.40/t/author/podcoverage.t000644 000765 000024 00000000325 12461526004 024363 0ustar00jnapiorkowskistaff000000 000000 use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; all_pod_coverage_ok(); Catalyst-Plugin-Session-0.40/lib/Catalyst/000755 000765 000024 00000000000 12461562414 022472 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/000755 000765 000024 00000000000 12461562414 023730 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session/000755 000765 000024 00000000000 12461562414 025353 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session.pm000644 000765 000024 00000074537 12461562151 025727 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Session; use Moose; with 'MooseX::Emulate::Class::Accessor::Fast'; use MRO::Compat; use Catalyst::Exception (); use Digest (); use overload (); use Object::Signature (); use Carp; use List::Util qw/ max /; use namespace::clean -except => 'meta'; our $VERSION = '0.40'; $VERSION = eval $VERSION; my @session_data_accessors; # used in delete_session __PACKAGE__->mk_accessors( "_session_delete_reason", @session_data_accessors = qw/ _sessionid _session _session_expires _extended_session_expires _session_data_sig _flash _flash_keep_keys _flash_key_hashes _tried_loading_session_id _tried_loading_session_data _tried_loading_session_expires _tried_loading_flash_data _needs_early_session_finalization / ); sub _session_plugin_config { my $c = shift; # FIXME - Start warning once all the state/store modules have also been updated. #$c->log->warn("Deprecated 'session' config key used, please use the key 'Plugin::Session' instead") # if exists $c->config->{session} #$c->config->{'Plugin::Session'} ||= delete($c->config->{session}) || {}; $c->config->{'Plugin::Session'} ||= $c->config->{session} || {}; } sub setup { my $c = shift; $c->maybe::next::method(@_); $c->check_session_plugin_requirements; $c->setup_session; return $c; } sub check_session_plugin_requirements { my $c = shift; unless ( $c->isa("Catalyst::Plugin::Session::State") && $c->isa("Catalyst::Plugin::Session::Store") ) { my $err = ( "The Session plugin requires both Session::State " . "and Session::Store plugins to be used as well." ); $c->log->fatal($err); Catalyst::Exception->throw($err); } } sub setup_session { my $c = shift; my $cfg = $c->_session_plugin_config; %$cfg = ( expires => 7200, verify_address => 0, verify_user_agent => 0, expiry_threshold => 0, %$cfg, ); $c->maybe::next::method(); } sub prepare_action { my $c = shift; $c->maybe::next::method(@_); if ( $c->_session_plugin_config->{flash_to_stash} and $c->sessionid and my $flash_data = $c->flash ) { @{ $c->stash }{ keys %$flash_data } = values %$flash_data; } } sub finalize_headers { my $c = shift; # fix cookie before we send headers $c->_save_session_expires; # Force extension of session_expires before finalizing headers, so a pos # up to date. First call to session_expires will extend the expiry, subs # just return the previously extended value. $c->session_expires; $c->finalize_session if $c->_needs_early_session_finalization; return $c->maybe::next::method(@_); } sub finalize_body { my $c = shift; # We have to finalize our session *before* $c->engine->finalize_xxx is called, # because we do not want to send the HTTP response before the session is stored/committed to # the session database (or whatever Session::Store you use). $c->finalize_session unless $c->_needs_early_session_finalization; $c->_clear_session_instance_data; return $c->maybe::next::method(@_); } sub finalize_session { my $c = shift; $c->maybe::next::method(@_); $c->_save_session_id; $c->_save_session; $c->_save_flash; } sub _session_updated { my $c = shift; if ( my $session_data = $c->_session ) { no warnings 'uninitialized'; if ( Object::Signature::signature($session_data) ne $c->_session_data_sig ) { return $session_data; } else { return; } } else { return; } } sub _save_session_id { my $c = shift; # we already called set when allocating # no need to tell the state plugins anything new } sub _save_session_expires { my $c = shift; if ( defined($c->_session_expires) ) { if (my $sid = $c->sessionid) { my $current = $c->_get_stored_session_expires; my $extended = $c->session_expires; if ($extended > $current) { $c->store_session_data( "expires:$sid" => $extended ); } } } } sub _save_session { my $c = shift; if ( my $session_data = $c->_session_updated ) { $session_data->{__updated} = time(); my $sid = $c->sessionid; $c->store_session_data( "session:$sid" => $session_data ); } } sub _save_flash { my $c = shift; if ( my $flash_data = $c->_flash ) { my $hashes = $c->_flash_key_hashes || {}; my $keep = $c->_flash_keep_keys || {}; foreach my $key ( keys %$hashes ) { if ( !exists $keep->{$key} and Object::Signature::signature( \$flash_data->{$key} ) eq $hashes->{$key} ) { delete $flash_data->{$key}; } } my $sid = $c->sessionid; my $session_data = $c->_session; if (%$flash_data) { $session_data->{__flash} = $flash_data; } else { delete $session_data->{__flash}; } $c->_session($session_data); $c->_save_session; } } sub _load_session_expires { my $c = shift; return $c->_session_expires if $c->_tried_loading_session_expires; $c->_tried_loading_session_expires(1); if ( my $sid = $c->sessionid ) { my $expires = $c->_get_stored_session_expires; if ( $expires >= time() ) { $c->_session_expires( $expires ); return $expires; } else { $c->delete_session( "session expired" ); return 0; } } return; } sub _load_session { my $c = shift; return $c->_session if $c->_tried_loading_session_data; $c->_tried_loading_session_data(1); if ( my $sid = $c->sessionid ) { if ( $c->_load_session_expires ) { # > 0 my $session_data = $c->get_session_data("session:$sid") || return; $c->_session($session_data); no warnings 'uninitialized'; # ne __address if ( $c->_session_plugin_config->{verify_address} && exists $session_data->{__address} && $session_data->{__address} ne $c->request->address ) { $c->log->warn( "Deleting session $sid due to address mismatch (" . $session_data->{__address} . " != " . $c->request->address . ")" ); $c->delete_session("address mismatch"); return; } if ( $c->_session_plugin_config->{verify_user_agent} && $session_data->{__user_agent} ne $c->request->user_agent ) { $c->log->warn( "Deleting session $sid due to user agent mismatch (" . $session_data->{__user_agent} . " != " . $c->request->user_agent . ")" ); $c->delete_session("user agent mismatch"); return; } $c->log->debug(qq/Restored session "$sid"/) if $c->debug; $c->_session_data_sig( Object::Signature::signature($session_data) ) if $session_data; $c->_expire_session_keys; return $session_data; } } return; } sub _load_flash { my $c = shift; return $c->_flash if $c->_tried_loading_flash_data; $c->_tried_loading_flash_data(1); if ( my $sid = $c->sessionid ) { my $session_data = $c->session; $c->_flash($session_data->{__flash}); if ( my $flash_data = $c->_flash ) { $c->_flash_key_hashes({ map { $_ => Object::Signature::signature( \$flash_data->{$_} ) } keys %$flash_data }); return $flash_data; } } return; } sub _expire_session_keys { my ( $c, $data ) = @_; my $now = time; my $expire_times = ( $data || $c->_session || {} )->{__expire_keys} || {}; foreach my $key ( grep { $expire_times->{$_} < $now } keys %$expire_times ) { delete $c->_session->{$key}; delete $expire_times->{$key}; } } sub _clear_session_instance_data { my $c = shift; $c->$_(undef) for @session_data_accessors; $c->maybe::next::method(@_); # allow other plugins to hook in on this } sub change_session_id { my $c = shift; my $sessiondata = $c->session; my $oldsid = $c->sessionid; my $newsid = $c->create_session_id; if ($oldsid) { $c->log->debug(qq/change_sessid: deleting session data from "$oldsid"/) if $c->debug; $c->delete_session_data("${_}:${oldsid}") for qw/session expires flash/; } $c->log->debug(qq/change_sessid: storing session data to "$newsid"/) if $c->debug; $c->store_session_data( "session:$newsid" => $sessiondata ); return $newsid; } sub delete_session { my ( $c, $msg ) = @_; $c->log->debug("Deleting session" . ( defined($msg) ? "($msg)" : '(no reason given)') ) if $c->debug; # delete the session data if ( my $sid = $c->sessionid ) { $c->delete_session_data("${_}:${sid}") for qw/session expires flash/; $c->delete_session_id($sid); } # reset the values in the context object # see the BEGIN block $c->_clear_session_instance_data; $c->_session_delete_reason($msg); } sub session_delete_reason { my $c = shift; $c->session_is_valid; # check that it was loaded $c->_session_delete_reason(@_); } sub session_expires { my $c = shift; if ( defined( my $expires = $c->_extended_session_expires ) ) { return $expires; } elsif ( defined( $expires = $c->_load_session_expires ) ) { return $c->extend_session_expires( $expires ); } else { return 0; } } sub extend_session_expires { my ( $c, $expires ) = @_; my $threshold = $c->_session_plugin_config->{expiry_threshold} || 0; if ( my $sid = $c->sessionid ) { my $expires = $c->_get_stored_session_expires; my $cutoff = $expires - $threshold; if (!$threshold || $cutoff <= time || $c->_session_updated) { $c->_extended_session_expires( my $updated = $c->calculate_initial_session_expires() ); $c->extend_session_id( $sid, $updated ); return $updated; } else { return $expires; } } else { return; } } sub change_session_expires { my ( $c, $expires ) = @_; $expires ||= 0; my $sid = $c->sessionid; my $time_exp = time() + $expires; $c->store_session_data( "expires:$sid" => $time_exp ); } sub _get_stored_session_expires { my ($c) = @_; if ( my $sid = $c->sessionid ) { return $c->get_session_data("expires:$sid") || 0; } else { return 0; } } sub initial_session_expires { my $c = shift; return ( time() + $c->_session_plugin_config->{expires} ); } sub calculate_initial_session_expires { my ($c) = @_; return max( $c->initial_session_expires, $c->_get_stored_session_expires ); } sub calculate_extended_session_expires { my ( $c, $prev ) = @_; return ( time() + $prev ); } sub reset_session_expires { my ( $c, $sid ) = @_; my $exp = $c->calculate_initial_session_expires; $c->_session_expires( $exp ); # # since we're setting _session_expires directly, make load_session_expires # actually use that value. # $c->_tried_loading_session_expires(1); $c->_extended_session_expires( $exp ); $exp; } sub sessionid { my $c = shift; return $c->_sessionid || $c->_load_sessionid; } sub _load_sessionid { my $c = shift; return if $c->_tried_loading_session_id; $c->_tried_loading_session_id(1); if ( defined( my $sid = $c->get_session_id ) ) { if ( $c->validate_session_id($sid) ) { # temporarily set the inner key, so that validation will work $c->_sessionid($sid); return $sid; } else { my $err = "Tried to set invalid session ID '$sid'"; $c->log->error($err); Catalyst::Exception->throw($err); } } return; } sub session_is_valid { my $c = shift; # force a check for expiry, but also __address, etc if ( $c->_load_session ) { return 1; } else { return; } } sub validate_session_id { my ( $c, $sid ) = @_; $sid and $sid =~ /^[a-f\d]+$/i; } sub session { my $c = shift; my $session = $c->_session || $c->_load_session || do { $c->create_session_id_if_needed; $c->initialize_session_data; }; if (@_) { my $new_values = @_ > 1 ? { @_ } : $_[0]; croak('session takes a hash or hashref') unless ref $new_values; for my $key (keys %$new_values) { $session->{$key} = $new_values->{$key}; } } $session; } sub keep_flash { my ( $c, @keys ) = @_; my $href = $c->_flash_keep_keys || $c->_flash_keep_keys({}); (@{$href}{@keys}) = ((undef) x @keys); } sub _flash_data { my $c = shift; $c->_flash || $c->_load_flash || do { $c->create_session_id_if_needed; $c->_flash( {} ); }; } sub _set_flash { my $c = shift; if (@_) { my $items = @_ > 1 ? {@_} : $_[0]; croak('flash takes a hash or hashref') unless ref $items; @{ $c->_flash }{ keys %$items } = values %$items; } } sub flash { my $c = shift; $c->_flash_data; $c->_set_flash(@_); return $c->_flash; } sub clear_flash { my $c = shift; #$c->delete_session_data("flash:" . $c->sessionid); # should this be in here? or delayed till finalization? $c->_flash_key_hashes({}); $c->_flash_keep_keys({}); $c->_flash({}); } sub session_expire_key { my ( $c, %keys ) = @_; my $now = time; @{ $c->session->{__expire_keys} }{ keys %keys } = map { $now + $_ } values %keys; } sub initialize_session_data { my $c = shift; my $now = time; return $c->_session( { __created => $now, __updated => $now, ( $c->_session_plugin_config->{verify_address} ? ( __address => $c->request->address||'' ) : () ), ( $c->_session_plugin_config->{verify_user_agent} ? ( __user_agent => $c->request->user_agent||'' ) : () ), } ); } sub generate_session_id { my $c = shift; my $digest = $c->_find_digest(); $digest->add( $c->session_hash_seed() ); return $digest->hexdigest; } sub create_session_id_if_needed { my $c = shift; $c->create_session_id unless $c->sessionid; } sub create_session_id { my $c = shift; my $sid = $c->generate_session_id; $c->log->debug(qq/Created session "$sid"/) if $c->debug; $c->_sessionid($sid); $c->reset_session_expires; $c->set_session_id($sid); return $sid; } my $counter; sub session_hash_seed { my $c = shift; return join( "", ++$counter, time, rand, $$, {}, overload::StrVal($c), ); } my $usable; sub _find_digest () { unless ($usable) { foreach my $alg (qw/SHA-1 SHA-256 MD5/) { if ( eval { Digest->new($alg) } ) { $usable = $alg; last; } } Catalyst::Exception->throw( "Could not find a suitable Digest module. Please install " . "Digest::SHA1, Digest::SHA, or Digest::MD5" ) unless $usable; } return Digest->new($usable); } sub dump_these { my $c = shift; ( $c->maybe::next::method(), $c->_sessionid ? ( [ "Session ID" => $c->sessionid ], [ Session => $c->session ], ) : () ); } sub get_session_id { shift->maybe::next::method(@_) } sub set_session_id { shift->maybe::next::method(@_) } sub delete_session_id { shift->maybe::next::method(@_) } sub extend_session_id { shift->maybe::next::method(@_) } __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Session - Generic Session plugin - ties together server side storage and client side state required to maintain session data. =head1 SYNOPSIS # To get sessions to "just work", all you need to do is use these plugins: use Catalyst qw/ Session Session::Store::FastMmap Session::State::Cookie /; # you can replace Store::FastMmap with Store::File - both have sensible # default configurations (see their docs for details) # more complicated backends are available for other scenarios (DBI storage, # etc) # after you've loaded the plugins you can save session data # For example, if you are writing a shopping cart, it could be implemented # like this: sub add_item : Local { my ( $self, $c ) = @_; my $item_id = $c->req->param("item"); # $c->session is a hash ref, a bit like $c->stash # the difference is that it' preserved across requests push @{ $c->session->{items} }, $item_id; $c->forward("MyView"); } sub display_items : Local { my ( $self, $c ) = @_; # values in $c->session are restored $c->stash->{items_to_display} = [ map { MyModel->retrieve($_) } @{ $c->session->{items} } ]; $c->forward("MyView"); } =head1 DESCRIPTION The Session plugin is the base of two related parts of functionality required for session management in web applications. The first part, the State, is getting the browser to repeat back a session key, so that the web application can identify the client and logically string several requests together into a session. The second part, the Store, deals with the actual storage of information about the client. This data is stored so that the it may be revived for every request made by the same client. This plugin links the two pieces together. =head1 RECOMENDED BACKENDS =over 4 =item Session::State::Cookie The only really sane way to do state is using cookies. =item Session::Store::File A portable backend, based on Cache::File. =item Session::Store::FastMmap A fast and flexible backend, based on Cache::FastMmap. =back =head1 METHODS =over 4 =item sessionid An accessor for the session ID value. =item session Returns a hash reference that might contain unserialized values from previous requests in the same session, and whose modified value will be saved for future requests. This method will automatically create a new session and session ID if none exists. You can also set session keys by passing a list of key/value pairs or a hashref. $c->session->{foo} = "bar"; # This works. $c->session(one => 1, two => 2); # And this. $c->session({ answer => 42 }); # And this. =item session_expires This method returns the time when the current session will expire, or 0 if there is no current session. If there is a session and it already expired, it will delete the session and return 0 as well. =item flash This is like Ruby on Rails' flash data structure. Think of it as a stash that lasts for longer than one request, letting you redirect instead of forward. The flash data will be cleaned up only on requests on which actually use $c->flash (thus allowing multiple redirections), and the policy is to delete all the keys which haven't changed since the flash data was loaded at the end of every request. Note that use of the flash is an easy way to get data across requests, but it's also strongly disrecommended, due it it being inherently plagued with race conditions. This means that it's unlikely to work well if your users have multiple tabs open at once, or if your site does a lot of AJAX requests. L is the recommended alternative solution, as this doesn't suffer from these issues. sub moose : Local { my ( $self, $c ) = @_; $c->flash->{beans} = 10; $c->response->redirect( $c->uri_for("foo") ); } sub foo : Local { my ( $self, $c ) = @_; my $value = $c->flash->{beans}; # ... $c->response->redirect( $c->uri_for("bar") ); } sub bar : Local { my ( $self, $c ) = @_; if ( exists $c->flash->{beans} ) { # false } } =item clear_flash Zap all the keys in the flash regardless of their current state. =item keep_flash @keys If you want to keep a flash key for the next request too, even if it hasn't changed, call C and pass in the keys as arguments. =item delete_session REASON This method is used to invalidate a session. It takes an optional parameter which will be saved in C if provided. NOTE: This method will B delete your flash data. =item session_delete_reason This accessor contains a string with the reason a session was deleted. Possible values include: =over 4 =item * C
=item * C =back =item session_expire_key $key, $ttl Mark a key to expire at a certain time (only useful when shorter than the expiry time for the whole session). For example: __PACKAGE__->config('Plugin::Session' => { expires => 10000000000 }); # "forever" (NB If this number is too large, Y2K38 breakage could result.) # later $c->session_expire_key( __user => 3600 ); Will make the session data survive, but the user will still be logged out after an hour. Note that these values are not auto extended. =item change_session_id By calling this method you can force a session id change while keeping all session data. This method might come handy when you are paranoid about some advanced variations of session fixation attack. If you want to prevent this session fixation scenario: 0) let us have WebApp with anonymous and authenticated parts 1) a hacker goes to vulnerable WebApp and gets a real sessionid, just by browsing anonymous part of WebApp 2) the hacker inserts (somehow) this values into a cookie in victim's browser 3) after the victim logs into WebApp the hacker can enter his/her session you should call change_session_id in your login controller like this: if ($c->authenticate( { username => $user, password => $pass } )) { # login OK $c->change_session_id; ... } else { # login FAILED ... } =item change_session_expires $expires You can change the session expiration time for this session; $c->change_session_expires( 4000 ); Note that this only works to set the session longer than the config setting. =back =head1 INTERNAL METHODS =over 4 =item setup This method is extended to also make calls to C and C. =item check_session_plugin_requirements This method ensures that a State and a Store plugin are also in use by the application. =item setup_session This method populates C<< $c->config('Plugin::Session') >> with the default values listed in L. =item prepare_action This method is extended. Its only effect is if the (off by default) C configuration parameter is on - then it will copy the contents of the flash to the stash at prepare time. =item finalize_headers This method is extended and will extend the expiry time before sending the response. =item finalize_body This method is extended and will call finalize_session before the other finalize_body methods run. Here we persist the session data if a session exists. =item initialize_session_data This method will initialize the internal structure of the session, and is called by the C method if appropriate. =item create_session_id Creates a new session ID using C if there is no session ID yet. =item validate_session_id SID Make sure a session ID is of the right format. This currently ensures that the session ID string is any amount of case insensitive hexadecimal characters. =item generate_session_id This method will return a string that can be used as a session ID. It is supposed to be a reasonably random string with enough bits to prevent collision. It basically takes C and hashes it using SHA-1, MD5 or SHA-256, depending on the availability of these modules. =item session_hash_seed This method is actually rather internal to generate_session_id, but should be overridable in case you want to provide more random data. Currently it returns a concatenated string which contains: =over 4 =item * A counter =item * The current time =item * One value from C. =item * The stringified value of a newly allocated hash reference =item * The stringified value of the Catalyst context object =back in the hopes that those combined values are entropic enough for most uses. If this is not the case you can replace C with e.g. sub session_hash_seed { open my $fh, "<", "/dev/random"; read $fh, my $bytes, 20; close $fh; return $bytes; } Or even more directly, replace C: sub generate_session_id { open my $fh, "<", "/dev/random"; read $fh, my $bytes, 20; close $fh; return unpack("H*", $bytes); } Also have a look at L and the various openssl bindings - these modules provide APIs for cryptographically secure random data. =item finalize_session Clean up the session during C. This clears the various accessors after saving to the store. =item dump_these See L - ammends the session data structure to the list of dumped objects if session ID is defined. =item calculate_extended_session_expires =item calculate_initial_session_expires =item create_session_id_if_needed =item delete_session_id =item extend_session_expires Note: this is *not* used to give an individual user a longer session. See 'change_session_expires'. =item extend_session_id =item get_session_id =item reset_session_expires =item session_is_valid =item set_session_id =item initial_session_expires =back =head1 USING SESSIONS DURING PREPARE The earliest point in time at which you may use the session data is after L's C has finished. State plugins must set $c->session ID before C, and during C L will actually load the data from the store. sub prepare_action { my $c = shift; # don't touch $c->session yet! $c->NEXT::prepare_action( @_ ); $c->session; # this is OK $c->sessionid; # this is also OK } =head1 CONFIGURATION $c->config('Plugin::Session' => { expires => 1234, }); All configuation parameters are provided in a hash reference under the C key in the configuration hash. =over 4 =item expires The time-to-live of each session, expressed in seconds. Defaults to 7200 (two hours). =item expiry_threshold Only update the session expiry time if it would otherwise expire within this many seconds from now. The purpose of this is to keep the session store from being updated when nothing else in the session is updated. Defaults to 0 (in which case, the expiration will always be updated). =item verify_address When true, C<< $c->request->address >> will be checked at prepare time. If it is not the same as the address that initiated the session, the session is deleted. Defaults to false. =item verify_user_agent When true, C<< $c->request->user_agent >> will be checked at prepare time. If it is not the same as the user agent that initiated the session, the session is deleted. Defaults to false. =item flash_to_stash This option makes it easier to have actions behave the same whether they were forwarded to or redirected to. On prepare time it copies the contents of C (if any) to the stash. =back =head1 SPECIAL KEYS The hash reference returned by C<< $c->session >> contains several keys which are automatically set: =over 4 =item __expires This key no longer exists. Use C instead. =item __updated The last time a session was saved to the store. =item __created The time when the session was first created. =item __address The value of C<< $c->request->address >> at the time the session was created. This value is only populated if C is true in the configuration. =item __user_agent The value of C<< $c->request->user_agent >> at the time the session was created. This value is only populated if C is true in the configuration. =back =head1 CAVEATS =head2 Round the Robin Proxies C could make your site inaccessible to users who are behind load balanced proxies. Some ISPs may give a different IP to each request by the same client due to this type of proxying. If addresses are verified these users' sessions cannot persist. To let these users access your site you can either disable address verification as a whole, or provide a checkbox in the login dialog that tells the server that it's OK for the address of the client to change. When the server sees that this box is checked it should delete the C<__address> special key from the session hash when the hash is first created. =head2 Race Conditions In this day and age where cleaning detergents and Dutch football (not the American kind) teams roam the plains in great numbers, requests may happen simultaneously. This means that there is some risk of session data being overwritten, like this: =over 4 =item 1. request a starts, request b starts, with the same session ID =item 2. session data is loaded in request a =item 3. session data is loaded in request b =item 4. session data is changed in request a =item 5. request a finishes, session data is updated and written to store =item 6. request b finishes, session data is updated and written to store, overwriting changes by request a =back For applications where any given user's session is only making one request at a time this plugin should be safe enough. =head1 AUTHORS Andy Grundman Christian Hansen Yuval Kogman, C Sebastian Riedel Tomas Doran (t0m) C (current maintainer) Sergio Salvi kmx C Florian Ragwitz (rafl) C Kent Fredric (kentnl) And countless other contributers from #catalyst. Thanks guys! =head1 Contributors Devin Austin (dhoss) Robert Rothenberg (on behalf of Foxtons Ltd.) =head1 COPYRIGHT & LICENSE Copyright (c) 2005 the aforementioned authors. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session/State.pm000644 000765 000024 00000002330 12461526004 026762 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Session::State; use strict; use warnings; __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Session::State - Base class for session state preservation plugins. =head1 SYNOPSIS package Catalyst::Plugin::Session::State::MyBackend; use base qw/Catalyst::Plugin::Session::State/; =head1 DESCRIPTION This class doesn't actually provide any functionality, but when the C module sets up it will check to see that C<< YourApp->isa("Catalyst::Plugin::Session::State") >>. When you write a session state plugin you should subclass this module this reason only. =head1 WRITING STATE PLUGINS To write a session state plugin you usually need to extend two methods: =over 4 =item prepare_(action|cookies|whatever) Set C (accessor) at B time using data in the request. Note that this must happen B other C instances, in order to get along with L. Overriding C is probably the stablest approach. =item finalize Modify the response at to include the session ID if C is defined, using whatever scheme you use. For example, set a cookie, =back =cut Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session/Store/000755 000765 000024 00000000000 12461562414 026447 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session/Store.pm000644 000765 000024 00000010125 12461561642 027006 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Session::Store; use strict; use warnings; __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Session::Store - Base class for session storage drivers. =head1 SYNOPSIS package Catalyst::Plugin::Session::Store::MyBackend; use base qw/Catalyst::Plugin::Session::Store/; =head1 DESCRIPTION This class doesn't actually provide any functionality, but when the C module sets up it will check to see that C<< YourApp->isa("Catalyst::Plugin::Session::Store") >>. When you write a session storage plugin you should subclass this module for this reason. This documentation is intended for authors of session storage plugins, not for end users. =head1 WRITING STORE PLUGINS All session storage plugins need to adhere to the following interface specification to work correctly: =head2 Required Methods =over 4 =item get_session_data $key =item store_session_data $key, $data Retrieve or store session data by key. C<$data> is currently either a hash reference (for most keys) or an integer value (for expires), but all value types should be supported. Keys are in the format C, where C is C, C, or C, and C is always the session ID. Plugins such as L store extensions to this format, such as C. It is suggested that the store should split on the colon and store the data more efficiently - the API should remain stable, with the possible addition of new prefixes in the future. For example, C maps C a column of C by special-casing C and C for that key format, in order to ease the implementation of C. The only assurance stores are required to make is that given $c->store_session_data( $x, $y ); for any $x, $y == $c->get_session_data( $x ) will hold. =item store_session_data ( $key, $data ) Store a session whose KEY is the first parameter and data is the second parameter in storage. The second parameter is a hash reference, which should normally be serialized (and later deserialized by C). =item delete_session_data ( $key ) Delete the session whose KEY is the parameter. =item delete_expired_sessions This method is not called by any code at present, but may be called in the future, as part of a Catalyst-specific maintenance script. If you are wrapping around a backend which manages its own auto expiry you can just give this method an empty body. =back =head2 Error handling All errors should be thrown using L. Return values are not checked, and are assumed to be OK. Missing values are not errors. =head2 Auto-Expiry on the Backend Storage plugins are encouraged to use C<< $c->session_expires >>, C<< $c->config('Plugin::Session' => { expires => $val }) >>, or the storage of the C key to perform more efficient expiration, but only for the key prefixes C, C and C. If the backend chooses not to do so, L will detect expired sessions as they are retrieved and delete them if necessary. Note that session store that use this approach may leak disk space, since nothing will actively delete an expired session. The C method is there so that regularly scheduled maintenance scripts can give your backend the opportunity to clean up. =head2 Early Finalization By default the main session plugin will finalize during body finalization which ensures that all controller code related to the session has completed. However some storage plugins may wish to finalize earlier, during header finalization. For example a storage that saved state in a client cookie would wish this. If a storage plugin wants to finalize early it should set $c->_needs_early_session_finalization to true. Please note that if you do this in a storage plugin, you should warn users not to attempt to change or add session keys if you use a streaming or socket interface such as $c->res->write, $c->res->write_fh or $c->req->io_fh. =cut Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session/Test/000755 000765 000024 00000000000 12461562414 026272 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session/Tutorial.pod000644 000765 000024 00000025105 12461526004 027660 0ustar00jnapiorkowskistaff000000 000000 =pod =head1 NAME Catalyst::Plugin::Session::Tutorial - Understanding and using sessions. =head1 ASSUMPTIONS This tutorial assumes that you are familiar with web applications in general and Catalyst specifically (up to models and configuration), and that you know what HTTP is. =head1 WHAT ARE SESSIONS When users use a site, especially one that knows who they are (sites you log in to, sites which let you keep a shopping cart, etc.), the server preparing the content has to know that request X comes from client A while request Y comes from client B, so that each user gets the content meant for them. The problem is that HTTP is a stateless protocol. This means that every request is distinct, and even if it comes from the same client, it's difficult to know that. The way sessions are maintained between distinct requests is that the client says, for every request, "I'm client A" or "I'm client B". This piece of data that tells the server "I'm X" is called the session ID, and the threading of several requests together is called a session. =head1 HOW SESSIONS WORK =head2 Cookies HTTP has a feature that lets this become easier, called cookies. A cookie is something the server asks the client to save somewhere, and resend every time a request is made. The way they work is that the server sends the C header, with a cookie name, a value, and some metadata (like when it expires, what paths it applies to, etc.). The client saves this. Then, on every subsequent request the client will send a C header, with the cookie name and value. =head2 Cookie Alternatives Another way is to make sure that the session ID is repeated is to include it in every URI. This can be as either a part of the path, or as a query parameter. This technique has several issues which are discussed in L. =head2 Server-Side Behavior When the server receives the session ID it can then look this key up in a database of some sort. For example the database can contain a shopping cart's contents, user preferences, etc. =head1 USING SESSIONS In L, the L plugin provides an API for convenient handling of session data. This API is based on the older, less flexible and less reliable L. The plugin is modular, and requires backend plugins to be used. =head2 State Plugins State plugins handle session ID persistence. For example L creates a cookie with the session ID in it. These plugins will automatically set C<< $c->sessionid >> at the beginning of the request, and automatically cause C<< $c->sessionid >> to be saved by the client at the end of the request. =head2 Store Plugins The backend into which session data is stored is provided by these plugins. For example, L uses a database table to store session data, while L uses L. =head2 Configuration First you need to load the appropriate plugins into your L application: package MyApp; use Catalyst qw/ Session Session::State::Cookie Session::Store::File /; This loads the session API, as well as the required backends of your choice. After the plugins are loaded they need to be configured. This is done according to L. Each backend plugin requires its own configuration options (with most plugins providing sensible defaults). The session API itself also has configurable options listed in L. For the plugins above we don't need any configuration at all - they should work out of the box, but suppose we did want to change some things around, it'll look like this: MyApp->config( 'Plugin::Session' => { cookie_name => "my_fabulous_cookie", storage => "/path/to/store_data_file", }); =head2 Usage Now, let's say we have an online shop, and the user is adding an item to the shopping cart. Typically the item the user was viewing would have a form or link that adds the item to the cart. Suppose this link goes to C, meaning that we want two units of the item C to be added to the cart. Our C action should look something like this: package MyApp::Controller::Cart; sub add : Local { my ( $self, $c, $item_id, $quantity ) = @_; $quantity ||= 1; if ( $c->model("Items")->item_exists($item_id) ) { $c->session->{cart}{$item_id} += $quantity; } else { die "No such item"; } } The way this works is that C<< $c->session >> always returns a hash reference to some data which is stored by the storage backend plugin. The hash reference returned always contains the same items that were in there at the end of the last request. All the mishmash described above is done automatically. First, the method looks to see if a session ID is set. This session ID will be set by the State plugin if appropriate, at the start of the request (e.g. by looking at the cookies sent by the client). If a session ID is set, the store will be asked to retrieve the session data for that specific session ID, and this is returned from C<< $c->session >>. This retrieval is cached, and will only happen once per request, if at all. If a session ID is not set, a new one is generated, a new anonymous hash is created and saved in the store with the session ID as the key, and the reference to the hash is returned. The action above takes this hash reference, and updates a nested hash within it, that counts quantity of each item as stored in the cart. Any cart-listing code can then look into the session data and use it to display the correct items, which will, of course, be remembered across requests. Here is an action some Template Toolkit example code that could be used to generate a cart listing: sub list_cart : Local { my ( $self, $c ) = @_; # get the cart data, that maps from item_id to quantity my $cart = $c->session->{cart} || {}; # this is our abstract model in which items are stored my $storage = $c->model("Items"); # map from item_id to item (an object or hash reference) my %items = map { $_ => $storage->get_item($_) } keys %$cart; # put the relevant info on the stash $c->stash->{cart}{items} = \%items; $c->stash->{cart}{quantity} = $cart; } And [a part of] the template it forwards to: [%# the table body lists all the items in the cart %] [% FOREACH item_id = cart.items.keys %] [%# each item has its own row in the table %] [% item = cart.items.$item_id %] [% quantity = cart.quantity.$item_id %] [% END %]
Item Quantity Price remove
[%# item.name is an attribute in the item # object, as loaded from the store %] [% item.name %] [%# supposedly this is part of a form where you # can update the quantity %] $ [% item.price * quantity %]
Total: [%# calculate sum in this cell - too # much headache for a tutorial ;-) %] Empty cart
As you can see the way that items are added into C<< $c->session->{cart} >> is pretty simple. Since C<< $c->session >> is restored as necessary, and contains data from previous requests by the same client, the cart can be updated as the user navigates the site pretty transparently. =head1 SECURITY ISSUES These issues all relate to how session data is managed, as described above. These are not issues you should be concerned about in your application code, but are here for their educational value. =head2 (Not) Trusting the Client In order to avoid the overhead of server-side data storage, the session data can be included in the cookie itself. There are two problems with this: =over 4 =item 1 The user can change the data. =item 2 Cookies have a 4 kilobyte size limit. The size limit is of no concern in this section, but data changing is. In the database scheme the data can be trusted, since the user can neither read nor write it. However, if the data is delegated to the user, then special measures have to be added for ensuring data integrity, and perhaps secrecy too. This can be implemented by encrypting and signing the cookie data, but this is a big headache. =back =head2 Session Hijacking What happens when client B says "I'm client A"? Well, basically, the server buys it. There's no real way around it. The solution is to make "I'm client A" a difficult thing to say. This is why session IDs are randomized. If they are properly randomized, session IDs are so hard to guess that they must be stolen instead. This is called session hijacking. There are several ways one might hijack another user's session. =head3 Cross Site Scripting One is by using cross site scripting attacks to steal the cookie data. In community sites, where users can cause the server to display arbitrary HTML, they can use this to put JavaScript code on the server. If the server does not enforce a strict subset of tags that may be used, the malicious user could use this code to steal the cookies (there is a JavaScript API that lets cookies be accessed, but this code has to be run on the same website that the cookie came from). =head3 Social Engineering By tricking a user into revealing a URI with session data embedded in it (when cookies are not used), the session ID can also be stolen. Also, a naive user could be tricked into showing the cookie data from the browser to a malicious user. =head1 AUTHOR Yuval Kogman Enothingmuch@woobling.orgE =cut Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session/Test/Store.pm000644 000765 000024 00000011043 12461526004 027716 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Session::Test::Store; use strict; use warnings; use utf8; use Test::More; use File::Temp; use File::Spec; use Catalyst (); sub import { shift; my %args = @_; plan tests => 19 + ($args{extra_tests} || 0); my $backend = $args{backend}; my $cfg = $args{config}; my $p = "Session::Store::$backend"; use_ok( my $m = "Catalyst::Plugin::$p" ); isa_ok( bless( {}, $m ), "Catalyst::Plugin::Session::Store" ); { package # Hide from PAUSE Catalyst::Plugin::SessionStateTest; use base qw/Catalyst::Plugin::Session::State/; no strict 'refs'; sub get_session_id { my $c = shift; ${ ref($c) . "::session_id" }; } sub set_session_id { my ( $c, $sid ) = @_; ${ ref($c) . "::session_id" } = $sid; } sub delete_session_id { my $c = shift; undef ${ ref($c) . "::session_id" }; } } { package # Hide from PAUSE SessionStoreTest; use Catalyst qw/Session SessionStateTest/; push our (@ISA), $m; our $VERSION = "123"; # Do not remove use strict; use warnings; use Test::More; sub create_session : Global { my ( $self, $c ) = @_; ok( !$c->session_is_valid, "no session id yet" ); ok( $c->session, "session created" ); ok( $c->session_is_valid, "with a session id" ); $c->session->{magic} = "møøse"; } sub recover_session : Global { my ( $self, $c ) = @_; ok( $c->session_is_valid, "session id exists" ); is( $c->sessionid, our $session_id, "and is the one we saved in the last action" ); ok( $c->session, "a session exists" ); is( $c->session->{magic}, "møøse", "and it contains what we put in on the last attempt" ); $c->delete_session("user logout"); } sub after_session : Global { my ( $self, $c ) = @_; ok( !$c->session_is_valid, "no session id" ); ok( !$c->session->{magic}, "session data not restored" ); ok( !$c->session_delete_reason, "no reason for deletion" ); } @{ __PACKAGE__->config->{'Plugin::Session'} }{ keys %$cfg } = values %$cfg; { __PACKAGE__->setup; }; # Extra block here is an INSANE HACK to get inlined constructor # (i.e. to make B::Hooks::EndOfScope fire) } { package # Hide from PAUSE SessionStoreTest2; use Catalyst qw/Session SessionStateTest/; push our (@ISA), $m; our $VERSION = "123"; use Test::More; sub create_session : Global { my ( $self, $c ) = @_; $c->session->{magic} = "møøse"; } sub recover_session : Global { my ( $self, $c ) = @_; ok( !$c->session_is_valid, "session is gone" ); is( $c->session_delete_reason, "session expired", "reason is that the session expired" ); ok( !$c->session->{magic}, "no saved data" ); } __PACKAGE__->config->{'Plugin::Session'}{expires} = 0; @{ __PACKAGE__->config->{'Plugin::Session'} }{ keys %$cfg } = values %$cfg; { __PACKAGE__->setup; }; # INSANE HACK (the block - as above) } use Test::More; can_ok( $m, "get_session_data" ); can_ok( $m, "store_session_data" ); can_ok( $m, "delete_session_data" ); can_ok( $m, "delete_expired_sessions" ); { package # Hide from PAUSE t1; use Catalyst::Test "SessionStoreTest"; # idiotic void context warning workaround my $x = get("/create_session"); $x = get("/recover_session"); $x = get("/after_session"); } { package # Hide fram PAUSE t2; use Catalyst::Test "SessionStoreTest2"; my $x = get("/create_session"); sleep 1; # let the session expire $x = get("/recover_session"); } } __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Session::Test::Store - Reusable sanity for session storage engines. =head1 SYNOPSIS #!/usr/bin/perl use Catalyst::Plugin::Session::Test::Store ( backend => "FastMmap", config => { storage => "/tmp/foo", }, ); =head1 DESCRIPTION =cut Catalyst-Plugin-Session-0.40/lib/Catalyst/Plugin/Session/Store/Dummy.pm000644 000765 000024 00000001606 12461526004 030076 0ustar00jnapiorkowskistaff000000 000000 #!/usr/bin/perl package Catalyst::Plugin::Session::Store::Dummy; use base qw/Catalyst::Plugin::Session::Store/; use strict; use warnings; my %store; sub get_session_data { my ( $c, @keys ) = @_; @store{@keys}; } sub store_session_data { my $c = shift; my %data = @_; @store{ keys %data } = values %data; } sub delete_session_data { my ( $c, $sid ) = @_; delete $store{$sid}; } sub delete_expired_sessions { } __PACKAGE__; __END__ =pod =head1 NAME Catalyst::Plugin::Session::Store::Dummy - Doesn't really store sessions - useful for tests. =head1 SYNOPSIS use Catalyst qw/Session Session::Store::Dummy/; =head1 DESCRIPTION This plugin will "store" data in a hash. =head1 METHODS See L. =over 4 =item get_session_data =item store_session_data =item delete_session_data =item delete_expired_sessions =back =cut Catalyst-Plugin-Session-0.40/inc/Module/000755 000765 000024 00000000000 12461562414 022136 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/inc/Module/Install/000755 000765 000024 00000000000 12461562414 023544 5ustar00jnapiorkowskistaff000000 000000 Catalyst-Plugin-Session-0.40/inc/Module/Install.pm000644 000765 000024 00000030217 12461562404 024104 0ustar00jnapiorkowskistaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.14'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $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 /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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-Session-0.40/inc/Module/Install/AuthorTests.pm000644 000765 000024 00000002215 12461562405 026367 0ustar00jnapiorkowskistaff000000 000000 #line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; Catalyst-Plugin-Session-0.40/inc/Module/Install/Base.pm000644 000765 000024 00000002147 12461562405 024760 0ustar00jnapiorkowskistaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.14'; } # 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-Session-0.40/inc/Module/Install/Can.pm000644 000765 000024 00000006157 12461562405 024614 0ustar00jnapiorkowskistaff000000 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.14'; @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-Session-0.40/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 12461562405 025144 0ustar00jnapiorkowskistaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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-Session-0.40/inc/Module/Install/Makefile.pm000644 000765 000024 00000027437 12461562405 025634 0ustar00jnapiorkowskistaff000000 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.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Catalyst-Plugin-Session-0.40/inc/Module/Install/Metadata.pm000644 000765 000024 00000043302 12461562405 025624 0ustar00jnapiorkowskistaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Catalyst-Plugin-Session-0.40/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 12461562405 025004 0ustar00jnapiorkowskistaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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-Session-0.40/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 12461562405 025635 0ustar00jnapiorkowskistaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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;