From: Florian Ragwitz Date: Thu, 19 Feb 2009 05:16:12 +0000 (+0000) Subject: Create branch register_actions. X-Git-Tag: 5.80001~40^2~16 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=ae29b412955743885e80350085167b54b69672da Create branch register_actions. --- diff --git a/Changes b/Changes index 53d3d18..f5d21d8 100644 --- a/Changes +++ b/Changes @@ -1,24 +1,218 @@ # This file documents the revision history for Perl extension Catalyst. -5.71000 2009-01-19 17:50:00 + - Make MyApp.pm restartable by unsetting setup_finished in + the restarter process (t0m) + - Non-naive implementation of making mutable on restart using + B::Hooks::OP::Check::StashChange if installed (t0m) + - Tests for this (t0m) + - Naive implementation of making all components mutable in the + forked restart watcher process so native Moose apps using + immutable restart correctly. (t0m) + - Tests for this (t0m) + - Bump Moose dependency to 0.70 so that we avoid nasty surprises + with is_class_loaded and perl 5.80 when you Moosify MyApp.pm (t0m) + - Clarify that request arguments aren't unescaped automatically + (Simon Bertrang) (Closes RT#41153) + - Don't require C3 for the MRO test (rafl) + - Bump MX::Emulate::CAF prereq to support list assignment (rafl) + - Remove useless column in chained action debug table. (rafl) + - namespace::clean related cleanups (rafl) + - Import related cleanups and consistency fixes (rafl) + - Fix test suite TestApp /dump/env action (t0m) + +5.8000_06 2009-02-04 21:00 + - Disallow writing to config after setup (rafl) + - Disallow calling setup more than once (rafl) + - Documentation fix regarding overloading of Engine and Dispatcher + instances (rafl) + - Several documentation typo fixes (rafl) + - Stop Makefile.PL from warning about versions that fixed a conflict + (t0m) + - Improved upgrading documentation (t0m, rafl) + - Seed the RNG in each FastCGI child process (Andrew Rodland) + - Properly report dynamic bind port for the development server (rafl) + (Closes RT#38544) + - Use the way documented by IO::Socket::INET to get the error message + after trying to create a listening socket (rafl) (Closes RT#41828) + - Don't ignore SIGCHLD while handling requests with the dev server + (rafl) (Closes RT#42962) + +5.8000_05 2008-29-01 00:00 - Text::SimpleTable's go as wide as $ENV{COLUMNS} (jhannah) Patch written by Oleg Kostyuk - - backport go doc patch - - added ru/ua translations to error page - - backport stripping build_requires - -5.7099_04 2009-01-12 13:06:00 - - Add environment hack for FastCGI under IIS (Simon Bertrang) - - Test for this and preexisting Lighty hack (Simon Bertrang) - - Change streaming test to serve itself rather than 01use.t, making test - sync for engines easier (t0m) + - Improve docs for visit (mateu) + - Add docs for finalize hook (dhoss) + - Added ru/ua translations to error page + - Improve the clarity and verbosity of the warning when component + resolution uses regex fallback. (jhannah) + - Handle leading CRLF in HTTP requests sometimes sent by IE6 in + keep-alive requests. (andyg) + - Fixes for FastCGI with IIS 6.0 (janus) + - Passing request method exported by Catalyst::Test an extra + parameter used to be ignored, but started breaking if the parameter + was not a hash in 5.8000_04. Extra parameter is now ignored if + it isn't a hashref (t0m) + - Fix request argumentss getting corrupted if you override the + dispatcher and call an action which detaches (for + Catalyst::Plugin::Authorization::ACL) (t0m) + - Fix calling use Catalyst::Test 'MyApp' 'foo' which used to work, + but stopped as the 2nd parameter can be an options hash now (t0m) + - Bump Moose dependency to fix make_immutable bug (t0m) + - Use compile time extends in Catalyst::Controller (t0m) + - Make Catalyst::Request::uploads attribute non-lazy, to fix + test for Catalyst-Engine-Apache (t0m) + - Bump version of MooseX::Emulate::Class::Accessor::Fast (t0m) + - Stop using MooseX::Adopt::Class::Accessor::Fast by default, to stop + breaking other packages which use Class::Accessor::Fast + - Remove unused action_container_class attribute from + Catalyst::Dispatcher (t0m) + - Replace {_body} instance access with calls to _body accessors (t0m) + - Add backwards compatibility alias methods for private attributes on + Catalyst::Dispatcher which used to be public. Needed by + Catalyst::Plugin::Server and Catalyst::Plugin::Authorization::ACL + (t0m) + - Fix return value of $c->req->body, which delegates to the body + method on the requests HTTP::Body instance (t0m) + - Test for this (t0m) + - Fix calling $c->req->body from inside an overridden prepare_action + method in a plugin, as used by Catalyst::Plugin::Server (t0m) + - Test for this (t0m) + - Fix assignment to Catalyst::Dispatcher's preload_dispatch_types and + postload_dispatch_types attributes - assigning a list should later + return a listref. Fixes Catalyst::Plugin::Server. (t0m) + - Tests for this (t0m) + - Change streaming test to serve itself rather than 01use.t, making + test sync for engines easier (t0m) + - Refactor capturing of $app from Catalyst::Controller into + Catalyst::Component::ApplicationAttribute for easier reuse in other + components (Florian Ragwitz) + - Make the test suites YAML dependency optional (Florian Ragwitz) + - Make debug output show class name for the engine and dispatcher + rather than the stringified ref. (t0m) + - Make MyApp immutable at the end of the scope after the setup + method is called, fixing issues with plugins which have their + own new methods by inlining a constructor on MyApp (t0m) + - Test for this and method modifiers in MyApp (t0m) + - Fix bug causing Catalyst::Request::Upload's basename method + to return undef (t0m) + - Test for this (Carl Franks) + - Fix loading of classes which do not define any symbols to not + die, as it didn't in 5.70 (t0m) + - Test for this (t0m) + - Bump MooseX::Emulate::Class::Accessor::Fast dependency + to force new version which fixes a lot of plugins (t0m) + - Make log levels additive, and add documentation and tests + for the setup_log method, which previously had none. + Sewn together by t0m from two patches provided by David E. Wheeler + - Switch an around 'new' in Catalyst::Controller to a BUILDARGS + method as it's much neater and more obvious what is going on (t0m) + - Add a clearer method on request and response _context + attributes, and use if from ::Engine rather than deleting + the key from the instance hash (t0m) + - Use handles on tree attribute of Catalyst::Stats to replace + trivial delegation methods (t0m) + - Change the following direct hash accesses into attributes: + Catalyst::Engine: _prepared_write + Catalyst::Engine::CGI: _header_buf + Catalyst::Engine::HTTP: options, _keepalive, _write_error + Catalyst::Request: _path + Catalyst::Stats: tree + (t0m) + - Fix issues in Catalyst::Controller::WrapCGI + and any other components which import (or define) their + own meta method by always explicitly calling + Class::MOP::Object->meta inside Catalyst (t0m) + - Add test for this (t0m) + - Add test case for the bug which is causing the + Catalyst::Plugin::Authentication tests to fail (t0m) + - Fix a bug in uri_for which could cause it to generate paths + with multiple slashes in them. (t0m) + - Add test for this (t0m) + - Fix SKIP block name in t/optional_http-server-restart.t, + stopping 'Label not found for "last SKIP"' error from + Test::More (t0m) + - Workaround max_redirect 0 bug in LWP (andyg) + - Move live_engine_response_print into aggregate (andyg) + - Fix dependency bug, s/parent/base/ in new test (rafl) + - Fix optional tests to run the live tests in the aggregate + dir (andyg) + - Fix Catalyst->go error in remote tests (andyg) + - Fix upload test to work with remote servers, don't check for + deleted files (andyg) + - Fix engine_request_uri tests to work on remote server with + different URI (andyg) + +5.8000_04 2008-12-05 12:15:00 + - Silence Class::C3::Adopt::NEXT warnings in the test suite (rafl) + - Fix loads of 'used once, possible typo' warnings (rafl) + - Additional tests to ensure upload temp files are deleted (andyg) + - Remove use of NEXT from the test suite, except for one case + which tests if Class::C3::Adopt::NEXT is working (t0m) + - Use a predicate to avoid recursion in cases where the uri + method is overridden by a plugin, and calls the base method, + for example Catalyst::Plugin::SmartURI (t0m) + - Test for this (caelum) + - Compose the MooseX::Emulate::Class::Accessor::Fast role to + Catalyst::Action, Catalyst::Request, and all other modules which + inherit from Class::Accessor::Fast in 5.70. + This fixes: + - Catalyst::Controller::HTML::FormFu (zamolxes) + - Catalyst::Request::REST (t0m) + - Test for this (t0m) + - Make hostname resolution lazy (Marc Mims) + - Support mocking virtualhosts in test suite (Jason Gottshall) + - Add README (marcus) + - Fix TODO list (t0m) + - Use Class::C3::Adopt::NEXT (rafl) + - Ignore C3 warnings on 5.10 when testing ensure_class_loaded (rafl) + - Add TODO test for chained bug (gbjk) + - Fix list address in documentation (zarquon) + - Fix ACCEPT_CONTEXT on MyApp, called as a class method (marcus) + - Test for this (marcus) + - Bump MooseX::Emulate::Class::Accessor::Fast version requirement to + get more back compatibility (t0m) + - Improve documentation for $req->captures (caelum) + - Fix a bug in Catalyst::Stats, stopping garbage being inserted into + the stats if a user calls begin => but no end => (jhannah) + - Test for this (jhannah) + - Trim lines sooner in stats to avoid ugly Text::SimpleTable wrapping + (jhannah) + - Change Catalyst::ClassData to tweak the symbol table inline for + performance after profiling (mst) + - Fix POD typo in finalize_error (jhannah) + - Add tests to ensure that we delete the temp files created by + HTTP::Body's OctetStream parser (t0m) + +5.8000_03 2008-10-14 14:13:00 + - Fix forwarding to Catalyst::Action objects (Rafael Kitover). + - Fix links to the mailing lists (RT #39754 and Florian Ragwitz). + - Use Class::MOP instead of Class::Inspector (Florian Ragwitz). + - Change Catalyst::Test to use Sub::Exporter (Florian Ragwitz). + - Fixed typo in Engine::HTTP::Restarter::Watcher causing -r to complain. + +5.8000_02 2008-10-14 07:59:00 + - Fix manifest + +5.8000_01 2008-10-13 22:52:00 + - Port to Moose + - Added test for action stringify + - Added test for component instances getting $self->{value} from config. + - Add Catalyst::Response->print() method (ilmari) + - Optionally aggregate tests using Test::Aggregate (Florian Ragwitz). + - Additional docs for uri_for to mention how to use $c->action and + $c->req->captures (jhannah) + - List unattached chained actions in Debug mode (Florian Ragwitz). + - Pod formatting fix for Engine::FastCGI (Oleg Kostyuk). + - Add visit, a returning ->go + +5.7XXXXXX XXXX - Workaround change in LWP that broke a cookie test (RT #40037) - - Backport go() from 5.8 branch. + - Back out go() since that feature's been pushed to 5.80 - Fix some Win32 test failures - Add pt translation of error message (wreis) - Make :Chained('../action') work (Florian Ragwitz) - - Fix forwarding to action object. - - Handle leading CRLF in HTTP requests sometimes sent by IE6 in keep-alive requests. + - Add test actions + - Chained doc improvements (rev 8326-8328) 5.7099_03 2008-07-20 10:10:00 - Fix regressions for regexp fallback in model(), view() and controller() diff --git a/IDEAS b/IDEAS new file mode 100644 index 0000000..e101406 --- /dev/null +++ b/IDEAS @@ -0,0 +1,19 @@ +* improve NEXT warnings. related irc conversation from 09/01/21: + +04:41:15 <@mst> actually, even better, it can pass an exclude list +04:41:22 <@mst> and an include list with versions that contain fixage +04:41:39 <@mst> then as shit on CPAN gets fixed it can start warning that you should upgrade +04:41:46 <@rafl> that's already implemented. someone would need to maintain that list though +04:42:28 <@rafl> i still think that silencing the warnings will delay fixes +04:42:33 <@mst> if one person files all the rt tickets +04:42:45 <@mst> it's just a question of watching email +04:44:04 <@mst> and it doesn't seem fair for a user's code to warn all over the fucking place +04:44:10 <@mst> just because some cpan author hasn't got their ass in gear +04:44:52 <@rafl> the user already can disable the warnings for certain classes +04:45:44 <@mst> I think we should leave 'em on for the RCs +04:45:57 * dhoss-laptop phrews +04:46:02 <@mst> but I don't think 5.80 final should be that sqeually +04:46:06 <@rafl> what we have now is basically what i thought was good enough. it can certainly be better. +04:46:17 <@rafl> i won't work on that anytime soon though +04:46:20 <@mst> sure +04:46:34 <@mst> could you throw this conversation into an IDEAS file or something? diff --git a/Makefile.PL b/Makefile.PL index 12fc01e..524248a 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,14 +1,17 @@ -use inc::Module::Install 0.77; +use inc::Module::Install 0.64; perl_version '5.008001'; name 'Catalyst-Runtime'; all_from 'lib/Catalyst/Runtime.pm'; +requires 'namespace::clean'; +requires 'Scope::Upper' => '0.06'; +requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00800'; +requires 'Moose' => '0.70'; requires 'Carp'; -requires 'Class::Accessor::Fast'; -requires 'Class::Data::Inheritable'; -requires 'Class::Inspector' => '1.06'; +requires 'Class::C3::Adopt::NEXT' => '0.07'; +requires 'Class::MOP'; requires 'CGI::Simple::Cookie'; requires 'Data::Dump'; requires 'File::Modified'; @@ -20,43 +23,57 @@ requires 'HTTP::Response'; requires 'HTTP::Request::AsCGI' => '0.5'; requires 'LWP::UserAgent'; requires 'Module::Pluggable' => '3.01'; -requires 'NEXT'; requires 'Path::Class' => '0.09'; requires 'Scalar::Util'; +requires 'Sub::Exporter'; requires 'Text::SimpleTable' => '0.03'; requires 'Time::HiRes'; requires 'Tree::Simple' => '1.15'; requires 'Tree::Simple::Visitor::FindByPath'; requires 'URI' => '1.35'; requires 'Text::Balanced'; # core in 5.8.x but mentioned for completeness +requires 'MRO::Compat'; +recommends 'B::Hooks::OP::Check::StashChange'; +test_requires 'Class::Data::Inheritable'; +test_requires 'Test::MockObject'; + +if ( ( exists $ENV{AGGREGATE_TESTS} && !$ENV{AGGREGATE_TESTS}) + || (!exists $ENV{AGGREGATE_TESTS} && !can_use('Test::Aggregate', '0.34_01'))) { + tests join q{ }, + grep { $_ ne 't/aggregate.t' } + map { glob } qw[t/*.t t/aggregate/*.t]; +} +else { + test_requires('Test::Aggregate', '0.34_01'); +} my @force_build_requires_if_author = qw( - Test::NoTabs - Test::Pod - Test::Pod::Coverage - Pod::Coverage + Test::NoTabs + Test::Pod + Test::Pod::Coverage + Pod::Coverage ); - + if ($Module::Install::AUTHOR) { - foreach my $module (@force_build_requires_if_author) { - build_requires $module; - } + foreach my $module (@force_build_requires_if_author) { + build_requires $module; + } - if ($^O eq 'darwin') { - my $osx_ver = `/usr/bin/sw_vers -productVersion`; - chomp $osx_ver; + if ($^O eq 'darwin') { + my $osx_ver = `/usr/bin/sw_vers -productVersion`; + chomp $osx_ver; -# TAR on 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE -# On 10.5 (Leopard) it wants COPYFILE_DISABLE - my $attr = $osx_ver eq '10.5' ? 'COPYFILE_DISABLE' : 'COPY_EXTENDED_ATTRIBUTES_DISABLE'; + # TAR on 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE + # On 10.5 (Leopard) it wants COPYFILE_DISABLE + my $attr = $osx_ver eq '10.5' ? 'COPYFILE_DISABLE' : 'COPY_EXTENDED_ATTRIBUTES_DISABLE'; - makemaker_args(dist => { PREOP => qq{\@if [ "\$\$$attr" != "true" ]; then}. - qq{ echo "You must set the ENV variable $attr to true,"; }. - ' echo "to avoid getting resource forks in your dist."; exit 255; fi' }); - } + makemaker_args(dist => { PREOP => qq{\@if [ "\$\$$attr" != "true" ]; then}. + qq{ echo "You must set the ENV variable $attr to true,"; }. + ' echo "to avoid getting resource forks in your dist."; exit 255; fi' }); + } } install_script glob('script/*.pl'); @@ -65,28 +82,28 @@ WriteAll; if ($Module::Install::AUTHOR) { -# Strip out the author only build_requires from META.yml -# Need to do this _after_ WriteAll else it looses track of them - Meta->{values}{build_requires} = [ grep { - my $ok = 1; - foreach my $module (@force_build_requires_if_author) { - if ($_->[0] =~ /$module/) { - $ok = 0; - last; - } - } - $ok; - } @{Meta->{values}{build_requires}} ]; - - Meta->{values}{resources} = [ - [ 'MailingList', 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst' ], - [ 'IRC', 'irc://irc.perl.org/#catalyst' ], - [ 'license', 'http://dev.perl.org/licenses/' ], - [ 'homepage', 'http://dev.catalyst.perl.org/'], - [ 'repository', 'http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/' ], - ]; - - Meta->write; + # Strip out the author only build_requires from META.yml + # Need to do this _after_ WriteAll else it looses track of them + Meta->{values}{build_requires} = [ grep { + my $ok = 1; + foreach my $module (@force_build_requires_if_author) { + if ($_->[0] =~ /$module/) { + $ok = 0; + last; + } + } + $ok; + } @{Meta->{values}{build_requires}} ]; + + Meta->{values}{resources} = [ + [ 'MailingList', 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst' ], + [ 'IRC', 'irc://irc.perl.org/#catalyst' ], + [ 'license', 'http://dev.perl.org/licenses/' ], + [ 'homepage', 'http://dev.catalyst.perl.org/'], + [ 'repository', 'http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/' ], + ]; + + Meta->write; } print <<"EOF"; @@ -105,3 +122,52 @@ print <<"EOF"; Have fun! EOF + +check_conflicts(); + +# Nicked straight from Moose! +sub check_conflicts { + # NOTE - This is the version number of the _incompatible_ code, + # not the version number of the fixed version. + my %conflicts = ( + 'Catalyst::Plugin::SmartURI' => '0.029', + 'CatalystX::CRUD' => '0.37', + 'Catalyst::Action::RenderView' => '0.07', + 'Catalyst::Plugin::DebugCookie' => '0.999002', + 'Catalyst::Plugin::Authentication' => '0.100091', + 'CatalystX::Imports' => '0.03', + 'Catalyst::Plugin::HashedCookies' => '1.03', + ); + + my $found = 0; + for my $mod ( sort keys %conflicts ) { + eval "require($mod)"; + next if $@; + + my $installed = $mod->VERSION(); + if ( $installed le $conflicts{$mod} ) { + + print <<"EOF"; + +*** + This version of Catalyst conflicts with the version of + $mod ($installed) you have installed. + + You will need to upgrade $mod after installing + this version of Catalyst. +*** + +EOF + + $found = 1; + } + } + + return unless $found; + + # More or less copied from Module::Build + return if $ENV{PERL_MM_USE_DEFAULT}; + return unless -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)); + + sleep 4; +} diff --git a/README b/README new file mode 100644 index 0000000..1438432 --- /dev/null +++ b/README @@ -0,0 +1,14 @@ +Catalyst-Runtime +================ +This is the Runtime distribution for the Catalyst MVC framework. +For more information about Catalyst, write + +$ perldoc Catalyst + +at the command line, or visit http://www.catalystframework.org/. +You can also install Catalyst::Manual from CPAN for more +comprehensive information. + +If you are going to write your own Catalyst application, you will +need to install Catalyst::Devel. Afterwards run catalyst.pl +for more information about creating your first app. diff --git a/TODO b/TODO new file mode 100644 index 0000000..03ae67f --- /dev/null +++ b/TODO @@ -0,0 +1,21 @@ +Known issues: + +Documentation: + + - Catalyst/Upgrading.pod needs brushing up + + - Warning when you pass $c->model("MyApp::Model::Foo") is the generic + warning for regex fall back. Should be more specific about what you + screwed up, and the docs for $c->model should be more explicit about + what is expected. This probably also applies to view/controller. + + - Run more smokes + + - Using anything ::[CMV]:: should warn (once, on boot). + + - TestApp should not use NEXT. There should be a TestAppNEXTCompat + which does but is standalone.. + +Profiling: + + - vs 5.70 and optimisation as needed on perl 5.8 (5.10 is already faster!). diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 5294064..8805134 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -1,8 +1,9 @@ package Catalyst; -use strict; -use base 'Catalyst::Component'; +use Moose; +extends 'Catalyst::Component'; use bytes; +use Scope::Upper (); use Catalyst::Exception; use Catalyst::Log; use Catalyst::Request; @@ -13,36 +14,45 @@ use Catalyst::Controller; use Devel::InnerPackage (); use File::stat; use Module::Pluggable::Object (); -use NEXT; use Text::SimpleTable (); use Path::Class::Dir (); use Path::Class::File (); -use Time::HiRes qw/gettimeofday tv_interval/; use URI (); use URI::http; use URI::https; -use Scalar::Util qw/weaken blessed/; use Tree::Simple qw/use_weak_refs/; use Tree::Simple::Visitor::FindByUID; +use Class::C3::Adopt::NEXT; use attributes; use utf8; use Carp qw/croak carp shortmess/; BEGIN { require 5.008001; } -__PACKAGE__->mk_accessors( - qw/counter request response state action stack namespace stats/ -); +has stack => (is => 'ro', default => sub { [] }); +has stash => (is => 'rw', default => sub { {} }); +has state => (is => 'rw', default => 0); +has stats => (is => 'rw'); +has action => (is => 'rw'); +has counter => (is => 'rw', default => sub { {} }); +has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1); +has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1); +has namespace => (is => 'rw'); sub depth { scalar @{ shift->stack || [] }; } +sub comp { shift->component(@_) } -# Laziness++ -*comp = \&component; -*req = \&request; -*res = \&response; +sub req { + # carp "the use of req() is deprecated in favour of request()"; + my $self = shift; return $self->request(@_); +} +sub res { + # carp "the use of res() is deprecated in favour of response()"; + my $self = shift; return $self->response(@_); +} # For backwards compatibility -*finalize_output = \&finalize_body; +sub finalize_output { shift->finalize_body(@_) }; # For statistics our $COUNT = 1; @@ -51,6 +61,8 @@ our $RECURSION = 1000; our $DETACH = "catalyst_detach\n"; our $GO = "catalyst_go\n"; +#I imagine that very few of these really need to be class variables. if any. +#maybe we should just make them attributes with a default? __PACKAGE__->mk_classdata($_) for qw/components arguments dispatcher engine log dispatcher_class engine_class context_class request_class response_class stats_class @@ -64,7 +76,7 @@ __PACKAGE__->stats_class('Catalyst::Stats'); # Remember to update this in Catalyst::Runtime as well! -our $VERSION = '5.71000'; +our $VERSION = '5.8000_06'; sub import { my ( $class, @arguments ) = @_; @@ -73,11 +85,23 @@ sub import { # callers @ISA. return unless $class eq 'Catalyst'; - my $caller = caller(0); + my $caller = caller(); + return if $caller eq 'main'; + + # Kill Adopt::NEXT warnings if we're a non-RC version + if ($VERSION !~ /_\d{2}$/) { + Class::C3::Adopt::NEXT->unimport(qr/^Catalyst::/); + } + + my $meta = Moose::Meta::Class->initialize($caller); + #Moose->import({ into => $caller }); #do we want to do this? unless ( $caller->isa('Catalyst') ) { - no strict 'refs'; - push @{"$caller\::ISA"}, $class, 'Catalyst::Controller'; + my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller'); + $meta->superclasses(@superclasses); + } + unless( $meta->has_method('meta') ){ + $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } ); } $caller->arguments( [@arguments] ); @@ -239,7 +263,9 @@ MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used. =head2 -Log -Specifies log level. + use Catalyst '-Log=warn,fatal,error'; + +Specifies a comma-delimited list of log levels. =head2 -Stats @@ -311,7 +337,7 @@ your code like this: =cut -sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) } +sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $c, @_ ) } =head2 $c->detach( $action [, \@arguments ] ) @@ -394,17 +420,21 @@ Catalyst). =cut -sub stash { +around stash => sub { + my $orig = shift; my $c = shift; + my $stash = $orig->($c); if (@_) { - my $stash = @_ > 1 ? {@_} : $_[0]; - croak('stash takes a hash or hashref') unless ref $stash; - foreach my $key ( keys %$stash ) { - $c->{stash}->{$key} = $stash->{$key}; + my $new_stash = @_ > 1 ? {@_} : $_[0]; + croak('stash takes a hash or hashref') unless ref $new_stash; + foreach my $key ( keys %$new_stash ) { + $stash->{$key} = $new_stash->{$key}; } } - return $c->{stash}; -} + + return $stash; +}; + =head2 $c->error @@ -610,7 +640,7 @@ sub model { $c->log->warn( '* $c->config->{default_model} # the name of the default model to use' ); $c->log->warn( '* $c->stash->{current_model} # the name of the model to use for this request' ); $c->log->warn( '* $c->stash->{current_model_instance} # the instance of the model to use for this request' ); - $c->log->warn( 'NB: in version 5.80, the "random" behavior will not work at all.' ); + $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' ); } return $c->_filter_component( $comp ); @@ -663,7 +693,7 @@ sub view { $c->log->warn( '* $c->config->{default_view} # the name of the default view to use' ); $c->log->warn( '* $c->stash->{current_view} # the name of the view to use for this request' ); $c->log->warn( '* $c->stash->{current_view_instance} # the instance of the view to use for this request' ); - $c->log->warn( 'NB: in version 5.80, the "random" behavior will not work at all.' ); + $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' ); } return $c->_filter_component( $comp ); @@ -776,14 +806,15 @@ L. =cut -sub config { +around config => sub { + my $orig = shift; my $c = shift; - $c->log->warn("Setting config after setup has been run is not a good idea.") - if ( @_ and $c->setup_finished ); + croak('Setting config after setup has been run is not allowed.') + if ( @_ and $c->setup_finished ); - $c->NEXT::config(@_); -} + $c->$orig(@_); +}; =head2 $c->log @@ -816,13 +847,11 @@ sub debug { 0 } =head2 $c->dispatcher -Returns the dispatcher instance. Stringifies to class name. See -L. +Returns the dispatcher instance. See L. =head2 $c->engine -Returns the engine instance. Stringifies to the class name. See -L. +Returns the engine instance. See L. =head2 UTILITY METHODS @@ -847,17 +876,25 @@ sub path_to { =head2 $c->plugin( $name, $class, @args ) -Helper method for plugins. It creates a classdata accessor/mutator and +Helper method for plugins. It creates a class data accessor/mutator and loads and instantiates the given class. MyApp->plugin( 'prototype', 'HTML::Prototype' ); $c->prototype->define_javascript_functions; + +B This method of adding plugins is deprecated. The ability +to add plugins like this B in a Catalyst 5.9. +Please do not use this functionality in new code. =cut sub plugin { my ( $class, $name, $plugin, @args ) = @_; + + # See block comment in t/unit_core_plugin.t + $class->log->debug(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.9/); + $class->_register_plugin( $plugin, 1 ); eval { $plugin->import }; @@ -889,9 +926,8 @@ Catalyst> line. sub setup { my ( $class, @arguments ) = @_; - - $class->log->warn("Running setup twice is not a good idea.") - if ( $class->setup_finished ); + croak('Running setup more than once') + if ( $class->setup_finished ); unless ( $class->isa('Catalyst') ) { @@ -966,8 +1002,8 @@ EOF my $engine = $class->engine; my $home = $class->config->{home}; - $class->log->debug(qq/Loaded dispatcher "$dispatcher"/); - $class->log->debug(qq/Loaded engine "$engine"/); + $class->log->debug(sprintf(q/Loaded dispatcher "%s"/, blessed($dispatcher))); + $class->log->debug(sprintf(q/Loaded engine "%s"/, blessed($engine))); $home ? ( -d $home ) @@ -976,7 +1012,7 @@ EOF : $class->log->debug(q/Couldn't find home/); } - # Call plugins setup + # Call plugins setup, this is stupid and evil. { no warnings qw/redefine/; local *setup = sub { }; @@ -1000,7 +1036,9 @@ EOF } # Add our self to components, since we are also a component - $class->components->{$class} = $class; + if( $class->isa('Catalyst::Controller') ){ + $class->components->{$class} = $class; + } $class->setup_actions; @@ -1010,85 +1048,76 @@ EOF } $class->log->_flush() if $class->log->can('_flush'); - $class->setup_finished(1); + # Make sure that the application class becomes immutable at this point, + # which ensures that it gets an inlined constructor. This means that it + # works even if the user has added a plugin which contains a new method. + # Note however that we have to do the work on scope end, so that method + # modifiers work correctly in MyApp (as you have to call setup _before_ + # applying modifiers). + Scope::Upper::reap(sub { + my $meta = Class::MOP::get_metaclass_by_name($class); + $meta->make_immutable unless $meta->is_immutable; + }, Scope::Upper::SCOPE(1)); + + $class->setup_finalize; } -=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? ) -=head2 $c->uri_for( $path, @args?, \%query_values? ) +=head2 $app->setup_finalize -=over +A hook to attach modifiers to. +Using C< after setup => sub{}; > doesn't work, because of quirky things done for plugin setup. +Also better than C< setup_finished(); >, as that is a getter method. -=item $action + sub setup_finalize { -A Catalyst::Action object representing the Catalyst action you want to -create a URI for. To get one for an action in the current controller, -use C<< $c->action('someactionname') >>. To get one from different -controller, fetch the controller using C<< $c->controller() >>, then -call C on it. - -This method must be used to create URIs for -L actions. + my $app = shift; -=item $path + ## do stuff, i.e., determine a primary key column for sessions stored in a DB -The actual path you wish to create a URI for, this is a public path, -not a private action path. + $app->next::method(@_); -=item \@captures -If provided, this argument is used to insert values into a I -action in the parts where the definitions contain I. If -not needed, leave out this argument. - -=item @args - -If provided, this is used as a list of further path sections to append -to the URI. In a I action these are the equivalent to the -endpoint L. + } -=item \%query_values +=cut -If provided, the query_values hashref is used to add query parameters -to the URI, with the keys as the names, and the values as the values. +sub setup_finalize { + my ($class) = @_; + $class->setup_finished(1); +} -=back +=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? ) -Returns a L object. +=head2 $c->uri_for( $path, @args?, \%query_values? ) - ## Ex 1: a path with args and a query parameter - $c->uri_for('user/list', 'short', { page => 2}); - ## -> ($c->req->base is 'http://localhost:3000/' - URI->new('http://localhost:3000/user/list/short?page=2) +=over - ## Ex 2: a chained view action that captures the user id - ## In controller: - sub user : Chained('/'): PathPart('myuser'): CaptureArgs(1) {} - sub viewuser : Chained('user'): PathPart('view') {} +=item $action - ## In uri creating code: - my $uaction = $c->controller('Users')->action_for('viewuser'); - $c->uri_for($uaction, [ 42 ]); - ## outputs: - URI->new('http://localhost:3000/myuser/42/view') +A Catalyst::Action object representing the Catalyst action you want to +create a URI for. To get one for an action in the current controller, +use C<< $c->action('someactionname') >>. To get one from different +controller, fetch the controller using C<< $c->controller() >>, then +call C on it. -Creates a URI object using C<< $c->request->base >> and a path. If an -Action object is given instead of a path, the path is constructed -using C<< $c->dispatcher->uri_for_action >> and passing it the -@captures array, if supplied. +You can maintain the arguments captured by an action (e.g.: Regex, Chained) +using C<< $c->req->captures >>. -If any query parameters are passed they are added to the end of the -URI in the usual way. + # For the current action + $c->uri_for($c->action, $c->req->captures); + + # For the Foo action in the Bar controller + $c->uri_for($c->controller->('Bar')->action_for('Foo'), $c->req->captures); -Note that uri_for is destructive to the passed query values hashref. -Subsequent calls with the same hashref may have unintended results. +=back =cut sub uri_for { my ( $c, $path, @args ) = @_; - if ( Scalar::Util::blessed($path) ) { # action object + if ( blessed($path) ) { # action object my $captures = ( scalar @args && ref $args[0] eq 'ARRAY' ? shift(@args) : [] ); @@ -1118,7 +1147,7 @@ sub uri_for { # join args with '/', or a blank string my $args = join('/', grep { defined($_) } @args); $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE - $args =~ s!^/!!; + $args =~ s!^/+!!; my $base = $c->req->base; my $class = ref($base); $base =~ s{(?Wiki
  • - Mailing-List + Mailing-List
  • IRC channel #catalyst on irc.perl.org @@ -1360,9 +1389,9 @@ sub execute { $c->state(0); if ( $c->depth >= $RECURSION ) { - my $action = "$code"; + my $action = $code->reverse(); $action = "/$action" unless $action =~ /->/; - my $error = qq/Deep recursion detected calling "$action"/; + my $error = qq/Deep recursion detected calling "${action}"/; $c->log->error($error); $c->error($error); $c->state(0); @@ -1373,7 +1402,7 @@ sub execute { push( @{ $c->stack }, $code ); - eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }; + eval { $c->state( $code->execute( $class, $c, @{ $c->req->args } ) || 0 ) }; $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info; @@ -1407,9 +1436,10 @@ sub _stats_start_execute { return if ( ( $code->name =~ /^_.*/ ) && ( !$c->config->{show_internal_actions} ) ); - $c->counter->{"$code"}++; + my $action_name = $code->reverse(); + $c->counter->{$action_name}++; - my $action = "$code"; + my $action = $action_name; $action = "/$action" unless $action =~ /->/; # determine if the call was the result of a forward @@ -1428,7 +1458,7 @@ sub _stats_start_execute { } } - my $uid = "$code" . $c->counter->{"$code"}; + my $uid = $action_name . $c->counter->{$action_name}; # is this a root-level call or a forwarded call? if ( $callsub =~ /forward$/ ) { @@ -1471,6 +1501,8 @@ sub _stats_finish_execute { =cut +#Why does this exist? This is no longer safe and WILL NOT WORK. +# it doesnt seem to be used anywhere. can we remove it? sub _localize_fields { my ( $c, $localized, $code ) = ( @_ ); @@ -1498,8 +1530,9 @@ sub finalize { } # Allow engine to handle finalize flow (for POE) - if ( $c->engine->can('finalize') ) { - $c->engine->finalize($c); + my $engine = $c->engine; + if ( my $code = $engine->can('finalize') ) { + $engine->$code($c); } else { @@ -1563,31 +1596,33 @@ Finalizes headers. sub finalize_headers { my $c = shift; + my $response = $c->response; #accessor calls can add up? + # Check if we already finalized headers - return if $c->response->{_finalized_headers}; + return if $response->finalized_headers; # Handle redirects - if ( my $location = $c->response->redirect ) { + if ( my $location = $response->redirect ) { $c->log->debug(qq/Redirecting to "$location"/) if $c->debug; - $c->response->header( Location => $location ); - - if ( !$c->response->body ) { + $response->header( Location => $location ); + + if ( !$response->has_body ) { # Add a default body if none is already present - $c->response->body( + $response->body( qq{

    This item has moved here.

    } ); } } # Content-Length - if ( $c->response->body && !$c->response->content_length ) { + if ( $response->body && !$response->content_length ) { # get the length from a filehandle - if ( blessed( $c->response->body ) && $c->response->body->can('read') ) + if ( blessed( $response->body ) && $response->body->can('read') ) { - my $stat = stat $c->response->body; + my $stat = stat $response->body; if ( $stat && $stat->size > 0 ) { - $c->response->content_length( $stat->size ); + $response->content_length( $stat->size ); } else { $c->log->warn('Serving filehandle without a content-length'); @@ -1595,14 +1630,14 @@ sub finalize_headers { } else { # everything should be bytes at this point, but just in case - $c->response->content_length( bytes::length( $c->response->body ) ); + $response->content_length( bytes::length( $response->body ) ); } } # Errors - if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) { - $c->response->headers->remove_header("Content-Length"); - $c->response->body(''); + if ( $response->status =~ /^(1\d\d|[23]04)$/ ) { + $response->headers->remove_header("Content-Length"); + $response->body(''); } $c->finalize_cookies; @@ -1610,7 +1645,7 @@ sub finalize_headers { $c->engine->finalize_headers( $c, @_ ); # Done - $c->response->{_finalized_headers} = 1; + $response->finalized_headers(1); } =head2 $c->finalize_output @@ -1680,7 +1715,10 @@ sub handle_request { } $COUNT++; - $class->log->_flush() if $class->log->can('_flush'); + + if(my $coderef = $class->log->can('_flush')){ + $class->log->$coderef(); + } return $status; } @@ -1694,48 +1732,24 @@ etc.). sub prepare { my ( $class, @arguments ) = @_; + # XXX + # After the app/ctxt split, this should become an attribute based on something passed + # into the application. $class->context_class( ref $class || $class ) unless $class->context_class; - my $c = $class->context_class->new( - { - counter => {}, - stack => [], - request => $class->request_class->new( - { - arguments => [], - body_parameters => {}, - cookies => {}, - headers => HTTP::Headers->new, - parameters => {}, - query_parameters => {}, - secure => 0, - captures => [], - uploads => {} - } - ), - response => $class->response_class->new( - { - body => '', - cookies => {}, - headers => HTTP::Headers->new(), - status => 200 - } - ), - stash => {}, - state => 0 - } - ); + + my $c = $class->context_class->new({}); + + # For on-demand data + $c->request->_context($c); + $c->response->_context($c); + #surely this is not the most efficient way to do things... $c->stats($class->stats_class->new)->enable($c->use_stats); if ( $c->debug ) { $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION ); } - # For on-demand data - $c->request->{_context} = $c; - $c->response->{_context} = $c; - weaken( $c->request->{_context} ); - weaken( $c->response->{_context} ); - + #XXX reuse coderef from can # Allow engine to direct the prepare flow (for POE) if ( $c->engine->can('prepare') ) { $c->engine->prepare( $c, @arguments ); @@ -1788,8 +1802,7 @@ Prepares message body. sub prepare_body { my $c = shift; - # Do we run for the first time? - return if defined $c->request->{_body}; + return if $c->request->_has_body; # Initialize on-demand data $c->engine->prepare_body( $c, @_ ); @@ -2034,7 +2047,12 @@ sub setup_components { my @comps = sort { length $a <=> length $b } $locator->plugins; my %comps = map { $_ => 1 } @comps; - + + my $deprecated_component_names = grep { /::[CMV]::/ } @comps; + $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}. + qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n} + ); + for my $component ( @comps ) { # We pass ignore_loaded here so that overlay files for (e.g.) @@ -2042,6 +2060,7 @@ sub setup_components { # we know M::P::O found a file on disk so this is safe Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } ); + #Class::MOP::load_class($component); my $module = $class->setup_component( $component ); my %modules = ( @@ -2085,7 +2104,7 @@ sub setup_component { Catalyst::Exception->throw( message => qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/ - ) unless eval { $instance->can( 'can' ) }; + ) unless blessed($instance); return $instance; } @@ -2111,9 +2130,7 @@ sub setup_dispatcher { $dispatcher = $class->dispatcher_class; } - unless (Class::Inspector->loaded($dispatcher)) { - require Class::Inspector->filename($dispatcher); - } + Class::MOP::load_class($dispatcher); # dispatcher instance $class->dispatcher( $dispatcher->new ); @@ -2137,12 +2154,10 @@ sub setup_engine { } if ( $ENV{MOD_PERL} ) { - + my $meta = Class::MOP::get_metaclass_by_name($class); + # create the apache method - { - no strict 'refs'; - *{"$class\::apache"} = sub { shift->engine->apache }; - } + $meta->add_method('apache' => sub { shift->engine->apache }); my ( $software, $version ) = $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/; @@ -2199,9 +2214,7 @@ sub setup_engine { $engine = $class->engine_class; } - unless (Class::Inspector->loaded($engine)) { - require Class::Inspector->filename($engine); - } + Class::MOP::load_class($engine); # check for old engines that are no longer compatible my $old_engine; @@ -2252,11 +2265,10 @@ sub setup_home { $home = $env; } - unless ($home) { - $home = Catalyst::Utils::home($class); - } + $home ||= Catalyst::Utils::home($class); if ($home) { + #I remember recently being scolded for assigning config values like this $class->config->{home} ||= $home; $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root'); } @@ -2264,21 +2276,35 @@ sub setup_home { =head2 $c->setup_log -Sets up log. +Sets up log by instantiating a L object and +passing it to C. Pass in a comma-delimited list of levels to set the +log to. + +This method also installs a C method that returns a true value into the +catalyst subclass if the "debug" level is passed in the comma-delimited list, +or if the C<$CATALYST_DEBUG> environment variable is set to a true value. + +Note that if the log has already been setup, by either a previous call to +C or by a call such as C<< __PACKAGE__->log( MyLogger->new ) >>, +that this method won't actually set up the log object. =cut sub setup_log { - my ( $class, $debug ) = @_; + my ( $class, $levels ) = @_; + $levels ||= ''; + $levels =~ s/^\s+//; + $levels =~ s/\s+$//; + my %levels = map { $_ => 1 } split /\s*,\s*/, $levels || ''; + unless ( $class->log ) { - $class->log( Catalyst::Log->new ); + $class->log( Catalyst::Log->new(keys %levels) ); } my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' ); - if ( defined($env_debug) ? $env_debug : $debug ) { - no strict 'refs'; - *{"$class\::debug"} = sub { 1 }; + if ( defined($env_debug) or $levels{debug} ) { + Class::MOP::get_metaclass_by_name($class)->add_method('debug' => sub { 1 }); $class->log->debug('Debug messages enabled'); } } @@ -2302,8 +2328,7 @@ sub setup_stats { my $env = Catalyst::Utils::env_value( $class, 'STATS' ); if ( defined($env) ? $env : ($stats || $class->debug ) ) { - no strict 'refs'; - *{"$class\::use_stats"} = sub { 1 }; + Class::MOP::get_metaclass_by_name($class)->add_method('use_stats' => sub { 1 }); $class->log->debug('Statistics enabled'); } } @@ -2341,12 +2366,17 @@ the plugin name does not begin with C. # no ignore_loaded here, the plugin may already have been # defined in memory and we don't want to error on "no file" if so - Catalyst::Utils::ensure_class_loaded( $plugin ); + Class::MOP::load_class( $plugin ); $proto->_plugins->{$plugin} = 1; unless ($instant) { no strict 'refs'; - unshift @{"$class\::ISA"}, $plugin; + if ( my $meta = Class::MOP::get_metaclass_by_name($class) ) { + my @superclasses = ($plugin, $meta->superclasses ); + $meta->superclasses(@superclasses); + } else { + unshift @{"$class\::ISA"}, $plugin; + } } return $class; } @@ -2492,8 +2522,8 @@ IRC: Mailing Lists: - http://lists.rawmode.org/mailman/listinfo/catalyst - http://lists.rawmode.org/mailman/listinfo/catalyst-dev + http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst + http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev Web: @@ -2543,10 +2573,14 @@ audreyt: Audrey Tang bricas: Brian Cassidy +Caelum: Rafael Kitover + chansen: Christian Hansen chicks: Christopher Hicks +David E. Wheeler + dkubb: Dan Kubb Drew Taylor @@ -2561,6 +2595,8 @@ Gary Ashton Jones Geoff Richards +ilmari: Dagfinn Ilmari Mannsåker + jcamacho: Juan Camacho jhannah: Jay Hannah @@ -2595,16 +2631,18 @@ Oleg Kostyuk phaylon: Robert Sedlacek +rafl: Florian Ragwitz + sky: Arthur Bergman the_jester: Jesse Sheidlower +t0m: Tomas Doran + Ulf Edvinsson willert: Sebastian Willert -batman: Jan Henning Thorsen - =head1 LICENSE This library is free software, you can redistribute it and/or modify it under @@ -2612,4 +2650,8 @@ the same terms as Perl itself. =cut +no Moose; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/Action.pm b/lib/Catalyst/Action.pm index 6c9e9a1..b96bfbc 100644 --- a/lib/Catalyst/Action.pm +++ b/lib/Catalyst/Action.pm @@ -1,16 +1,12 @@ package Catalyst::Action; -use strict; -use base qw/Class::Accessor::Fast/; - - =head1 NAME Catalyst::Action - Catalyst Action =head1 SYNOPSIS -
    + =head1 DESCRIPTION @@ -21,7 +17,18 @@ L subclasses. =cut -__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/); +use Moose; + +with 'MooseX::Emulate::Class::Accessor::Fast'; + +has class => (is => 'rw'); +has namespace => (is => 'rw'); +has 'reverse' => (is => 'rw'); +has attributes => (is => 'rw'); +has name => (is => 'rw'); +has code => (is => 'rw'); + +no Moose; use overload ( @@ -36,6 +43,12 @@ use overload ( ); + + +no warnings 'recursion'; + +#__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/); + sub dispatch { # Execute ourselves against a context my ( $self, $c ) = @_; return $c->execute( $self->class, $self ); @@ -43,17 +56,22 @@ sub dispatch { # Execute ourselves against a context sub execute { my $self = shift; - $self->{code}->(@_); + $self->code->(@_); } sub match { my ( $self, $c ) = @_; + #would it be unreasonable to store the number of arguments + #the action has as it's own attribute? + #it would basically eliminate the code below. ehhh. small fish return 1 unless exists $self->attributes->{Args}; my $args = $self->attributes->{Args}[0]; return 1 unless defined($args) && length($args); return scalar( @{ $c->req->args } ) == $args; } +__PACKAGE__->meta->make_immutable; + 1; __END__ @@ -99,6 +117,10 @@ Returns the private path for this action. returns the sub name of this action. +=head2 meta + +Provided by Moose + =head1 AUTHORS Catalyst Contributors, see Catalyst.pm diff --git a/lib/Catalyst/ActionChain.pm b/lib/Catalyst/ActionChain.pm index 9ef1513..1518802 100644 --- a/lib/Catalyst/ActionChain.pm +++ b/lib/Catalyst/ActionChain.pm @@ -1,8 +1,11 @@ package Catalyst::ActionChain; -use strict; -use base qw/Catalyst::Action/; +use Moose; +extends qw(Catalyst::Action); +has chain => (is => 'rw'); + +no Moose; =head1 NAME @@ -20,22 +23,6 @@ the actions in the chain in order. =cut -__PACKAGE__->mk_accessors(qw/chain/); - -use overload ( - - # Stringify to reverse for debug output etc. - q{""} => sub { shift->{reverse} }, - - # Codulate to execute to invoke the encapsulated action coderef - '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; }, - - # Make general $stuff still work - fallback => 1, - -); - - sub dispatch { my ( $self, $c ) = @_; my @captures = @{$c->req->captures||[]}; @@ -58,6 +45,7 @@ sub from_chain { return $self->new({ %$final, chain => $actions }); } +__PACKAGE__->meta->make_immutable; 1; __END__ @@ -79,6 +67,10 @@ actions in order. Takes a list of Catalyst::Action objects and constructs and returns a Catalyst::ActionChain object representing a chain of these actions +=head2 meta + +Provided by Moose + =head1 AUTHORS Catalyst Contributors, see Catalyst.pm diff --git a/lib/Catalyst/ActionContainer.pm b/lib/Catalyst/ActionContainer.pm index 9adab59..848f71a 100644 --- a/lib/Catalyst/ActionContainer.pm +++ b/lib/Catalyst/ActionContainer.pm @@ -1,8 +1,5 @@ package Catalyst::ActionContainer; -use strict; -use base qw/Class::Accessor::Fast/; - =head1 NAME Catalyst::ActionContainer - Catalyst Action Container @@ -18,24 +15,24 @@ to represent the various dispatch points in your application. =cut -__PACKAGE__->mk_accessors(qw/part actions/); - -use overload ( - - # Stringify to path part for tree search - q{""} => sub { shift->{part} }, - -); +use Moose; +with 'MooseX::Emulate::Class::Accessor::Fast'; -sub new { - my ( $class, $fields ) = @_; +has part => (is => 'rw', required => 1); +has actions => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); - $fields = { part => $fields, actions => {} } unless ref $fields; - - $class->SUPER::new($fields); -} +around BUILDARGS => sub { + my ($next, $self, @args) = @_; + unshift @args, 'part' if scalar @args == 1 && !ref $args[0]; + return $self->$next(@args); +}; +no Moose; +use overload ( + # Stringify to path part for tree search + q{""} => sub { shift->part }, +); sub get_action { my ( $self, $name ) = @_; @@ -49,6 +46,8 @@ sub add_action { $self->actions->{$name} = $action; } +__PACKAGE__->meta->make_immutable; + 1; __END__ @@ -78,6 +77,10 @@ Accessor to the actions hashref, containing all actions in this container. Accessor to the path part this container resolves to. Also what the container stringifies to. +=head2 meta + +Provided by Moose + =head1 AUTHORS Catalyst Contributors, see Catalyst.pm diff --git a/lib/Catalyst/AttrContainer.pm b/lib/Catalyst/AttrContainer.pm index f699d9f..443b416 100644 --- a/lib/Catalyst/AttrContainer.pm +++ b/lib/Catalyst/AttrContainer.pm @@ -1,14 +1,13 @@ package Catalyst::AttrContainer; -use strict; -use base qw/Class::Accessor::Fast Class::Data::Inheritable/; - +use Moose; use Catalyst::Exception; -use NEXT; +with 'Catalyst::ClassData'; + +no Moose; -__PACKAGE__->mk_classdata($_) for qw/_attr_cache _action_cache/; -__PACKAGE__->_attr_cache( {} ); -__PACKAGE__->_action_cache( [] ); +__PACKAGE__->mk_classdata(_attr_cache => {} ); +__PACKAGE__->mk_classdata( _action_cache => [] ); # note - see attributes(3pm) sub MODIFY_CODE_ATTRIBUTES { diff --git a/lib/Catalyst/Base.pm b/lib/Catalyst/Base.pm index e6bd821..659a97d 100644 --- a/lib/Catalyst/Base.pm +++ b/lib/Catalyst/Base.pm @@ -1,7 +1,8 @@ package Catalyst::Base; -use strict; use base qw/Catalyst::Controller/; +use Moose; +no Moose; 1; @@ -14,7 +15,7 @@ Catalyst::Base - Deprecated base class =head1 DESCRIPTION This used to be the base class for Catalyst Controllers. It -remains here for compability reasons. +remains here for compatibility reasons. =head1 SEE ALSO diff --git a/lib/Catalyst/ClassData.pm b/lib/Catalyst/ClassData.pm new file mode 100644 index 0000000..72062d9 --- /dev/null +++ b/lib/Catalyst/ClassData.pm @@ -0,0 +1,87 @@ +package Catalyst::ClassData; + +use Moose::Role; +use Class::MOP; +use Class::MOP::Object; + +sub mk_classdata { + my ($class, $attribute) = @_; + confess("mk_classdata() is a class method, not an object method") + if blessed $class; + + my $slot = '$'.$attribute; + my $accessor = sub { + my $pkg = ref $_[0] || $_[0]; + # Hack - delberately create a metaclass instance + my $meta = $pkg->Class::MOP::Object::meta(); + if (@_ > 1) { + $meta->namespace->{$attribute} = \$_[1]; + return $_[1]; + } + + # tighter version of + # if ( $meta->has_package_symbol($slot) ) { + # return ${ $meta->get_package_symbol($slot) }; + # } + no strict 'refs'; + my $v = *{"${pkg}::${attribute}"}{SCALAR}; + if (defined ${$v}) { + return ${$v}; + } else { + foreach my $super ( $meta->linearized_isa ) { + # tighter version of same after + # my $super_meta = Moose::Meta::Class->initialize($super); + my $v = ${"${super}::"}{$attribute} ? *{"${super}::${attribute}"}{SCALAR} : undef; + if (defined ${$v}) { + return ${$v}; + } + } + } + return; + }; + + confess("Failed to create accessor: $@ ") + unless ref $accessor eq 'CODE'; + + my $meta = $class->Class::MOP::Object::meta(); + my $immutable_options; + if( $meta->is_immutable ){ + $immutable_options = $meta->get_immutable_options; + $meta->make_mutable; + } + my $alias = "_${attribute}_accessor"; + $meta->add_method($alias, $accessor); + $meta->add_method($attribute, $accessor); + if(defined $immutable_options){ + $meta->make_immutable(%{ $immutable_options }); + } + $class->$attribute($_[2]) if(@_ > 2); + return $accessor; +} + +1; + +__END__ + + +=head1 NAME + +Catalyst::ClassData - Class data accessors + +=head1 METHODS + +=head2 mk_classdata $name, $optional_value + +A moose-safe clone of L that borrows some ideas from +L; + +=head1 AUTHOR + +Guillermo Roditi + +=head1 COPYRIGHT + +This program is free software, you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/Catalyst/Component.pm b/lib/Catalyst/Component.pm index 0b48725..80fc838 100644 --- a/lib/Catalyst/Component.pm +++ b/lib/Catalyst/Component.pm @@ -1,9 +1,15 @@ package Catalyst::Component; -use strict; -use base qw/Class::Accessor::Fast Class::Data::Inheritable/; -use NEXT; +use Moose; +use Class::MOP; +use Class::MOP::Object; use Catalyst::Utils; +use Class::C3::Adopt::NEXT; +use MRO::Compat; +use mro 'c3'; + +with 'MooseX::Emulate::Class::Accessor::Fast'; +with 'Catalyst::ClassData'; =head1 NAME @@ -49,18 +55,18 @@ component loader with config() support and a process() method placeholder. =cut -__PACKAGE__->mk_classdata($_) for qw/_config _plugins/; - - - -sub new { - my ( $self, $c ) = @_; +__PACKAGE__->mk_classdata('_plugins'); +__PACKAGE__->mk_classdata('_config'); +sub BUILDARGS { + my ($self) = @_; + # Temporary fix, some components does not pass context to constructor my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {}; - return $self->NEXT::new( - $self->merge_config_hashes( $self->config, $arguments ) ); + my $args = $self->merge_config_hashes( $self->config, $arguments ); + + return $args; } sub COMPONENT { @@ -68,27 +74,20 @@ sub COMPONENT { # Temporary fix, some components does not pass context to constructor my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {}; - - if ( my $new = $self->NEXT::COMPONENT( $c, $arguments ) ) { - return $new; - } - else { - if ( my $new = $self->new( $c, $arguments ) ) { - return $new; - } - else { - my $class = ref $self || $self; - my $new = $self->merge_config_hashes( - $self->config, $arguments ); - return bless $new, $class; - } + if( my $next = $self->next::can ){ + my $class = blessed $self || $self; + my ($next_package) = Class::MOP::get_code_info($next); + warn "There is a COMPONENT method resolving after Catalyst::Component in ${next_package}.\n"; + warn "This behavior can no longer be supported, and so your application is probably broken.\n"; + warn "Your linearised isa hierarchy is: " . join(', ', mro::get_linear_isa($class)) . "\n"; + warn "Please see perldoc Catalyst::Upgrading for more information about this issue.\n"; } + return $self->new($c, $arguments); } sub config { my $self = shift; - my $config_sub = $self->can('_config'); - my $config = $self->$config_sub() || {}; + my $config = $self->_config || {}; if (@_) { my $newconfig = { %{@_ > 1 ? {@_} : $_[0]} }; $self->_config( @@ -97,18 +96,13 @@ sub config { } else { # this is a bit of a kludge, required to make # __PACKAGE__->config->{foo} = 'bar'; - # work in a subclass. Calling the Class::Data::Inheritable setter - # will create a new _config method in the current class if it's - # currently inherited from the superclass. So, the can() call will - # return a different subref in that case and that means we know to - # copy and reset the value stored in the class data. - - $self->_config( $config ); - - if ((my $config_sub_now = $self->can('_config')) ne $config_sub) { + # work in a subclass. + my $class = blessed($self) || $self; + my $meta = Class::MOP::get_metaclass_by_name($class); + unless ($meta->has_package_symbol('$_config')) { $config = $self->merge_config_hashes( $config, {} ); - $self->$config_sub_now( $config ); + $self->_config( $config ); } } return $config; @@ -126,6 +120,9 @@ sub process { . " did not override Catalyst::Component::process" ); } +no Moose; + +__PACKAGE__->meta->make_immutable; 1; __END__ @@ -173,7 +170,7 @@ Alias for the method in L. =head2 ACCEPT_CONTEXT($c, @args) -Catalyst components are normally initalized during server startup, either +Catalyst components are normally initialized during server startup, either as a Class or a Instance. However, some components require information about the current request. To do so, they can implement an ACCEPT_CONTEXT method. diff --git a/lib/Catalyst/Component/ApplicationAttribute.pm b/lib/Catalyst/Component/ApplicationAttribute.pm new file mode 100644 index 0000000..78b292a --- /dev/null +++ b/lib/Catalyst/Component/ApplicationAttribute.pm @@ -0,0 +1,73 @@ +package Catalyst::Component::ApplicationAttribute; + +use Moose::Role; +use namespace::clean -except => 'meta'; + +# Future - isa => 'ClassName|Catalyst' performance? +# required => 1 breaks tests.. +has _application => (is => 'ro', weak_ref => 1); +sub _app { (shift)->_application(@_) } + +override BUILDARGS => sub { + my ($self, $app) = @_; + + my $args = super(); + $args->{_application} = $app; + + return $args; +}; + +1; + +__END__ + +=head1 NAME + +Catalyst::Component::ApplicationAttribute - Moose Role for components which capture the application context. + +=head1 SYNOPSIS + + package My::Component; + use Moose; + extends 'Catalyst::Component'; + with 'Catalyst::Component::ApplicationAttribute'; + + # Your code here + + 1; + +=head1 DESCRIPTION + +This role provides a BUILDARGS method which captures the application context into an attribute. + +=head1 ATTRIBUTES + +=head2 _application + +Weak reference to the application context. + +=head1 METHODS + +=head2 BUILDARGS ($self, $app) + +BUILDARGS method captures the application context into the C<_application> attribute. + +=head2 _application + +Reader method for the application context. + +=head1 SEE ALSO + +L, +L. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This program is free software, you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/Catalyst/Controller.pm b/lib/Catalyst/Controller.pm index 5902597..18c8259 100644 --- a/lib/Catalyst/Controller.pm +++ b/lib/Catalyst/Controller.pm @@ -1,12 +1,48 @@ package Catalyst::Controller; -use strict; -use base qw/Catalyst::Component Catalyst::AttrContainer Class::Accessor::Fast/; +use Moose; +use Moose::Util qw/find_meta/; + +use namespace::clean -except => 'meta'; + +# Note - Must be done at compile time due to attributes (::AttrContainer) +BEGIN { extends qw/Catalyst::Component Catalyst::AttrContainer/; } use Catalyst::Exception; use Catalyst::Utils; -use Class::Inspector; -use NEXT; + +with 'Catalyst::Component::ApplicationAttribute'; + +has path_prefix => + ( + is => 'rw', + isa => 'Str', + init_arg => 'path', + predicate => 'has_path_prefix', + ); + +has action_namespace => + ( + is => 'rw', + isa => 'Str', + init_arg => 'namespace', + predicate => 'has_action_namespace', + ); + +has actions => + ( + is => 'rw', + isa => 'HashRef', + init_arg => undef, + ); + +sub BUILD { + my ($self, $args) = @_; + my $action = delete $args->{action} || {}; + my $actions = delete $args->{actions} || {}; + my $attr_value = $self->merge_config_hashes($actions, $action); + $self->actions($attr_value); +} =head1 NAME @@ -31,15 +67,13 @@ for more info about how Catalyst dispatches to actions. =cut +#I think both of these could be attributes. doesn't really seem like they need +#to ble class data. i think that attributes +default would work just fine __PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/; __PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] ); __PACKAGE__->_action_class('Catalyst::Action'); -__PACKAGE__->mk_accessors( qw/_application/ ); - -### _app as alias -*_app = *_application; sub _DISPATCH : Private { my ( $self, $c ) = @_; @@ -88,59 +122,75 @@ sub _END : Private { return !@{ $c->error }; } -sub new { - my $self = shift; - my $app = $_[0]; - my $new = $self->NEXT::new(@_); - $new->_application( $app ); - return $new; -} - - sub action_for { my ( $self, $name ) = @_; my $app = ($self->isa('Catalyst') ? $self : $self->_application); return $app->dispatcher->get_action($name, $self->action_namespace); } -sub action_namespace { +#my opinion is that this whole sub really should be a builder method, not +#something that happens on every call. Anyone else disagree?? -- groditi +## -- apparently this is all just waiting for app/ctx split +around action_namespace => sub { + my $orig = shift; my ( $self, $c ) = @_; - unless ( $c ) { - $c = ($self->isa('Catalyst') ? $self : $self->_application); + + if( ref($self) ){ + return $self->$orig if $self->has_action_namespace; + } else { + return $self->config->{namespace} if exists $self->config->{namespace}; } - my $hash = (ref $self ? $self : $self->config); # hate app-is-class - return $hash->{namespace} if exists $hash->{namespace}; - return Catalyst::Utils::class2prefix( ref($self) || $self, - $c->config->{case_sensitive} ) - || ''; -} -sub path_prefix { - my ( $self, $c ) = @_; - unless ( $c ) { - $c = ($self->isa('Catalyst') ? $self : $self->_application); + my $case_s; + if( $c ){ + $case_s = $c->config->{case_sensitive}; + } else { + if ($self->isa('Catalyst')) { + $case_s = $self->config->{case_sensitive}; + } else { + if (ref $self) { + $case_s = $self->_application->config->{case_sensitive}; + } else { + confess("Can't figure out case_sensitive setting"); + } + } } - my $hash = (ref $self ? $self : $self->config); # hate app-is-class - return $hash->{path} if exists $hash->{path}; - return shift->action_namespace(@_); -} + + my $namespace = Catalyst::Utils::class2prefix(ref($self) || $self, $case_s) || ''; + $self->$orig($namespace) if ref($self); + return $namespace; +}; + +#Once again, this is probably better written as a builder method +around path_prefix => sub { + my $orig = shift; + my $self = shift; + if( ref($self) ){ + return $self->$orig if $self->has_path_prefix; + } else { + return $self->config->{path} if exists $self->config->{path}; + } + my $namespace = $self->action_namespace(@_); + $self->$orig($namespace) if ref($self); + return $namespace; +}; sub register_actions { my ( $self, $c ) = @_; my $class = ref $self || $self; + #this is still not correct for some reason. my $namespace = $self->action_namespace($c); - my %methods; - $methods{ $self->can($_) } = $_ - for @{ Class::Inspector->methods($class) || [] }; + my $meta = find_meta($self); + my %methods = map { $_->body => $_->name } + $meta->get_all_methods; # Advanced inheritance support for plugins and the like + #moose todo: migrate to eliminate CDI compat my @action_cache; - { - no strict 'refs'; - for my $isa ( @{"$class\::ISA"}, $class ) { - push @action_cache, @{ $isa->_action_cache } - if $isa->can('_action_cache'); + for my $isa ( $meta->superclasses, $class ) { + if(my $coderef = $isa->can('_action_cache')){ + push(@action_cache, @{ $isa->$coderef }); } } @@ -156,7 +206,7 @@ sub register_actions { if $c->debug; next; } - my $reverse = $namespace ? "$namespace/$method" : $method; + my $reverse = $namespace ? "${namespace}/${method}" : $method; my $action = $self->create_action( name => $method, code => $code, @@ -178,10 +228,7 @@ sub create_action { ? $args{attributes}{ActionClass}[0] : $self->_action_class); - unless ( Class::Inspector->loaded($class) ) { - require Class::Inspector->filename($class); - } - + Class::MOP::load_class($class); return $class->new( \%args ); } @@ -204,15 +251,24 @@ sub _parse_attrs { } } - my $hash = (ref $self ? $self : $self->config); # hate app-is-class - - if (exists $hash->{actions} || exists $hash->{action}) { - my $a = $hash->{actions} || $hash->{action}; - %raw_attributes = ((exists $a->{'*'} ? %{$a->{'*'}} : ()), - %raw_attributes, - (exists $a->{$name} ? %{$a->{$name}} : ())); + #I know that the original behavior was to ignore action if actions was set + # but i actually think this may be a little more sane? we can always remove + # the merge behavior quite easily and go back to having actions have + # presedence over action by modifying the keys. i honestly think this is + # superior while mantaining really high degree of compat + my $actions; + if( ref($self) ) { + $actions = $self->actions; + } else { + my $cfg = $self->config; + $actions = $self->merge_config_hashes($cfg->{actions}, $cfg->{action}); } + %raw_attributes = ((exists $actions->{'*'} ? %{$actions->{'*'}} : ()), + %raw_attributes, + (exists $actions->{$name} ? %{$actions->{$name}} : ())); + + my %final_attributes; foreach my $key (keys %raw_attributes) { @@ -222,8 +278,8 @@ sub _parse_attrs { foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) { my $meth = "_parse_${key}_attr"; - if ( $self->can($meth) ) { - ( $key, $value ) = $self->$meth( $c, $name, $value ); + if ( my $code = $self->can($meth) ) { + ( $key, $value ) = $self->$code( $c, $name, $value ); } push( @{ $final_attributes{$key} }, $value ); } @@ -333,6 +389,8 @@ sub _parse_MyAction_attr { return ( 'ActionClass', $value ); } +__PACKAGE__->meta->make_immutable; + 1; __END__ diff --git a/lib/Catalyst/DispatchType.pm b/lib/Catalyst/DispatchType.pm index ce16150..6ac653d 100644 --- a/lib/Catalyst/DispatchType.pm +++ b/lib/Catalyst/DispatchType.pm @@ -1,7 +1,8 @@ package Catalyst::DispatchType; -use strict; -use base 'Class::Accessor::Fast'; +use Moose; +with 'MooseX::Emulate::Class::Accessor::Fast'; +no Moose; =head1 NAME @@ -46,15 +47,6 @@ Should return true if it registers something, or false otherwise. sub register { } -=head2 $self->expand_action - -Default fallback, returns nothing. See L for more info -about expand_action. - -=cut - -sub expand_action { } - =head2 $self->uri_for_action( $action, \@captures ) abstract method, to be implemented by dispatchtypes. Takes a @@ -67,6 +59,15 @@ arrayref, or undef if unable to do so. sub uri_for_action { } +=head2 $self->expand_action + +Default fallback, returns nothing. See L for more info +about expand_action. + +=cut + +sub expand_action { } + =head1 AUTHORS Catalyst Contributors, see Catalyst.pm @@ -78,4 +79,6 @@ the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/DispatchType/Chained.pm b/lib/Catalyst/DispatchType/Chained.pm index dccd3c9..3b7502e 100644 --- a/lib/Catalyst/DispatchType/Chained.pm +++ b/lib/Catalyst/DispatchType/Chained.pm @@ -1,12 +1,36 @@ package Catalyst::DispatchType::Chained; -use strict; -use base qw/Catalyst::DispatchType/; +use Moose; +extends 'Catalyst::DispatchType'; + use Text::SimpleTable; use Catalyst::ActionChain; use Catalyst::Utils; use URI; +has _endpoints => ( + is => 'rw', + isa => 'ArrayRef', + required => 1, + default => sub{ [] }, + ); + +has _actions => ( + is => 'rw', + isa => 'HashRef', + required => 1, + default => sub{ {} }, + ); + +has _children_of => ( + is => 'rw', + isa => 'HashRef', + required => 1, + default => sub{ {} }, + ); + +no Moose; + # please don't perltidy this. hairy code within. =head1 NAME @@ -42,16 +66,21 @@ Debug output for Path Part dispatch points sub list { my ( $self, $c ) = @_; - return unless $self->{endpoints}; + return unless $self->_endpoints; my $column_width = Catalyst::Utils::term_width() - 35 - 9; my $paths = Text::SimpleTable->new( - [ 35, 'Path Spec' ], [ 36, 'Private' ], [ $column_width, 'Private' ] + [ 35, 'Path Spec' ], [ $column_width, 'Private' ], + ); + + my $has_unattached_actions; + my $unattached_actions = Text::SimpleTable->new( + [ 35, 'Private' ], [ 36, 'Missing parent' ], ); ENDPOINT: foreach my $endpoint ( sort { $a->reverse cmp $b->reverse } - @{ $self->{endpoints} } + @{ $self->_endpoints } ) { my $args = $endpoint->attributes->{Args}->[0]; my @parts = (defined($args) ? (("*") x $args) : '...'); @@ -67,10 +96,14 @@ sub list { if (defined $pp->[0] && length $pp->[0]); } $parent = $curr->attributes->{Chained}->[0]; - $curr = $self->{actions}{$parent}; + $curr = $self->_actions->{$parent}; unshift(@parents, $curr) if $curr; } - next ENDPOINT unless $parent eq '/'; # skip dangling action + if ($parent ne '/') { + $has_unattached_actions = 1; + $unattached_actions->row('/'.$parents[0]->reverse, $parent); + next ENDPOINT; + } my @rows; foreach my $p (@parents) { my $name = "/${p}"; @@ -88,6 +121,8 @@ sub list { } $c->log->debug( "Loaded Chained actions:\n" . $paths->draw . "\n" ); + $c->log->debug( "Unattached Chained actions:\n", $unattached_actions->draw . "\n" ) + if $has_unattached_actions; } =head2 $self->match( $c, $path ) @@ -99,20 +134,21 @@ Calls C to see if a chain matches the C<$path>. sub match { my ( $self, $c, $path ) = @_; - return 0 if @{$c->req->args}; + my $request = $c->request; + return 0 if @{$request->args}; my @parts = split('/', $path); my ($chain, $captures, $parts) = $self->recurse_match($c, '/', \@parts); - push @{$c->req->args}, @$parts if $parts && @$parts; + push @{$request->args}, @$parts if $parts && @$parts; return 0 unless $chain; my $action = Catalyst::ActionChain->from_chain($chain); - $c->req->action("/${action}"); - $c->req->match("/${action}"); - $c->req->captures($captures); + $request->action("/${action}"); + $request->match("/${action}"); + $request->captures($captures); $c->action($action); $c->namespace( $action->namespace ); @@ -127,7 +163,7 @@ Recursive search for a matching chain. sub recurse_match { my ( $self, $c, $parent, $path_parts ) = @_; - my $children = $self->{children_of}{$parent}; + my $children = $self->_children_of->{$parent}; return () unless $children; my $best_action; my @captures; @@ -223,7 +259,7 @@ sub register { ); } - my $children = ($self->{children_of}{ $chained_attr[0] } ||= {}); + my $children = ($self->_children_of->{ $chained_attr[0] } ||= {}); my @path_part = @{ $action->attributes->{PathPart} || [] }; @@ -233,13 +269,13 @@ sub register { $part = $path_part[0]; } elsif (@path_part > 1) { Catalyst::Exception->throw( - "Multiple PathPart attributes not supported registering ${action}" + "Multiple PathPart attributes not supported registering " . $action->reverse() ); } if ($part =~ m(^/)) { Catalyst::Exception->throw( - "Absolute parameters to PathPart not allowed registering ${action}" + "Absolute parameters to PathPart not allowed registering " . $action->reverse() ); } @@ -247,10 +283,10 @@ sub register { unshift(@{ $children->{$part} ||= [] }, $action); - ($self->{actions} ||= {})->{'/'.$action->reverse} = $action; + $self->_actions->{'/'.$action->reverse} = $action; unless ($action->attributes->{CaptureArgs}) { - unshift(@{ $self->{endpoints} ||= [] }, $action); + unshift(@{ $self->_endpoints }, $action); } return 1; @@ -285,7 +321,7 @@ sub uri_for_action { if (defined($pp->[0]) && length($pp->[0])); } $parent = $curr->attributes->{Chained}->[0]; - $curr = $self->{actions}{$parent}; + $curr = $self->_actions->{$parent}; } return undef unless $parent eq '/'; # fail for dangling action @@ -315,12 +351,14 @@ sub expand_action { while ($curr) { push @chain, $curr; my $parent = $curr->attributes->{Chained}->[0]; - $curr = $self->{'actions'}{$parent}; + $curr = $self->_actions->{$parent}; } return Catalyst::ActionChain->from_chain([reverse @chain]); } +__PACKAGE__->meta->make_immutable; + =head1 USAGE =head2 Introduction diff --git a/lib/Catalyst/DispatchType/Default.pm b/lib/Catalyst/DispatchType/Default.pm index e1d0050..2fc3bc9 100644 --- a/lib/Catalyst/DispatchType/Default.pm +++ b/lib/Catalyst/DispatchType/Default.pm @@ -1,7 +1,9 @@ package Catalyst::DispatchType::Default; -use strict; -use base qw/Catalyst::DispatchType/; +use Moose; +extends 'Catalyst::DispatchType'; + +no Moose; =head1 NAME @@ -56,4 +58,6 @@ the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/DispatchType/Index.pm b/lib/Catalyst/DispatchType/Index.pm index 8a85c50..610e0a4 100644 --- a/lib/Catalyst/DispatchType/Index.pm +++ b/lib/Catalyst/DispatchType/Index.pm @@ -1,7 +1,8 @@ package Catalyst::DispatchType::Index; -use strict; -use base qw/Catalyst::DispatchType/; +use Moose; +extends 'Catalyst::DispatchType'; +no Moose; =head1 NAME @@ -66,4 +67,6 @@ the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/DispatchType/Path.pm b/lib/Catalyst/DispatchType/Path.pm index 9135d70..d58f1fd 100644 --- a/lib/Catalyst/DispatchType/Path.pm +++ b/lib/Catalyst/DispatchType/Path.pm @@ -1,11 +1,21 @@ package Catalyst::DispatchType::Path; -use strict; -use base qw/Catalyst::DispatchType/; +use Moose; +extends 'Catalyst::DispatchType'; + use Text::SimpleTable; use Catalyst::Utils; use URI; +has _paths => ( + is => 'rw', + isa => 'HashRef', + required => 1, + default => sub { +{} }, + ); + +no Moose; + =head1 NAME Catalyst::DispatchType::Path - Path DispatchType @@ -30,14 +40,14 @@ sub list { my $paths = Text::SimpleTable->new( [ 35, 'Path' ], [ $column_width, 'Private' ] ); - foreach my $path ( sort keys %{ $self->{paths} } ) { + foreach my $path ( sort keys %{ $self->_paths } ) { my $display_path = $path eq '/' ? $path : "/$path"; - foreach my $action ( @{ $self->{paths}->{$path} } ) { + foreach my $action ( @{ $self->_paths->{$path} } ) { $paths->row( $display_path, "/$action" ); } } $c->log->debug( "Loaded Path actions:\n" . $paths->draw . "\n" ) - if ( keys %{ $self->{paths} } ); + if ( keys %{ $self->_paths } ); } =head2 $self->match( $c, $path ) @@ -53,7 +63,7 @@ sub match { $path = '/' if !defined $path || !length $path; - foreach my $action ( @{ $self->{paths}->{$path} || [] } ) { + foreach my $action ( @{ $self->_paths->{$path} || [] } ) { next unless $action->match($c); $c->req->action($path); $c->req->match($path); @@ -94,7 +104,7 @@ sub register_path { $path = '/' unless length $path; $path = URI->new($path)->canonical; - unshift( @{ $self->{paths}{$path} ||= [] }, $action); + unshift( @{ $self->_paths->{$path} ||= [] }, $action); return 1; } @@ -133,4 +143,6 @@ the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/DispatchType/Regex.pm b/lib/Catalyst/DispatchType/Regex.pm index d6d283d..1ffa932 100644 --- a/lib/Catalyst/DispatchType/Regex.pm +++ b/lib/Catalyst/DispatchType/Regex.pm @@ -1,11 +1,21 @@ package Catalyst::DispatchType::Regex; -use strict; -use base qw/Catalyst::DispatchType::Path/; +use Moose; +extends 'Catalyst::DispatchType::Path'; + use Text::SimpleTable; use Catalyst::Utils; use Text::Balanced (); +has _compiled => ( + is => 'rw', + isa => 'ArrayRef', + required => 1, + default => sub{ [] }, + ); + +no Moose; + =head1 NAME Catalyst::DispatchType::Regex - Regex DispatchType @@ -28,12 +38,12 @@ sub list { my ( $self, $c ) = @_; my $column_width = Catalyst::Utils::term_width() - 35 - 9; my $re = Text::SimpleTable->new( [ 35, 'Regex' ], [ $column_width, 'Private' ] ); - for my $regex ( @{ $self->{compiled} } ) { + for my $regex ( @{ $self->_compiled } ) { my $action = $regex->{action}; $re->row( $regex->{path}, "/$action" ); } $c->log->debug( "Loaded Regex actions:\n" . $re->draw . "\n" ) - if ( @{ $self->{compiled} } ); + if ( @{ $self->_compiled } ); } =head2 $self->match( $c, $path ) @@ -52,7 +62,7 @@ sub match { # Check path against plain text first - foreach my $compiled ( @{ $self->{compiled} || [] } ) { + foreach my $compiled ( @{ $self->_compiled } ) { if ( my @captures = ( $path =~ $compiled->{re} ) ) { next unless $compiled->{action}->match($c); $c->req->action( $compiled->{path} ); @@ -92,7 +102,7 @@ sub register { =head2 $self->register_regex($c, $re, $action) -Register an individual regex on the action. Usually called from the +Register an individual regex on the action. Usually called from the register method. =cut @@ -100,7 +110,7 @@ register method. sub register_regex { my ( $self, $c, $re, $action ) = @_; push( - @{ $self->{compiled} }, # and compiled regex for us + @{ $self->_compiled }, # and compiled regex for us { re => qr#$re#, action => $action, @@ -152,4 +162,6 @@ the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/Dispatcher.pm b/lib/Catalyst/Dispatcher.pm index 2b81250..08652e5 100644 --- a/lib/Catalyst/Dispatcher.pm +++ b/lib/Catalyst/Dispatcher.pm @@ -1,7 +1,9 @@ package Catalyst::Dispatcher; -use strict; -use base 'Class::Accessor::Fast'; +use Moose; +use Class::MOP; +with 'MooseX::Emulate::Class::Accessor::Fast'; + use Catalyst::Exception; use Catalyst::Utils; use Catalyst::Action; @@ -12,18 +14,10 @@ use Catalyst::Utils; use Text::SimpleTable; use Tree::Simple; use Tree::Simple::Visitor::FindByPath; -use Scalar::Util (); - -# Stringify to class -use overload '""' => sub { return ref shift }, fallback => 1; -__PACKAGE__->mk_accessors( - qw/tree dispatch_types registered_dispatch_types - method_action_class action_container_class - preload_dispatch_types postload_dispatch_types - action_hash container_hash - / -); +# Refactoring note: +# do these belong as package vars or should we build these via a builder method? +# See Catalyst-Plugin-Server for them being added to, which should be much less ugly. # Preload these action types our @PRELOAD = qw/Index Path Regex/; @@ -31,6 +25,27 @@ our @PRELOAD = qw/Index Path Regex/; # Postload these action types our @POSTLOAD = qw/Default/; +# Note - see back-compat methods at end of file. +has _tree => (is => 'rw'); +has _dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1); +has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1); +has _method_action_class => (is => 'rw', default => 'Catalyst::Action'); +has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); +has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); + +has preload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@PRELOAD] }); +has postload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@POSTLOAD] }); + +# Wrap accessors so you can assign a list and it will capture a list ref. +around qw/preload_dispatch_types postload_dispatch_types/ => sub { + my $orig = shift; + my $self = shift; + return $self->$orig([@_]) if (scalar @_ && ref $_[0] ne 'ARRAY'); + return $self->$orig(@_); +}; + +no Moose; + =head1 NAME Catalyst::Dispatcher - The Catalyst Dispatcher @@ -52,24 +67,13 @@ Construct a new dispatcher. =cut -sub new { - my $self = shift; - my $class = ref($self) || $self; +sub BUILD { + my ($self, $params) = @_; - my $obj = $class->SUPER::new(@_); + my $container = + Catalyst::ActionContainer->new( { part => '/', actions => {} } ); - # set the default pre- and and postloads - $obj->preload_dispatch_types( \@PRELOAD ); - $obj->postload_dispatch_types( \@POSTLOAD ); - $obj->action_hash( {} ); - $obj->container_hash( {} ); - - # Create the root node of the tree - my $container = - Catalyst::ActionContainer->new( { part => '/', actions => {} } ); - $obj->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) ); - - return $obj; + $self->_tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) ); } =head2 $self->preload_dispatch_types @@ -92,32 +96,18 @@ it with a C<+>, like so: +My::Dispatch::Type -=head2 $self->detach( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub detach { - my ( $self, $c, $command, @args ) = @_; - $c->forward( $command, @args ) if $command; - die $Catalyst::DETACH; -} - =head2 $self->dispatch($c) Delegate the dispatch to the action that matched the url, or return a message about unknown resource - =cut sub dispatch { my ( $self, $c ) = @_; - if ( $c->action ) { - $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) ); + if ( my $action = $c->action ) { + $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) ); } - else { my $path = $c->req->path; my $error = $path @@ -141,7 +131,7 @@ sub _command2action { } my @args; - + if ( ref( $extra_params[-1] ) eq 'ARRAY' ) { @args = @{ pop @extra_params } } else { @@ -152,12 +142,12 @@ sub _command2action { my $action; - if (Scalar::Util::blessed($command) && $command->isa('Catalyst::Action')) { + # go to a string path ("/foo/bar/gorch") + # or action object + if (blessed($command) && $command->isa('Catalyst::Action')) { $action = $command; } else { - # go to a string path ("/foo/bar/gorch") - # or action object which stringifies to that $action = $self->_invoke_as_path( $c, "$command", \@args ); } @@ -240,24 +230,43 @@ Documented in L sub forward { my $self = shift; + $self->_do_forward(forward => @_); +} + +sub _do_forward { + my $self = shift; + my $opname = shift; my ( $c, $command ) = @_; my ( $action, $args ) = $self->_command2action(@_); - unless ($action) { - my $error = - qq/Couldn't forward to command "$command": / - . qq/Invalid action or component./; + if (!$action) { + my $error .= qq/Couldn't $opname to command "$command": / + .qq/Invalid action or component./; $c->error($error); $c->log->debug($error) if $c->debug; return 0; } + no warnings 'recursion'; + local $c->request->{arguments} = $args; $action->dispatch( $c ); return $c->state; } +=head2 $self->detach( $c, $command [, \@arguments ] ) + +Documented in L + +=cut + +sub detach { + my ( $self, $c, $command, @args ) = @_; + $self->_do_forward(detach => $c, $command, @args ) if $command; + die $Catalyst::DETACH; +} + sub _action_rel2abs { my ( $self, $c, $path ) = @_; @@ -306,7 +315,7 @@ sub _invoke_as_component { my $class = $self->_find_component_class( $c, $component ) || return 0; if ( my $code = $class->can($method) ) { - return $self->method_action_class->new( + return $self->_method_action_class->new( { name => $method, code => $code, @@ -336,9 +345,10 @@ Find an dispatch type that matches $c->req->path, and set args from it. sub prepare_action { my ( $self, $c ) = @_; - my $path = $c->req->path; - my @path = split /\//, $c->req->path; - $c->req->args( \my @args ); + my $req = $c->req; + my $path = $req->path; + my @path = split /\//, $req->path; + $req->args( \my @args ); unshift( @path, '' ); # Root action @@ -351,7 +361,7 @@ sub prepare_action { # Check out dispatch types to see if any will handle the path at # this level - foreach my $type ( @{ $self->dispatch_types } ) { + foreach my $type ( @{ $self->_dispatch_types } ) { last DESCEND if $type->match( $c, $path ); } @@ -361,10 +371,10 @@ sub prepare_action { unshift @args, $arg; } - s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$c->req->captures||[]}; + s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]}; - $c->log->debug( 'Path is "' . $c->req->match . '"' ) - if ( $c->debug && length $c->req->match ); + $c->log->debug( 'Path is "' . $req->match . '"' ) + if ( $c->debug && defined $req->match && length $req->match ); $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' ) if ( $c->debug && @args ); @@ -382,20 +392,20 @@ sub get_action { $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) ); - return $self->action_hash->{"$namespace/$name"}; + return $self->_action_hash->{"${namespace}/${name}"}; } =head2 $self->get_action_by_path( $path ); - + Returns the named action by its full path. -=cut +=cut sub get_action_by_path { my ( $self, $path ) = @_; $path =~ s/^\///; $path = "/$path" unless $path =~ /\//; - $self->action_hash->{$path}; + $self->_action_hash->{$path}; } =head2 $self->get_actions( $c, $action, $namespace ) @@ -428,12 +438,13 @@ sub get_containers { if ( length $namespace ) { do { - push @containers, $self->container_hash->{$namespace}; + push @containers, $self->_container_hash->{$namespace}; } while ( $namespace =~ s#/[^/]+$## ); } - return reverse grep { defined } @containers, $self->container_hash->{''}; + return reverse grep { defined } @containers, $self->_container_hash->{''}; + #return (split '/', $namespace); # isnt this more clear? my @parts = split '/', $namespace; } @@ -451,7 +462,7 @@ cannot determine an appropriate URI, this method will return undef. sub uri_for_action { my ( $self, $action, $captures) = @_; $captures ||= []; - foreach my $dispatch_type ( @{ $self->dispatch_types } ) { + foreach my $dispatch_type ( @{ $self->_dispatch_types } ) { my $uri = $dispatch_type->uri_for_action( $action, $captures ); return( $uri eq '' ? '/' : $uri ) if defined($uri); @@ -459,7 +470,7 @@ sub uri_for_action { return undef; } -=head2 expand_action +=head2 expand_action expand an action into a full representation of the dispatch. mostly useful for chained, other actions will just return a @@ -470,7 +481,7 @@ single action. sub expand_action { my ($self, $action) = @_; - foreach my $dispatch_type (@{ $self->dispatch_types }) { + foreach my $dispatch_type (@{ $self->_dispatch_types }) { my $expanded = $dispatch_type->expand_action($action); return $expanded if $expanded; } @@ -489,21 +500,23 @@ Also, set up the tree with the action containers. sub register { my ( $self, $c, $action ) = @_; - my $registered = $self->registered_dispatch_types; + my $registered = $self->_registered_dispatch_types; - my $priv = 0; + #my $priv = 0; #seems to be unused foreach my $key ( keys %{ $action->attributes } ) { next if $key eq 'Private'; my $class = "Catalyst::DispatchType::$key"; unless ( $registered->{$class} ) { - eval "require $class"; - push( @{ $self->dispatch_types }, $class->new ) unless $@; + # FIXME - Some error checking and re-throwing needed here, as + # we eat exceptions loading dispatch types. + eval { Class::MOP::load_class($class) }; + push( @{ $self->_dispatch_types }, $class->new ) unless $@; $registered->{$class} = 1; } } # Pass the action to our dispatch types so they can register it if reqd. - foreach my $type ( @{ $self->dispatch_types } ) { + foreach my $type ( @{ $self->_dispatch_types } ) { $type->register( $c, $action ); } @@ -515,14 +528,14 @@ sub register { # Set the method value $container->add_action($action); - $self->action_hash->{"$namespace/$name"} = $action; - $self->container_hash->{$namespace} = $container; + $self->_action_hash->{"$namespace/$name"} = $action; + $self->_container_hash->{$namespace} = $container; } sub _find_or_create_action_container { my ( $self, $namespace ) = @_; - my $tree ||= $self->tree; + my $tree ||= $self->_tree; return $tree->getNodeValue unless $namespace; @@ -549,20 +562,18 @@ sub _find_or_create_namespace_node { =head2 $self->setup_actions( $class, $context ) +Loads all of the preload dispatch types, registers their actions and then +loads all of the postload dispatch types, and iterates over the tree of +actions, displaying the debug information if appropriate. =cut sub setup_actions { my ( $self, $c ) = @_; - $self->dispatch_types( [] ); - $self->registered_dispatch_types( {} ); - $self->method_action_class('Catalyst::Action'); - $self->action_container_class('Catalyst::ActionContainer'); - my @classes = $self->_load_dispatch_types( @{ $self->preload_dispatch_types } ); - @{ $self->registered_dispatch_types }{@classes} = (1) x @classes; + @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes; foreach my $comp ( values %{ $c->components } ) { $comp->register_actions($c) if $comp->can('register_actions'); @@ -596,12 +607,12 @@ sub setup_actions { $walker->( $walker, $_, $prefix ) for $parent->getAllChildren; }; - $walker->( $walker, $self->tree, '' ); + $walker->( $walker, $self->_tree, '' ); $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" ) if $has_private; # List all public actions - $_->list($c) for @{ $self->dispatch_types }; + $_->list($c) for @{ $self->_dispatch_types }; } sub _load_dispatch_types { @@ -613,10 +624,11 @@ sub _load_dispatch_types { for my $type (@types) { my $class = ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}"; - eval "require $class"; + + eval { Class::MOP::load_class($class) }; Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ ) if $@; - push @{ $self->dispatch_types }, $class->new; + push @{ $self->_dispatch_types }, $class->new; push @loaded, $class; } @@ -624,6 +636,52 @@ sub _load_dispatch_types { return @loaded; } +use Moose; + +# 5.70 backwards compatibility hacks. + +# Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL) +# need the methods here which *should* be private.. + +# However we can't really take them away until there is a sane API for +# building actions and configuring / introspecting the dispatcher. +# In 5.90, we should build that infrastructure, port the plugins which +# use it, and then take the crap below away. +# See also t/lib/TestApp/Plugin/AddDispatchTypes.pm + +# Alias _method_name to method_name, add a before modifier to warn.. +foreach my $public_method_name (qw/ + tree + dispatch_types + registered_dispatch_types + method_action_class + action_hash + container_hash + /) { + my $private_method_name = '_' . $public_method_name; + my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time. + $meta->add_method($public_method_name, $meta->get_method($private_method_name)); + { + my %package_hash; # Only warn once per method, per package. These are infrequent enough that + # I haven't provided a way to disable them, patches welcome. + $meta->add_before_method_modifier($public_method_name, sub { + my $class = blessed(shift); + $package_hash{$class}++ || do { + warn("Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name,\n" + . "this will be removed in Catalyst 5.9X"); + }; + }); + } +} +# End 5.70 backwards compatibility hacks. + +no Moose; +__PACKAGE__->meta->make_immutable; + +=head2 meta + +Provided by Moose + =head1 AUTHORS Catalyst Contributors, see Catalyst.pm diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm index 18addd4..8d66546 100644 --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@ -1,7 +1,8 @@ package Catalyst::Engine; -use strict; -use base 'Class::Accessor::Fast'; +use Moose; +with 'MooseX::Emulate::Class::Accessor::Fast'; + use CGI::Simple::Cookie; use Data::Dump qw/dump/; use Errno 'EWOULDBLOCK'; @@ -9,13 +10,14 @@ use HTML::Entities; use HTTP::Body; use HTTP::Headers; use URI::QueryParam; -use Scalar::Util (); + +use namespace::clean -except => 'meta'; # input position and length -__PACKAGE__->mk_accessors(qw/read_position read_length/); +has read_length => (is => 'rw'); +has read_position => (is => 'rw'); -# Stringify to class -use overload '""' => sub { return ref shift }, fallback => 1; +has _prepared_write => (is => 'rw'); # Amount of data to read from input on each pass our $CHUNKSIZE = 64 * 1024; @@ -43,7 +45,7 @@ sub finalize_body { my ( $self, $c ) = @_; my $body = $c->response->body; no warnings 'uninitialized'; - if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) { + if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) { while ( !eof $body ) { read $body, my ($buffer), $CHUNKSIZE; last unless $self->write( $c, $buffer ); @@ -66,13 +68,14 @@ sub finalize_cookies { my ( $self, $c ) = @_; my @cookies; + my $response = $c->response; - foreach my $name ( keys %{ $c->response->cookies } ) { + foreach my $name (keys %{ $response->cookies }) { - my $val = $c->response->cookies->{$name}; + my $val = $response->cookies->{$name}; my $cookie = ( - Scalar::Util::blessed($val) + blessed($val) ? $val : CGI::Simple::Cookie->new( -name => $name, @@ -88,13 +91,13 @@ sub finalize_cookies { } for my $cookie (@cookies) { - $c->res->headers->push_header( 'Set-Cookie' => $cookie ); + $response->headers->push_header( 'Set-Cookie' => $cookie ); } } =head2 $self->finalize_error($c) -Output an apropriate error message, called if there's an error in $c +Output an appropriate error message. Called if there's an error in $c after the dispatch has finished. Will output debug messages if Catalyst is in debug mode, or a `please come back later` message otherwise. @@ -121,14 +124,11 @@ sub finalize_error { $name = "

    $name

    "; # Don't show context in the dump - delete $c->req->{_context}; - delete $c->res->{_context}; + $c->req->_clear_context; + $c->res->_clear_context; # Don't show body parser in the dump - delete $c->req->{_body}; - - # Don't show response header state in dump - delete $c->res->{_finalized_headers}; + $c->req->_clear_body; my @infos; my $i = 0; @@ -294,14 +294,13 @@ Clean up after uploads, deleting temp files. sub finalize_uploads { my ( $self, $c ) = @_; - if ( keys %{ $c->request->uploads } ) { - for my $key ( keys %{ $c->request->uploads } ) { - my $upload = $c->request->uploads->{$key}; - unlink map { $_->tempname } - grep { -e $_->tempname } - ref $upload eq 'ARRAY' ? @{$upload} : ($upload); - } + my $request = $c->request; + foreach my $key (keys %{ $request->uploads }) { + my $upload = $request->uploads->{$key}; + unlink grep { -e $_ } map { $_->tempname } + (ref $upload eq 'ARRAY' ? @{$upload} : ($upload)); } + } =head2 $self->prepare_body($c) @@ -314,10 +313,11 @@ sub prepare_body { my ( $self, $c ) = @_; if ( my $length = $self->read_length ) { - unless ( $c->request->{_body} ) { - my $type = $c->request->header('Content-Type'); - $c->request->{_body} = HTTP::Body->new( $type, $length ); - $c->request->{_body}->tmpdir( $c->config->{uploadtmp} ) + my $request = $c->request; + unless ( $request->_body ) { + my $type = $request->header('Content-Type'); + $request->_body(HTTP::Body->new( $type, $length )); + $request->_body->tmpdir( $c->config->{uploadtmp} ) if exists $c->config->{uploadtmp}; } @@ -335,7 +335,7 @@ sub prepare_body { } else { # Defined but will cause all body code to be skipped - $c->request->{_body} = 0; + $c->request->_body(0); } } @@ -348,7 +348,7 @@ Add a chunk to the request body. sub prepare_body_chunk { my ( $self, $c, $chunk ) = @_; - $c->request->{_body}->add($chunk); + $c->request->_body->add($chunk); } =head2 $self->prepare_body_parameters($c) @@ -360,9 +360,9 @@ Sets up parameters from body. sub prepare_body_parameters { my ( $self, $c ) = @_; - return unless $c->request->{_body}; + return unless $c->request->_body; - $c->request->body_parameters( $c->request->{_body}->param ); + $c->request->body_parameters( $c->request->_body->param ); } =head2 $self->prepare_connection($c) @@ -402,25 +402,24 @@ sets up parameters from query and post parameters. sub prepare_parameters { my ( $self, $c ) = @_; + my $request = $c->request; + my $parameters = $request->parameters; + my $body_parameters = $request->body_parameters; + my $query_parameters = $request->query_parameters; # We copy, no references - foreach my $name ( keys %{ $c->request->query_parameters } ) { - my $param = $c->request->query_parameters->{$name}; - $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; - $c->request->parameters->{$name} = $param; + foreach my $name (keys %$query_parameters) { + my $param = $query_parameters->{$name}; + $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param; } # Merge query and body parameters - foreach my $name ( keys %{ $c->request->body_parameters } ) { - my $param = $c->request->body_parameters->{$name}; - $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; - if ( my $old_param = $c->request->parameters->{$name} ) { - if ( ref $old_param eq 'ARRAY' ) { - push @{ $c->request->parameters->{$name} }, - ref $param eq 'ARRAY' ? @$param : $param; - } - else { $c->request->parameters->{$name} = [ $old_param, $param ] } + foreach my $name (keys %$body_parameters) { + my $param = $body_parameters->{$name}; + my @values = ref $param eq 'ARRAY' ? @$param : ($param); + if ( my $existing = $parameters->{$name} ) { + unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing)); } - else { $c->request->parameters->{$name} = $param } + $parameters->{$name} = @values > 1 ? \@values : $values[0]; } } @@ -511,40 +510,42 @@ sub prepare_request { } sub prepare_uploads { my ( $self, $c ) = @_; - - return unless $c->request->{_body}; - - my $uploads = $c->request->{_body}->upload; - for my $name ( keys %$uploads ) { + + my $request = $c->request; + return unless $request->_body; + + my $uploads = $request->_body->upload; + my $parameters = $request->parameters; + foreach my $name (keys %$uploads) { my $files = $uploads->{$name}; - $files = ref $files eq 'ARRAY' ? $files : [$files]; my @uploads; - for my $upload (@$files) { - my $u = Catalyst::Request::Upload->new; - $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) ); - $u->type( $u->headers->content_type ); - $u->tempname( $upload->{tempname} ); - $u->size( $upload->{size} ); - $u->filename( $upload->{filename} ); + for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) { + my $headers = HTTP::Headers->new( %{ $upload->{headers} } ); + my $u = Catalyst::Request::Upload->new + ( + size => $upload->{size}, + type => $headers->content_type, + headers => $headers, + tempname => $upload->{tempname}, + filename => $upload->{filename}, + ); push @uploads, $u; } - $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0]; + $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0]; # support access to the filename as a normal param my @filenames = map { $_->{filename} } @uploads; # append, if there's already params with this name - if (exists $c->request->parameters->{$name}) { - if (ref $c->request->parameters->{$name} eq 'ARRAY') { - push @{ $c->request->parameters->{$name} }, @filenames; + if (exists $parameters->{$name}) { + if (ref $parameters->{$name} eq 'ARRAY') { + push @{ $parameters->{$name} }, @filenames; } else { - $c->request->parameters->{$name} = - [ $c->request->parameters->{$name}, @filenames ]; + $parameters->{$name} = [ $parameters->{$name}, @filenames ]; } } else { - $c->request->parameters->{$name} = - @filenames > 1 ? \@filenames : $filenames[0]; + $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0]; } } } @@ -587,7 +588,7 @@ sub read { =head2 $self->read_chunk($c, $buffer, $length) -Each engine inplements read_chunk as its preferred way of reading a chunk +Each engine implements read_chunk as its preferred way of reading a chunk of data. =cut @@ -620,11 +621,13 @@ Writes the buffer to the client. sub write { my ( $self, $c, $buffer ) = @_; - unless ( $self->{_prepared_write} ) { + unless ( $self->_prepared_write ) { $self->prepare_write($c); - $self->{_prepared_write} = 1; + $self->_prepared_write(1); } + return 0 if !defined $buffer; + my $len = length($buffer); my $wrote = syswrite STDOUT, $buffer; diff --git a/lib/Catalyst/Engine/CGI.pm b/lib/Catalyst/Engine/CGI.pm index ca86d79..fa2e23e 100644 --- a/lib/Catalyst/Engine/CGI.pm +++ b/lib/Catalyst/Engine/CGI.pm @@ -1,10 +1,10 @@ package Catalyst::Engine::CGI; -use strict; -use base 'Catalyst::Engine'; -use NEXT; +use Moose; +extends 'Catalyst::Engine'; -__PACKAGE__->mk_accessors('env'); +has env => (is => 'rw'); +has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf'); =head1 NAME @@ -42,8 +42,7 @@ sub finalize_headers { $c->response->header( Status => $c->response->status ); - $self->{_header_buf} - = $c->response->headers->as_string("\015\012") . "\015\012"; + $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012"); } =head2 $self->prepare_connection($c) @@ -54,7 +53,8 @@ sub prepare_connection { my ( $self, $c ) = @_; local (*ENV) = $self->env || \%ENV; - $c->request->address( $ENV{REMOTE_ADDR} ); + my $request = $c->request; + $request->address( $ENV{REMOTE_ADDR} ); PROXY_CHECK: { @@ -67,20 +67,20 @@ sub prepare_connection { # If we are running as a backend server, the user will always appear # as 127.0.0.1. Select the most recent upstream IP (last in the list) my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/; - $c->request->address($ip); + $request->address($ip); } - $c->request->hostname( $ENV{REMOTE_HOST} ); - $c->request->protocol( $ENV{SERVER_PROTOCOL} ); - $c->request->user( $ENV{REMOTE_USER} ); - $c->request->method( $ENV{REQUEST_METHOD} ); + $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST}; + $request->protocol( $ENV{SERVER_PROTOCOL} ); + $request->user( $ENV{REMOTE_USER} ); + $request->method( $ENV{REQUEST_METHOD} ); if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { - $c->request->secure(1); + $request->secure(1); } if ( $ENV{SERVER_PORT} == 443 ) { - $c->request->secure(1); + $request->secure(1); } } @@ -91,12 +91,12 @@ sub prepare_connection { sub prepare_headers { my ( $self, $c ) = @_; local (*ENV) = $self->env || \%ENV; - + my $headers = $c->request->headers; # Read headers from %ENV foreach my $header ( keys %ENV ) { next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; ( my $field = $header ) =~ s/^HTTPS?_//; - $c->req->headers->header( $field => $ENV{$header} ); + $headers->header( $field => $ENV{$header} ); } } @@ -172,14 +172,15 @@ sub prepare_path { =cut -sub prepare_query_parameters { +around prepare_query_parameters => sub { + my $orig = shift; my ( $self, $c ) = @_; local (*ENV) = $self->env || \%ENV; if ( $ENV{QUERY_STRING} ) { - $self->SUPER::prepare_query_parameters( $c, $ENV{QUERY_STRING} ); + $self->$orig( $c, $ENV{QUERY_STRING} ); } -} +}; =head2 $self->prepare_request($c, (env => \%env)) @@ -199,14 +200,10 @@ Enable autoflush on the output handle for CGI-based engines. =cut -sub prepare_write { - my ( $self, $c ) = @_; - - # Set the output handle to autoflush +around prepare_write => sub { *STDOUT->autoflush(1); - - $self->NEXT::prepare_write($c); -} + return shift->(@_); +}; =head2 $self->write($c, $buffer) @@ -214,16 +211,17 @@ Writes the buffer to the client. =cut -sub write { +around write => sub { + my $orig = shift; my ( $self, $c, $buffer ) = @_; # Prepend the headers if they have not yet been sent - if ( my $headers = delete $self->{_header_buf} ) { - $buffer = $headers . $buffer; + if ( $self->_has_header_buf ) { + $buffer = $self->_clear_header_buf . $buffer; } - - return $self->NEXT::write( $c, $buffer ); -} + + return $self->$orig( $c, $buffer ); +}; =head2 $self->read_chunk($c, $buffer, $length) @@ -251,5 +249,6 @@ This program is free software, you can redistribute it and/or modify it under the same terms as Perl itself. =cut +no Moose; 1; diff --git a/lib/Catalyst/Engine/FastCGI.pm b/lib/Catalyst/Engine/FastCGI.pm index ec85acd..85dee52 100644 --- a/lib/Catalyst/Engine/FastCGI.pm +++ b/lib/Catalyst/Engine/FastCGI.pm @@ -1,7 +1,9 @@ package Catalyst::Engine::FastCGI; -use strict; -use base 'Catalyst::Engine::CGI'; +use Moose; +extends 'Catalyst::Engine::CGI'; + +# eval { Class::MOP::load_class("FCGI") }; eval "use FCGI"; die "Unable to load the FCGI module, you may need to install it:\n$@\n" if $@; @@ -44,7 +46,9 @@ Options may also be specified; =item leave_umask -Set to 1 to disable setting umask to 0 for socket open =item nointr +Set to 1 to disable setting umask to 0 for socket open + +=item nointr Do not allow the listener to be interrupted by Ctrl+C @@ -98,7 +102,7 @@ sub run { my $error = \*STDERR; # send STDERR to the web server $error = \*STDOUT # send STDERR to stdout (a logfile) if $options->{keep_stderr}; # (if asked to) - + my $request = FCGI::Request( \*STDIN, \*STDOUT, $error, \%env, $sock, ( $options->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR ), @@ -126,6 +130,9 @@ sub run { $self->daemon_detach() if $options->{detach}; $proc_manager->pm_manage(); + + # Give each child its own RNG state. + srand; } elsif ( $options->{detach} ) { $self->daemon_detach(); @@ -136,9 +143,9 @@ sub run { $proc_manager && $proc_manager->pm_pre_dispatch(); $self->_fix_env( \%env ); - + $class->handle_request( env => \%env ); - + $proc_manager && $proc_manager->pm_post_dispatch(); } } @@ -150,9 +157,9 @@ sub run { sub write { my ( $self, $c, $buffer ) = @_; - unless ( $self->{_prepared_write} ) { + unless ( $self->_prepared_write ) { $self->prepare_write($c); - $self->{_prepared_write} = 1; + $self->_prepared_write(1); } # XXX: We can't use Engine's write() method because syswrite @@ -160,8 +167,8 @@ sub write { # written: http://www.fastcgi.com/om_archive/mail-archive/0128.html # Prepend the headers if they have not yet been sent - if ( my $headers = delete $self->{_header_buf} ) { - $buffer = $headers . $buffer; + if ( $self->_has_header_buf ) { + $buffer = $self->_clear_header_buf . $buffer; } # FastCGI does not stream data properly if using 'print $handle', diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index 6f66a39..62481ea 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -1,13 +1,13 @@ package Catalyst::Engine::HTTP; -use strict; -use base 'Catalyst::Engine::CGI'; +use Moose; +extends 'Catalyst::Engine::CGI'; + use Data::Dump qw(dump); use Errno 'EWOULDBLOCK'; use HTTP::Date (); use HTTP::Headers; use HTTP::Status; -use NEXT; use Socket; use IO::Socket::INET (); use IO::Select (); @@ -19,6 +19,16 @@ require Catalyst::Engine::HTTP::Restarter::Watcher; use constant CHUNKSIZE => 64 * 1024; use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0; +use namespace::clean -except => 'meta'; + +has options => ( is => 'rw' ); +has _keepalive => ( is => 'rw', predicate => '_is_keepalive', clearer => '_clear_keepalive' ); +has _write_error => ( is => 'rw', predicate => '_has_write_error' ); + +# Refactoring note - could/should Eliminate all instances of $self->{inputbuf}, +# which I haven't touched as it is used as an lvalue in a lot of places, and I guess +# doing it differently could be expensive.. Feel free to refactor and NYTProf :) + =head1 NAME Catalyst::Engine::HTTP - Catalyst HTTP Engine @@ -52,59 +62,52 @@ sub finalize_headers { my $protocol = $c->request->protocol; my $status = $c->response->status; my $message = status_message($status); - + my $res_headers = $c->response->headers; + my @headers; push @headers, "$protocol $status $message"; - - $c->response->headers->header( Date => HTTP::Date::time2str(time) ); - $c->response->headers->header( Status => $status ); - + + $res_headers->header( Date => HTTP::Date::time2str(time) ); + $res_headers->header( Status => $status ); + # Should we keep the connection open? my $connection = $c->request->header('Connection'); - if ( $self->{options}->{keepalive} + if ( $self->options->{keepalive} && $connection && $connection =~ /^keep-alive$/i ) { - $c->response->headers->header( Connection => 'keep-alive' ); - $self->{_keepalive} = 1; + $res_headers->header( Connection => 'keep-alive' ); + $self->_keepalive(1); } else { - $c->response->headers->header( Connection => 'close' ); + $res_headers->header( Connection => 'close' ); } - - push @headers, $c->response->headers->as_string("\x0D\x0A"); - + + push @headers, $res_headers->as_string("\x0D\x0A"); + # Buffer the headers so they are sent with the first write() call # This reduces the number of TCP packets we are sending - $self->{_header_buf} = join("\x0D\x0A", @headers, ''); + $self->_header_buf( join("\x0D\x0A", @headers, '') ); } =head2 $self->finalize_read($c) =cut -sub finalize_read { - my ( $self, $c ) = @_; - +before finalize_read => sub { # Never ever remove this, it would result in random length output # streams if STDIN eq STDOUT (like in the HTTP engine) *STDIN->blocking(1); - - return $self->NEXT::finalize_read($c); -} +}; =head2 $self->prepare_read($c) =cut -sub prepare_read { - my ( $self, $c ) = @_; - +before prepare_read => sub { # Set the input handle to non-blocking *STDIN->blocking(0); - - return $self->NEXT::prepare_read($c); -} +}; =head2 $self->read_chunk($c, $buffer, $length) @@ -146,29 +149,30 @@ Writes the buffer to the client. =cut -sub write { +around write => sub { + my $orig = shift; my ( $self, $c, $buffer ) = @_; - + # Avoid 'print() on closed filehandle Remote' warnings when using IE return unless *STDOUT->opened(); # Prepend the headers if they have not yet been sent - if ( my $headers = delete $self->{_header_buf} ) { - $buffer = $headers . $buffer; + if ( $self->_has_header_buf ) { + $buffer = $self->_clear_header_buf . $buffer; } - - my $ret = $self->NEXT::write( $c, $buffer ); - + + my $ret = $self->$orig($c, $buffer); + if ( !defined $ret ) { - $self->{_write_error} = $!; + $self->_write_error($!); DEBUG && warn "write: Failed to write response ($!)\n"; } else { DEBUG && warn "write: Wrote response ($ret bytes)\n"; } - + return $ret; -} +}; =head2 run @@ -179,8 +183,8 @@ sub run { my ( $self, $class, $port, $host, $options ) = @_; $options ||= {}; - - $self->{options} = $options; + + $self->options($options); if ($options->{background}) { my $child = fork; @@ -212,7 +216,9 @@ sub run { ReuseAddr => 1, Type => SOCK_STREAM, ) - or die "Couldn't create daemon: $!"; + or die "Couldn't create daemon: $@"; + + $port = $daemon->sockport(); my $url = "http://$host"; $url .= ":$port" unless $port == 80; @@ -239,28 +245,28 @@ sub run { } my $pid = undef; - + # Ignore broken pipes as an HTTP server should local $SIG{PIPE} = 'IGNORE'; - + # Restart on HUP - local $SIG{HUP} = sub { + local $SIG{HUP} = sub { $restart = 1; warn "Restarting server on SIGHUP...\n"; }; - + LISTEN: while ( !$restart ) { - while ( accept( Remote, $daemon ) ) { + while ( accept( Remote, $daemon ) ) { DEBUG && warn "New connection\n"; select Remote; Remote->blocking(1); - + # Read until we see all headers $self->{inputbuf} = ''; - + if ( !$self->_read_headers ) { # Error reading, give up close Remote; @@ -268,15 +274,14 @@ sub run { } my ( $method, $uri, $protocol ) = $self->_parse_request_line; - - next unless $method; - + DEBUG && warn "Parsed request: $method $uri $protocol\n"; + next unless $method; unless ( uc($method) eq 'RESTART' ) { # Fork - if ( $options->{fork} ) { + if ( $options->{fork} ) { if ( $pid = fork ) { DEBUG && warn "Forked child $pid\n"; next; @@ -284,10 +289,10 @@ sub run { } $self->_handler( $class, $port, $method, $uri, $protocol ); - - if ( my $error = delete $self->{_write_error} ) { + + if ( $self->_has_write_error ) { close Remote; - + if ( !defined $pid ) { next LISTEN; } @@ -319,9 +324,9 @@ sub run { close Remote; } } - + $daemon->close; - + DEBUG && warn "Shutting down\n"; if ($restart) { @@ -332,8 +337,8 @@ sub run { ### those include dirs upon re-exec. So add them to PERL5LIB, so they ### are available again for the exec'ed process --kane use Config; - $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; - + $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; + exec $^X, $0, @{ $options->{argv} }; } @@ -364,7 +369,6 @@ sub _handler { PATH_INFO => $path || '', QUERY_STRING => $query_string || '', REMOTE_ADDR => $sockdata->{peeraddr}, - REMOTE_HOST => $sockdata->{peername}, REQUEST_METHOD => $method || '', SERVER_NAME => $sockdata->{localname}, SERVER_PORT => $port, @@ -378,13 +382,21 @@ sub _handler { } # Pass flow control to Catalyst - $class->handle_request; + { + # FIXME: don't ignore SIGCHLD while handling requests so system() + # et al. work within actions. it might be a little risky to do that + # this far out, but then again it's only the dev server anyway. + local $SIG{CHLD} = 'DEFAULT'; + + $class->handle_request; + } DEBUG && warn "Request done\n"; # Allow keepalive requests, this is a hack but we'll support it until # the next major release. - if ( delete $self->{_keepalive} ) { + if ( $self->_is_keepalive ) { + $self->_clear_keepalive; DEBUG && warn "Reusing previous connection for keep-alive request\n"; @@ -417,52 +429,51 @@ sub _handler { sub _read_headers { my $self = shift; - + while (1) { my $read = sysread Remote, my $buf, CHUNKSIZE; - + if ( !defined $read ) { next if $! == EWOULDBLOCK; DEBUG && warn "Error reading headers: $!\n"; return; - } - elsif ( $read == 0 ) { + } elsif ( $read == 0 ) { DEBUG && warn "EOF\n"; return; } - + DEBUG && warn "Read $read bytes\n"; $self->{inputbuf} .= $buf; last if $self->{inputbuf} =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s; } - + return 1; } sub _parse_request_line { my $self = shift; - # Parse request line + # Parse request line # Leading CRLF sometimes sent by buggy IE versions if ( $self->{inputbuf} !~ s/^(?:\x0D\x0A)?(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) { return (); } - + my $method = $1; my $uri = $2; my $proto = $3 || 'HTTP/0.9'; - + return ( $method, $uri, $proto ); } sub _parse_headers { my $self = shift; - + # Copy the buffer for header parsing, and remove the header block # from the content buffer. my $buf = $self->{inputbuf}; $self->{inputbuf} =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s; - + # Parse headers my $headers = HTTP::Headers->new; my ($key, $val); @@ -517,9 +528,6 @@ sub _socket_data { # This mess is necessary to keep IE from crashing the server my $data = { - peername => $iaddr - ? ( gethostbyaddr( $iaddr, AF_INET ) || 'localhost' ) - : 'localhost', peeraddr => $iaddr ? ( inet_ntoa($iaddr) || '127.0.0.1' ) : '127.0.0.1', @@ -532,6 +540,11 @@ sub _socket_data { sub _inet_addr { unpack "N*", inet_aton( $_[0] ) } +=head2 options + +Options hash passed to the http engine to control things like if keepalive +is supported. + =head1 SEE ALSO L, L diff --git a/lib/Catalyst/Engine/HTTP/Restarter.pm b/lib/Catalyst/Engine/HTTP/Restarter.pm index c23390b..c2db065 100644 --- a/lib/Catalyst/Engine/HTTP/Restarter.pm +++ b/lib/Catalyst/Engine/HTTP/Restarter.pm @@ -1,12 +1,14 @@ package Catalyst::Engine::HTTP::Restarter; +use Moose; +use Moose::Util qw/find_meta/; +use namespace::clean -except => 'meta'; + +extends 'Catalyst::Engine::HTTP'; -use strict; -use warnings; -use base 'Catalyst::Engine::HTTP'; use Catalyst::Engine::HTTP::Restarter::Watcher; -use NEXT; -sub run { +around run => sub { + my $orig = shift; my ( $self, $class, $port, $host, $options ) = @_; $options ||= {}; @@ -18,6 +20,12 @@ sub run { close STDIN; close STDOUT; + # Avoid "Setting config after setup" error restarting MyApp.pm + $class->setup_finished(0); + # Best effort if we can't trap compiles.. + $self->_make_components_mutable($class) + if !Catalyst::Engine::HTTP::Restarter::Watcher::DETECT_PACKAGE_COMPILATION; + my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new( directory => ( $options->{restart_directory} || @@ -67,7 +75,20 @@ sub run { } } - return $self->NEXT::run( $class, $port, $host, $options ); + return $self->$orig( $class, $port, $host, $options ); +}; + +# Naive way of trying to avoid Moose blowing up when you re-require components +# which have been made immutable. +sub _make_components_mutable { + my ($self, $class) = @_; + + my @metas = map { find_meta($_) } ($class, map { blessed($_) } values %{ $class->components }); + + foreach my $meta (@metas) { + # Paranoia unneeded, all component metaclasses should have immutable + $meta->make_mutable if $meta->is_immutable; + } } 1; diff --git a/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm b/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm index 0ff3916..6aada3e 100644 --- a/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm +++ b/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm @@ -1,32 +1,34 @@ package Catalyst::Engine::HTTP::Restarter::Watcher; -use strict; -use warnings; -use base 'Class::Accessor::Fast'; +use Moose; +with 'MooseX::Emulate::Class::Accessor::Fast'; + use File::Find; use File::Modified; use File::Spec; use Time::HiRes qw/sleep/; +use Moose::Util qw/find_meta/; +use namespace::clean -except => 'meta'; + +BEGIN { + # If we can detect stash changes, then we do magic + # to make their metaclass mutable (if they have one) + # so that restarting works as expected. + eval { require B::Hooks::OP::Check::StashChange; }; + *DETECT_PACKAGE_COMPILATION = $@ + ? sub () { 0 } + : sub () { 1 } +} -__PACKAGE__->mk_accessors( - qw/delay - directory - modified - regex - follow_symlinks - watch_list/ -); - -sub new { - my ( $class, %args ) = @_; - - my $self = {%args}; - - bless $self, $class; - - $self->_init; +has delay => (is => 'rw'); +has regex => (is => 'rw'); +has modified => (is => 'rw'); +has directory => (is => 'rw'); +has watch_list => (is => 'rw'); +has follow_symlinks => (is => 'rw'); - return $self; +sub BUILD { + shift->_init; } sub _init { @@ -134,7 +136,20 @@ sub _index_directory { sub _test { my ( $self, $file ) = @_; - delete $INC{$file}; + my $id; + if (DETECT_PACKAGE_COMPILATION) { + $id = B::Hooks::OP::Check::StashChange::register(sub { + my ($new, $old) = @_; + my $meta = find_meta($new); + if ($meta) { # A little paranoia here - Moose::Meta::Role has neither of these methods. + my $is_immutable = $meta->can('is_immutable'); + my $make_mutable = $meta->can('make_mutable'); + $meta->$make_mutable() if $is_immutable && $make_mutable && $meta->$is_immutable(); + } + }); + } + + delete $INC{$file}; # Remove from %INC so it will reload local $SIG{__WARN__} = sub { }; open my $olderr, '>&STDERR'; @@ -142,6 +157,8 @@ sub _test { eval "require '$file'"; open STDERR, '>&', $olderr; + B::Hooks::OP::Check::StashChange::unregister($id) if $id; + return ($@) ? $@ : 0; } @@ -182,6 +199,17 @@ Creates a new Watcher object. Returns a list of files that have been added, deleted, or changed since the last time watch was called. +=head2 DETECT_PACKAGE_COMPILATION + +Returns true if L is installed and +can be used to detect when files are compiled. This is used internally +to make the L metaclass of any class being reloaded immutable. + +If L is not installed, then the +restarter makes all application components immutable. This covers the +simple case, but is less useful if you're using Moose in components +outside Catalyst's namespaces, but inside your application directory. + =head1 SEE ALSO L, L, L diff --git a/lib/Catalyst/Exception.pm b/lib/Catalyst/Exception.pm index 14cf555..41b411a 100644 --- a/lib/Catalyst/Exception.pm +++ b/lib/Catalyst/Exception.pm @@ -1,15 +1,10 @@ package Catalyst::Exception; -use strict; -use vars qw[@ISA $CATALYST_EXCEPTION_CLASS]; - -BEGIN { - push( @ISA, $CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base' ); -} +# XXX: See bottom of file for Exception implementation package Catalyst::Exception::Base; -use strict; +use Moose; use Carp (); =head1 NAME @@ -49,6 +44,10 @@ sub throw { Carp::croak($message); } +=head2 meta + +Provided by Moose + =head1 AUTHORS Catalyst Contributors, see Catalyst.pm @@ -60,4 +59,18 @@ it under the same terms as Perl itself. =cut +Catalyst::Exception::Base->meta->make_immutable; + +package Catalyst::Exception; + +use Moose; +use vars qw[$CATALYST_EXCEPTION_CLASS]; + +BEGIN { + extends($CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base'); +} + +no Moose; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/Log.pm b/lib/Catalyst/Log.pm index de89a06..5557066 100644 --- a/lib/Catalyst/Log.pm +++ b/lib/Catalyst/Log.pm @@ -1,18 +1,21 @@ package Catalyst::Log; -use strict; -use base 'Class::Accessor::Fast'; +use Moose; +with 'MooseX::Emulate::Class::Accessor::Fast'; + use Data::Dump; +use Class::MOP (); our %LEVELS = (); -__PACKAGE__->mk_accessors('level'); -__PACKAGE__->mk_accessors('body'); -__PACKAGE__->mk_accessors('abort'); +has level => (is => 'rw'); +has _body => (is => 'rw'); +has abort => (is => 'rw'); { my @levels = qw[ debug info warn error fatal ]; + my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__); for ( my $i = 0 ; $i < @levels ; $i++ ) { my $name = $levels[$i]; @@ -20,29 +23,28 @@ __PACKAGE__->mk_accessors('abort'); $LEVELS{$name} = $level; - no strict 'refs'; - - *{$name} = sub { + $meta->add_method($name, sub { my $self = shift; - if ( $self->{level} & $level ) { + if ( $self->level & $level ) { $self->_log( $name, @_ ); } - }; + }); - *{"is_$name"} = sub { + $meta->add_method("is_$name", sub { my $self = shift; - return $self->{level} & $level; - }; + return $self->level & $level; + });; } } -sub new { +around new => sub { + my $orig = shift; my $class = shift; - my $self = $class->SUPER::new; + my $self = $class->$orig; $self->levels( scalar(@_) ? @_ : keys %LEVELS ); return $self; -} +}; sub levels { my ( $self, @levels ) = @_; @@ -52,12 +54,20 @@ sub levels { sub enable { my ( $self, @levels ) = @_; - $self->{level} |= $_ for map { $LEVELS{$_} } @levels; + my $level = $self->level; + for(map { $LEVELS{$_} } @levels){ + $level |= $_; + } + $self->level($level); } sub disable { my ( $self, @levels ) = @_; - $self->{level} &= ~$_ for map { $LEVELS{$_} } @levels; + my $level = $self->level; + for(map { $LEVELS{$_} } @levels){ + $level &= ~$_; + } + $self->level($level); } sub _dump { @@ -70,18 +80,20 @@ sub _log { my $level = shift; my $message = join( "\n", @_ ); $message .= "\n" unless $message =~ /\n$/; - $self->{body} .= sprintf( "[%s] %s", $level, $message ); + my $body = $self->_body; + $body .= sprintf( "[%s] %s", $level, $message ); + $self->_body($body); } sub _flush { my $self = shift; - if ( $self->abort || !$self->body ) { + if ( $self->abort || !$self->_body ) { $self->abort(undef); } else { - $self->_send_to_log( $self->body ); + $self->_send_to_log( $self->_body ); } - $self->body(undef); + $self->_body(undef); } sub _send_to_log { @@ -89,6 +101,9 @@ sub _send_to_log { print STDERR @_; } +no Moose; +__PACKAGE__->meta->make_immutable(); + 1; __END__ @@ -169,6 +184,10 @@ arguments. $log = Catalyst::Log->new; $log = Catalyst::Log->new( 'warn', 'error' ); +=head2 level + +Contains a bitmask of the currently set log levels. + =head2 levels Set log levels @@ -217,6 +236,8 @@ This protected method is what actually sends the log information to STDERR. You may subclass this module and override this method to get finer control over the log output. +=head2 meta + =head1 SEE ALSO L. @@ -232,4 +253,6 @@ it under the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/Manual.pm b/lib/Catalyst/Manual.pm index 0f1c842..79fa318 100644 --- a/lib/Catalyst/Manual.pm +++ b/lib/Catalyst/Manual.pm @@ -87,8 +87,8 @@ IRC: Mailing-Lists: - http://lists.rawmode.org/mailman/listinfo/catalyst - http://lists.rawmode.org/mailman/listinfo/catalyst-dev + http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst + http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev =head1 AUTHORS diff --git a/lib/Catalyst/Manual/Installation.pod b/lib/Catalyst/Manual/Installation.pod index cb1343a..24900cb 100644 --- a/lib/Catalyst/Manual/Installation.pod +++ b/lib/Catalyst/Manual/Installation.pod @@ -82,6 +82,43 @@ of VMWare images where an entire Catalyst development environment has already been installed, complete with database engines and a full complement of Catalyst plugins. +=item * + +Frank Speiser's Amazon EC2 Catalyst SDK + +There are currently two flavors of publicly available Amazon Machine +Images (AMI) that contain all the dependencies you'd need to get a +Catalyst development environment,with all the trimmings, up and +running within minutes. + +Once you obtain an Amazon Elastic Cloud Computing account available +here: +L, +you can literally get a Catalyst development instance up and running +in less than 5 minutes. + +The current AMIs that are available are here in abbreviated form: + + IMAGE ami-bdbe5ad4 developer-tools/Debian-Etch_Catalyst_DBIC_TT.manifest.xml + IMAGE ami-9fbe5af6 developer-tools/Fedora8-Catalyst_DBIC_TT.manifest.xml + +You can run the instances according to the Amazon documentation, as follows: + + ec2-run-instances -k gsg-keypair + +Refer to the Amazon EC2 documentation from the "Amazon Web Services" +section of the L web site for further +assistance. + +You can currently choose between ready-made SDKs on Fedora8 and Debian +Etch. Both machine images include Catalyst, DBIx::Class, +Template::Toolkit, Moose, the mysql and postgresql databases, as well +as subversion source control. The Debian Etch machine instance also +includes svk and git. + +Just run the installation instructions contained in this manual and +go. + =back =head2 OTHER METHODS diff --git a/lib/Catalyst/Manual/Installation/CentOS4.pod b/lib/Catalyst/Manual/Installation/CentOS4.pod index 79c1205..ccaf39a 100644 --- a/lib/Catalyst/Manual/Installation/CentOS4.pod +++ b/lib/Catalyst/Manual/Installation/CentOS4.pod @@ -306,7 +306,7 @@ Note: Once the C is complete, you may want to rerun the command to check the status of the packages listed in . Ideally, everything should return a I C message. If any packages try to re-install, the you could need to manually install the package with the -C option. Also, look for new optional dependences that C +C option. Also, look for new optional dependencies that C was not able to automatically handle. You can address these by manually installing the dependency and then re-running C. diff --git a/lib/Catalyst/Model.pm b/lib/Catalyst/Model.pm index e52fe46..05c913f 100644 --- a/lib/Catalyst/Model.pm +++ b/lib/Catalyst/Model.pm @@ -1,7 +1,9 @@ package Catalyst::Model; -use strict; -use base qw/Catalyst::Component/; +use Moose; +extends qw/Catalyst::Component/; + +no Moose; =head1 NAME @@ -31,4 +33,6 @@ the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/ROADMAP.pod b/lib/Catalyst/ROADMAP.pod index 7c79f7c..e872e5e 100644 --- a/lib/Catalyst/ROADMAP.pod +++ b/lib/Catalyst/ROADMAP.pod @@ -1,85 +1,81 @@ =head1 ROADMAP -This is a living document, that represents the core team's current plans -for the Catalyst framework. It's liable to change at any time. This document -lives in the the catalyst trunk, currently at +This is a living document, that represents the core team's current plans for +the Catalyst framework. It's liable to change at any time. This document lives +in the the catalyst trunk, currently at - http://dev.catalyst.perl.org/repos/Catalyst/trunk/Catalyst/lib/Catalyst/ROADMAP.pod + http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/5.80/trunk/lib/Catalyst/ROADMAP.pod Make sure you get it from there to ensure you have the latest version. -=head2 5.7x series +=head2 5.80000 1st Quarter 2009 -Stable relases, no major features planned. Bugfixes for current release -and documentation improvements. +Next major planned release, ports Catalyst to Moose, and does some refactoring +to help app/ctx. -Will be working on developing more ActionClasses, and Reusable chained -controllers, as well as opinonated highlevel frameworks on top of the -Catalyst Core. +=head2 5.81000 -=head3 5.7.1 +=over -=over 4 +=item Reduce core class data usage. -=item make deployment of Catalyst easier +Refactor everything that doesn't have to be class data into object data -=over 4 +=item Work towards a declarative syntax mode -=item Add htaccess files to distro +Dispatcher refactoring to provide alternatives to deprecated methods, and +support for pluggable dispatcher builders (so that attributes can be +replaced). -=item Trim runtime dependencies +=item MyApp should not ISA Catalyst::Controller -=item test dependency graph, make sure everything installs cleanly on different platforms. +=over -=back +=item * -=item Add support for configuration profiles to be selected at startup time -through switches / ENV +Update Test suite to not assume MyApp ISA Controller -=item add call method to do a forward with eval case. +=item * -=item add go method to do a call while setting action. - -=item move all inline pod to bottom of file. - -=item update pod coverage tests to detect stubbed pod, ensure real coverage +After that set up attr handlers that will output helpful error messages when +you do it as well as how to fix it. =back -=head2 5.80000 4. Quarter 2006 +=back -Next major planned release. +=head2 5.82000 -=over 4 +=over -=item Application / Context Split +=item Extend pluggability of the Catalyst core. -Catalyst needs to be split so that $c refers to the current context, and is a separate thing from the Application class. +good support for reusable components good support for reusable plugins good +separation of plugins (some reusable components want different plugins) near +total engine independence -=item Extend pluggability of the Catalyst core. +=back -good support for reusable components good support for reusable plugins good -separation of plugins (some reusable components want different plugins) -near total engine independence +=head2 5.90000 -=item Moose roles instead of NEXT. +=over -Change the Catalyst core to use Moose for the plugin system as well as -accessors/constructors. +=item Application / Context Split -=item Reduce core class data usage. +Catalyst needs to be split so that $c refers to the current context, and is a +separate thing from the Application class. -Refactor everything that doesn't have to be class data into object data +=back -=item Add support for Isotope Engines +=head2 Wishlist -This depends on the progress of Isotope +=over -=item Work towards a declarative syntax mode +=item move all inline pod to bottom of file. -=back - -=head2 5.90000 2007 +=item update pod coverage tests to detect stubbed pod, ensure real coverage -Blue Sky. Will start planning this once we land 5.8 :) +=item Add support for configuration profiles to be selected at startup time +through switches / ENV +=back diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm index 7210360..c859fd2 100644 --- a/lib/Catalyst/Request.pm +++ b/lib/Catalyst/Request.pm @@ -1,34 +1,133 @@ package Catalyst::Request; -use strict; -use base 'Class::Accessor::Fast'; - use IO::Socket qw[AF_INET inet_aton]; use Carp; use utf8; use URI::http; use URI::https; use URI::QueryParam; +use HTTP::Headers; + +use Moose; + +use namespace::clean -except => 'meta'; + +with 'MooseX::Emulate::Class::Accessor::Fast'; + +has action => (is => 'rw'); +has address => (is => 'rw'); +has arguments => (is => 'rw', default => sub { [] }); +has cookies => (is => 'rw', default => sub { {} }); +has query_keywords => (is => 'rw'); +has match => (is => 'rw'); +has method => (is => 'rw'); +has protocol => (is => 'rw'); +has query_parameters => (is => 'rw', default => sub { {} }); +has secure => (is => 'rw', default => 0); +has captures => (is => 'rw', default => sub { [] }); +has uri => (is => 'rw', predicate => 'has_uri'); +has user => (is => 'rw'); +has headers => ( + is => 'rw', + isa => 'HTTP::Headers', + handles => [qw(content_encoding content_length content_type header referer user_agent)], + default => sub { HTTP::Headers->new() }, + required => 1, + lazy => 1, +); + +# Moose TODO: +# - Can we lose the before modifiers which just call prepare_body ? +# they are wasteful, slow us down and feel cluttery. +# Can we call prepare_body at BUILD time? +# Can we make _body an attribute, have the rest of +# these lazy build from there and kill all the direct hash access +# in Catalyst.pm and Engine.pm? + +has _context => ( + is => 'rw', + weak_ref => 1, + handles => ['read'], + clearer => '_clear_context', +); + +has body_parameters => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { {} }, +); + +before body_parameters => sub { + my ($self) = @_; + $self->_context->prepare_body(); +}; -__PACKAGE__->mk_accessors( - qw/action address arguments cookies headers query_keywords match method - protocol query_parameters secure captures uri user/ +has uploads => ( + is => 'rw', + required => 1, + default => sub { {} }, ); -*args = \&arguments; -*body_params = \&body_parameters; -*input = \&body; -*params = \¶meters; -*query_params = \&query_parameters; -*path_info = \&path; -*snippets = \&captures; - -sub content_encoding { shift->headers->content_encoding(@_) } -sub content_length { shift->headers->content_length(@_) } -sub content_type { shift->headers->content_type(@_) } -sub header { shift->headers->header(@_) } -sub referer { shift->headers->referer(@_) } -sub user_agent { shift->headers->user_agent(@_) } +has parameters => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { {} }, +); + +before parameters => sub { + my ($self, $params) = @_; + if ( $params && !ref $params ) { + $self->_context->log->warn( + "Attempt to retrieve '$params' with req->params(), " . + "you probably meant to call req->param('$params')" ); + $params = undef; + } + +}; + +has base => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { + my $self = shift; + return $self->path if $self->has_uri; + }, +); + +has _body => ( + is => 'rw', clearer => '_clear_body', predicate => '_has_body', +); +# Eugh, ugly. Should just be able to rename accessor methods to 'body' +# and provide a custom reader.. +sub body { + my $self = shift; + $self->_context->prepare_body(); + $self->_body(@_) if scalar @_; + return blessed $self->_body ? $self->_body->body : $self->_body; +} + +has hostname => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { + my ($self) = @_; + gethostbyaddr( inet_aton( $self->address ), AF_INET ) || 'localhost' + }, +); + +has _path => ( is => 'rw', predicate => '_has_path', clearer => '_clear_path' ); + +sub args { shift->arguments(@_) } +sub body_params { shift->body_parameters(@_) } +sub input { shift->body(@_) } +sub params { shift->parameters(@_) } +sub query_params { shift->query_parameters(@_) } +sub path_info { shift->path(@_) } +sub snippets { shift->captures(@_) } =head1 NAME @@ -111,6 +210,9 @@ For example, if your action was and the URI for the request was C, the string C would be the first and only argument. +Arguments just get passed through and B get unescaped automatically, so +you should do that explicitly. + =head2 $req->args Shortcut for arguments. @@ -122,39 +224,11 @@ Contains the URI base. This will always have a trailing slash. If your application was queried with the URI C then C is C. -=cut - -sub base { - my ( $self, $base ) = @_; - - return $self->{base} unless $base; - - $self->{base} = $base; - - # set the value in path for backwards-compat - if ( $self->uri ) { - $self->path; - } - - return $self->{base}; -} - =head2 $req->body Returns the message body of the request, unless Content-Type is C or C. -=cut - -sub body { - my $self = shift; - $self->{_context}->prepare_body; - - return unless $self->{_body}; - - return $self->{_body}->body; -} - =head2 $req->body_parameters Returns a reference to a hash containing body (POST) parameters. Values can @@ -164,20 +238,11 @@ be either a scalar or an arrayref containing scalars. print $c->request->body_parameters->{field}->[0]; These are the parameters from the POST part of the request, if any. - + =head2 $req->body_params Shortcut for body_parameters. -=cut - -sub body_parameters { - my ( $self, $params ) = @_; - $self->{_context}->prepare_body; - $self->{body_parameters} = $params if $params; - return $self->{body_parameters}; -} - =head2 $req->content_encoding Shortcut for $req->headers->content_encoding. @@ -240,23 +305,6 @@ Returns an L object containing the headers for the current reques =head2 $req->hostname Returns the hostname of the client. - -=cut - -sub hostname { - my $self = shift; - - if ( @_ == 0 && not $self->{hostname} ) { - $self->{hostname} = - gethostbyaddr( inet_aton( $self->address ), AF_INET ); - } - - if ( @_ == 1 ) { - $self->{hostname} = shift; - } - - return $self->{hostname}; -} =head2 $req->input @@ -348,31 +396,13 @@ This is the combination of C and C. Shortcut for $req->parameters. -=cut - -sub parameters { - my ( $self, $params ) = @_; - $self->{_context}->prepare_body; - if ( $params ) { - if ( ref $params ) { - $self->{parameters} = $params; - } - else { - $self->{_context}->log->warn( - "Attempt to retrieve '$params' with req->params(), " . - "you probably meant to call req->param('$params')" ); - } - } - return $self->{parameters}; -} - =head2 $req->path Returns the path, i.e. the part of the URI after $req->base, for the current request. =head2 $req->path_info -Alias for path, added for compability with L. +Alias for path, added for compatibility with L. =cut @@ -381,17 +411,17 @@ sub path { if (@params) { $self->uri->path(@params); - undef $self->{path}; + $self->_clear_path; } - elsif ( defined( my $path = $self->{path} ) ) { - return $path; + elsif ( $self->_has_path ) { + return $self->_path; } else { my $path = $self->uri->path; my $location = $self->base->path; $path =~ s/^(\Q$location\E)?//; $path =~ s/^\///; - $self->{path} = $path; + $self->_path($path); return $path; } @@ -419,10 +449,6 @@ defaults to the size of the request if not specified. You have to set MyApp->config->{parse_on_demand} to use this directly. -=cut - -sub read { shift->{_context}->read(@_); } - =head2 $req->referer Shortcut for $req->headers->referer. Returns the referring page. @@ -433,13 +459,14 @@ Returns true or false, indicating whether the connection is secure (https). =head2 $req->captures -Returns a reference to an array containing regex captures. +Returns a reference to an array containing captured args from chained +actions or regex captures. my @captures = @{ $c->request->captures }; =head2 $req->snippets -C used to be called snippets. This is still available for backwoards +C used to be called snippets. This is still available for backwards compatibility, but is considered deprecated. =head2 $req->upload @@ -509,15 +536,6 @@ L objects. my $upload = $c->request->uploads->{field}; my $upload = $c->request->uploads->{field}->[0]; -=cut - -sub uploads { - my ( $self, $uploads ) = @_; - $self->{_context}->prepare_body; - $self->{uploads} = $uploads if $uploads; - return $self->{uploads}; -} - =head2 $req->uri Returns a URI object for the current request. Stringifies to the URI text. @@ -564,6 +582,10 @@ newer plugins is $c->user. Shortcut to $req->headers->user_agent. Returns the user agent (browser) version string. +=head2 meta + +Provided by Moose + =head1 AUTHORS Catalyst Contributors, see Catalyst.pm @@ -575,4 +597,6 @@ it under the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/Request/Upload.pm b/lib/Catalyst/Request/Upload.pm index 224b29c..ed3b0f5 100644 --- a/lib/Catalyst/Request/Upload.pm +++ b/lib/Catalyst/Request/Upload.pm @@ -1,16 +1,48 @@ package Catalyst::Request::Upload; -use strict; -use base 'Class::Accessor::Fast'; +use Moose; +with 'MooseX::Emulate::Class::Accessor::Fast'; use Catalyst::Exception; use File::Copy (); use IO::File (); use File::Spec::Unix; -__PACKAGE__->mk_accessors(qw/filename headers size tempname type basename/); +has filename => (is => 'rw'); +has headers => (is => 'rw'); +has size => (is => 'rw'); +has tempname => (is => 'rw'); +has type => (is => 'rw'); +has basename => (is => 'ro', lazy_build => 1); + +has fh => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { + my $self = shift; + + my $fh = IO::File->new($self->tempname, IO::File::O_RDONLY); + unless ( defined $fh ) { + my $filename = $self->tempname; + Catalyst::Exception->throw( + message => qq/Can't open '$filename': '$!'/ ); + } + + return $fh; + }, +); + +sub _build_basename { + my $self = shift; + my $basename = $self->filename; + $basename =~ s|\\|/|g; + $basename = ( File::Spec::Unix->splitpath($basename) )[2]; + $basename =~ s|[^\w\.-]+|_|g; + return $basename; +} -sub new { shift->SUPER::new( ref( $_[0] ) ? $_[0] : {@_} ) } +no Moose; =head1 NAME @@ -18,6 +50,8 @@ Catalyst::Request::Upload - handles file upload requests =head1 SYNOPSIS + my $upload = $c->req->upload('field'); + $upload->basename; $upload->copy_to; $upload->fh; @@ -64,24 +98,6 @@ sub copy_to { Opens a temporary file (see tempname below) and returns an L handle. -=cut - -sub fh { - my $self = shift; - - my $fh = IO::File->new( $self->tempname, IO::File::O_RDONLY ); - - unless ( defined $fh ) { - - my $filename = $self->tempname; - - Catalyst::Exception->throw( - message => qq/Can't open '$filename': '$!'/ ); - } - - return $fh; -} - =head2 $upload->filename Returns the client-supplied filename. @@ -133,19 +149,6 @@ sub slurp { return $content; } -sub basename { - my $self = shift; - unless ( $self->{basename} ) { - my $basename = $self->filename; - $basename =~ s|\\|/|g; - $basename = ( File::Spec::Unix->splitpath($basename) )[2]; - $basename =~ s|[^\w\.-]+|_|g; - $self->{basename} = $basename; - } - - return $self->{basename}; -} - =head2 $upload->basename Returns basename for C. @@ -158,6 +161,10 @@ Returns the path to the temporary file. Returns the client-supplied Content-Type. +=head2 meta + +Provided by Moose + =head1 AUTHORS Catalyst Contributors, see Catalyst.pm @@ -169,4 +176,6 @@ it under the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/Response.pm b/lib/Catalyst/Response.pm index 0107be0..3203b2d 100644 --- a/lib/Catalyst/Response.pm +++ b/lib/Catalyst/Response.pm @@ -1,16 +1,32 @@ package Catalyst::Response; -use strict; -use base 'Class::Accessor::Fast'; - -__PACKAGE__->mk_accessors(qw/cookies body headers location status/); - -*output = \&body; - -sub content_encoding { shift->headers->content_encoding(@_) } -sub content_length { shift->headers->content_length(@_) } -sub content_type { shift->headers->content_type(@_) } -sub header { shift->headers->header(@_) } +use Moose; +use HTTP::Headers; + +with 'MooseX::Emulate::Class::Accessor::Fast'; + +has cookies => (is => 'rw', default => sub { {} }); +has body => (is => 'rw', default => '', lazy => 1, predicate => 'has_body'); +has location => (is => 'rw'); +has status => (is => 'rw', default => 200); +has finalized_headers => (is => 'rw', default => 0); +has headers => ( + is => 'rw', + handles => [qw(content_encoding content_length content_type header)], + default => sub { HTTP::Headers->new() }, + required => 1, + lazy => 1, +); +has _context => ( + is => 'rw', + weak_ref => 1, + handles => ['write'], + clearer => '_clear_context', +); + +sub output { shift->body(@_) } + +no Moose; =head1 NAME @@ -48,6 +64,10 @@ you might want to use a L type of object (Something that implements in the same fashion), or a filehandle GLOB. Catalyst will write it piece by piece into the response. +=head2 $res->has_body + +Predicate which returns true when a body has been set. + =head2 $res->content_encoding Shortcut for $res->headers->content_encoding. @@ -133,6 +153,10 @@ sub redirect { return $self->location; } +=head2 $res->location + +Sets or returns the HTTP 'Location'. + =head2 $res->status Sets or returns the HTTP status. @@ -143,9 +167,30 @@ Sets or returns the HTTP status. Writes $data to the output stream. +=head2 meta + +Provided by Moose + +=head2 $res->print( @data ) + +Prints @data to the output stream, separated by $,. This lets you pass +the response object to functions that want to write to an L. + =cut -sub write { shift->{_context}->write(@_); } +sub print { + my $self = shift; + my $data = shift; + + defined $self->write($data) or return; + + for (@_) { + defined $self->write($,) or return; + defined $self->write($_) or return; + } + + return 1; +} =head1 AUTHORS @@ -158,4 +203,6 @@ it under the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/Runtime.pm b/lib/Catalyst/Runtime.pm index 26861b4..e68266c 100644 --- a/lib/Catalyst/Runtime.pm +++ b/lib/Catalyst/Runtime.pm @@ -7,7 +7,7 @@ BEGIN { require 5.008001; } # Remember to update this in Catalyst as well! -our $VERSION='5.71000'; +our $VERSION='5.8000_06'; $VERSION= eval $VERSION; diff --git a/lib/Catalyst/Stats.pm b/lib/Catalyst/Stats.pm index b22ad04..0f7dc4a 100644 --- a/lib/Catalyst/Stats.pm +++ b/lib/Catalyst/Stats.pm @@ -1,87 +1,85 @@ package Catalyst::Stats; -use strict; -use warnings; +use Moose; use Time::HiRes qw/gettimeofday tv_interval/; use Text::SimpleTable (); use Catalyst::Utils; use Tree::Simple qw/use_weak_refs/; use Tree::Simple::Visitor::FindByUID; -sub new { - my $class = shift; +use namespace::clean -except => 'meta'; - my $root = Tree::Simple->new({t => [gettimeofday]}); - bless { - enabled => 1, - stack => [ $root ], - tree => $root, - }, ref $class || $class; -} - -sub enable { - my ($self, $enable) = @_; - - $self->{enabled} = $enable; -} +has enable => (is => 'rw', required => 1, default => sub{ 1 }); +has tree => ( + is => 'ro', + required => 1, + default => sub{ Tree::Simple->new({t => [gettimeofday]}) }, + handles => [qw/ accept traverse /], + ); +has stack => ( + is => 'ro', + required => 1, + lazy => 1, + default => sub { [ shift->tree ] } + ); sub profile { my $self = shift; - return unless $self->{enabled}; + return unless $self->enable; my %params; if (@_ <= 1) { - $params{comment} = shift || ""; + $params{comment} = shift || ""; } elsif (@_ % 2 != 0) { - die "profile() requires a single comment parameter or a list of name-value pairs; found " - . (scalar @_) . " values: " . join(", ", @_); + die "profile() requires a single comment parameter or a list of name-value pairs; found " + . (scalar @_) . " values: " . join(", ", @_); } else { - (%params) = @_; - $params{comment} ||= ""; + (%params) = @_; + $params{comment} ||= ""; } my $parent; my $prev; my $t = [ gettimeofday ]; + my $stack = $self->stack; if ($params{end}) { - # parent is on stack; search for matching block and splice out - for (my $i = $#{$self->{stack}}; $i > 0; $i--) { - if ($self->{stack}->[$i]->getNodeValue->{action} eq $params{end}) { - my $node = $self->{stack}->[$i]; - splice(@{$self->{stack}}, $i, 1); - # Adjust elapsed on partner node - my $v = $node->getNodeValue; - $v->{elapsed} = tv_interval($v->{t}, $t); - return $node->getUID; + # parent is on stack; search for matching block and splice out + for (my $i = $#{$stack}; $i > 0; $i--) { + if ($stack->[$i]->getNodeValue->{action} eq $params{end}) { + my ($node) = splice(@{$stack}, $i, 1); + # Adjust elapsed on partner node + my $v = $node->getNodeValue; + $v->{elapsed} = tv_interval($v->{t}, $t); + return $node->getUID; + } } - } # if partner not found, fall through to treat as non-closing call } if ($params{parent}) { - # parent is explicitly defined - $prev = $parent = $self->_get_uid($params{parent}); + # parent is explicitly defined + $prev = $parent = $self->_get_uid($params{parent}); } if (!$parent) { - # Find previous node, which is either previous sibling or parent, for ref time. - $prev = $parent = $self->{stack}->[-1] or return undef; - my $n = $parent->getChildCount; - $prev = $parent->getChild($n - 1) if $n > 0; + # Find previous node, which is either previous sibling or parent, for ref time. + $prev = $parent = $stack->[-1] or return undef; + my $n = $parent->getChildCount; + $prev = $parent->getChild($n - 1) if $n > 0; } my $node = Tree::Simple->new({ - action => $params{begin} || "", - t => $t, - elapsed => tv_interval($prev->getNodeValue->{t}, $t), - comment => $params{comment}, + action => $params{begin} || "", + t => $t, + elapsed => tv_interval($prev->getNodeValue->{t}, $t), + comment => $params{comment}, }); $node->setUID($params{uid}) if $params{uid}; $parent->addChild($node); - push(@{$self->{stack}}, $node) if $params{begin}; + push(@{$stack}, $node) if $params{begin}; return $node->getUID; } @@ -96,7 +94,7 @@ sub report { my $column_width = Catalyst::Utils::term_width() - 9 - 13; my $t = Text::SimpleTable->new( [ $column_width, 'Action' ], [ 9, 'Time' ] ); my @results; - $self->{tree}->traverse( + $self->traverse( sub { my $action = shift; my $stat = $action->getNodeValue; @@ -106,8 +104,10 @@ sub report { $stat->{elapsed}, $stat->{action} ? 1 : 0, ); - $t->row( ( q{ } x $r[0] ) . $r[1], - defined $r[2] ? sprintf("%fs", $r[2]) : '??'); + # Trim down any times >= 10 to avoid ugly Text::Simple line wrapping + my $elapsed = substr(sprintf("%f", $stat->{elapsed}), 0, 8) . "s"; + $t->row( ( q{ } x $r[0] ) . $r[1], + defined $r[2] ? $elapsed : '??'); push(@results, \@r); } ); @@ -119,16 +119,10 @@ sub _get_uid { my $visitor = Tree::Simple::Visitor::FindByUID->new; $visitor->searchForUID($uid); - $self->{tree}->accept($visitor); + $self->accept($visitor); return $visitor->getResult; } - -sub accept { - my $self = shift; - $self->{tree}->accept( @_ ); -} - sub addChild { my $self = shift; my $node = $_[ 0 ]; @@ -141,7 +135,7 @@ sub addChild { $stat->{ elapsed } =~ s{s$}{}; } - $self->{tree}->addChild( @_ ); + $self->tree->addChild( @_ ); } sub setNodeValue { @@ -154,18 +148,15 @@ sub setNodeValue { $stat->{ elapsed } =~ s{s$}{}; } - $self->{tree}->setNodeValue( @_ ); + $self->tree->setNodeValue( @_ ); } sub getNodeValue { my $self = shift; - $self->{tree}->getNodeValue( @_ )->{ t }; + $self->tree->getNodeValue( @_ )->{ t }; } -sub traverse { - my $self = shift; - $self->{tree}->traverse( @_ ); -} +__PACKAGE__->meta->make_immutable(); 1; @@ -334,10 +325,10 @@ from the previous profiling point. The 'rollup' flag indicates whether the reported time is the rolled up time for the block, or the elapsed time from the previous profiling point. -=head1 COMPATABILITY METHODS +=head1 COMPATIBILITY METHODS Some components might expect the stats object to be a regular Tree::Simple object. -We've added some compatability methods to handle this scenario: +We've added some compatibility methods to handle this scenario: =head2 accept @@ -364,4 +355,6 @@ it under the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Catalyst/Test.pm b/lib/Catalyst/Test.pm index f3d4de3..2535f76 100644 --- a/lib/Catalyst/Test.pm +++ b/lib/Catalyst/Test.pm @@ -2,10 +2,77 @@ package Catalyst::Test; use strict; use warnings; +use Test::More (); use Catalyst::Exception; use Catalyst::Utils; -use Class::Inspector; +use Class::MOP; +use Sub::Exporter; + +my $build_exports = sub { + my ($self, $meth, $args, $defaults) = @_; + + my $request; + my $class = $args->{class}; + + if ( $ENV{CATALYST_SERVER} ) { + $request = sub { remote_request(@_) }; + } elsif (! $class) { + $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") }; + } else { + unless (Class::MOP::is_class_loaded($class)) { + Class::MOP::load_class($class); + } + $class->import; + + $request = sub { local_request( $class, @_ ) }; + } + + my $get = sub { $request->(@_)->content }; + + return { + request => $request, + get => $get, + content_like => sub { + my $action = shift; + return Test::More->builder->like($get->($action),@_); + }, + action_ok => sub { + my $action = shift; + return Test::More->builder->ok($request->($action)->is_success, @_); + }, + action_redirect => sub { + my $action = shift; + return Test::More->builder->ok($request->($action)->is_redirect,@_); + }, + action_notfound => sub { + my $action = shift; + return Test::More->builder->is_eq($request->($action)->code,404,@_); + }, + contenttype_is => sub { + my $action = shift; + my $res = $request->($action); + return Test::More->builder->is_eq(scalar($res->content_type),@_); + }, + }; +}; + +our $default_host; + +{ + my $import = Sub::Exporter::build_exporter({ + groups => [ all => $build_exports ], + into_level => 1, + }); + + + sub import { + my ($self, $class, $opts) = @_; + $import->($self, '-all' => { class => $class }); + $opts = {} unless ref $opts eq 'HASH'; + $default_host = $opts->{default_host} if exists $opts->{default_host}; + } +} =head1 NAME @@ -44,17 +111,27 @@ Catalyst::Test - Test Catalyst Applications package main; - use Test::More tests => 1; use Catalyst::Test 'TestApp'; + use Test::More tests => 1; ok( get('/foo') =~ /bar/ ); + # mock virtual hosts + use Catalyst::Test 'MyApp', { default_host => 'myapp.com' }; + like( get('/whichhost'), qr/served by myapp.com/ ); + like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by yourapp.com/ ); + { + local $Catalyst::Test::default_host = 'otherapp.com'; + like( get('/whichhost'), qr/served by otherapp.com/ ); + } + =head1 DESCRIPTION This module allows you to make requests to a Catalyst application either without a server, by simulating the environment of an HTTP request using L or remotely if you define the CATALYST_SERVER -environment variable. +environment variable. This module also adds a few catalyst +specific testing methods as displayed in the method section. The and functions take either a URI or an L object. @@ -80,39 +157,11 @@ method and the L method below: =head2 request -Returns a C object. +Returns a C object. Accepts an optional hashref for request +header configuration; currently only supports setting 'host' value. my $res = request('foo/bar?test=1'); - -=cut - -sub import { - my $self = shift; - my $class = shift; - - my ( $get, $request ); - - if ( $ENV{CATALYST_SERVER} ) { - $request = sub { remote_request(@_) }; - $get = sub { remote_request(@_)->content }; - } elsif (! $class) { - $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") }; - $get = $request; - } else { - unless( Class::Inspector->loaded( $class ) ) { - require Class::Inspector->filename( $class ); - } - $class->import; - - $request = sub { local_request( $class, @_ ) }; - $get = sub { local_request( $class, @_ )->content }; - } - - no strict 'refs'; - my $caller = caller(0); - *{"$caller\::request"} = $request; - *{"$caller\::get"} = $get; -} + my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'}); =head2 local_request @@ -126,6 +175,7 @@ sub local_request { require HTTP::Request::AsCGI; my $request = Catalyst::Utils::request( shift(@_) ); + _customize_request($request, @_); my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup; $class->handle_request; @@ -148,6 +198,8 @@ sub remote_request { my $request = Catalyst::Utils::request( shift(@_) ); my $server = URI->new( $ENV{CATALYST_SERVER} ); + _customize_request($request, @_); + if ( $server->path =~ m|^(.+)?/$| ) { my $path = $1; $server->path("$path") if $path; # need to be quoted @@ -199,6 +251,35 @@ sub remote_request { return $agent->request($request); } +sub _customize_request { + my $request = shift; + my $opts = pop(@_) || {}; + $opts = {} unless ref($opts) eq 'HASH'; + if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host ) { + $request->header( 'Host' => $host ); + } +} + +=head2 action_ok + +Fetches the given url and check that the request was successful + +=head2 action_redirect + +Fetches the given url and check that the request was a redirect + +=head2 action_notfound + +Fetches the given url and check that the request was not found + +=head2 content_like + +Fetches the given url and matches the content against it. + +=head2 contenttype_is + +Check for given mime type + =head1 SEE ALSO L, L, diff --git a/lib/Catalyst/Upgrading.pod b/lib/Catalyst/Upgrading.pod new file mode 100644 index 0000000..5918872 --- /dev/null +++ b/lib/Catalyst/Upgrading.pod @@ -0,0 +1,257 @@ +=head1 Upgrading to Catalyst 5.80 + +Most applications and plugins should run unaltered on Catalyst 5.80. + +However as a lot of refactoring work has taken place, several changes have +been made which could cause incompatibilities, if your application or plugin +is using deprecated code, or relying on side-effects then there could be +incompatibility. + +Most issues found with pre-existing components have been easy to solve, and a +complete description of behavior changes which may cause compatibility issues, +or warnings to be emitted is included below to help if you have problems. + +If you think you have found an upgrade related issue which is not covered in +this document, then please email the Catalyst list to discuss the problem. + +=head1 Known backwards compatibility breakages. + +=head2 Components which inherit from Moose::Object before Catalyst::Component + +Moose components which say: + + package TestApp::Controller::Example; + use Moose; + extends qw/Moose::Object Catalyst::Component/; + +to use the constructor provided by Moose, whilst working if you do some hacks +with the C< BUILDARGS > method, will not work with Catalyst 5.80 as +C inherits from C, and so C< @ISA > fails +to linearise. + +The fix for this, is to not inherit directly from C +yourself. Having components which do not inherit their constructor from +C is B, and has never been recommended, +therefore you're on your own if you're using this technique. You'll need +to detect the version of Catalyst your application is running with and deal +with it appropriately. + +You will also see this issue if you do the following: + + package TestApp::Controller::Example; + use Moose; + use base 'Catalyst::Controller'; + +as C< use base > appends to @ISA. + +The correct way to use Moose in a component in a both forward and backwards +compatible way is: + + package TestApp::Controller::Root; + use Moose; + BEGIN { extends 'Catalyst::Component' }; # Or ::Controller, or whatever + +Note that the C< extends > decleration needs to occur in a begin block for +L to operate correctly. + +=head3 use Moose in MyApp + +Similar to the above, this will also fail: + + package MyApp; + use Moose; + use Catalyst qw/ + ConfigLoader + /; + __PACKAGE__->setup; + +If you need to use Moose in your application class (e.g. for method modifiers +etc) then the correct technique is: + + package MyApp; + use Moose; + extends 'Catalyst'; + __PACKAGE__->setup(qw/ + ConfigLoader + /); + +=head2 Anonymous closures installed directly into the symbol table + +If you have any code which installs anonymous subroutine references directly +into the symbol table, you may encounter breakages. The simplest solution is +to use L to name the subroutine. Example: + + # Original code, likely to break: + my $full_method_name = join('::',$package_name, $method_name); + *$full_method_name = sub { ... }; + + # Fixed Code + use Sub::Name 'subname'; + my $full_method_name = join('::',$package_name, $method_name); + *$full_method_name = subname $full_method_name, sub { ... }; + +Additionally, you can take advantage of Catalysts use of L and +install the closure using the appropriate metaclass. Example: + + use Class::MOP; + my $metaclass = Moose::Meta::Class->initialize($package_name); + $metaclass->add_method($method_name => sub { ... }); + +=head2 Hooking into application setup + +To execute code during application startup the following snippet in MyApp.pm +used to work: + + sub setup { + my ($class, @args) = @_; + $class->NEXT::setup(@args); + ... # things to do after the actual setup + } + +With Catalyst 5.80 this won't work anymore. Because instead of using NEXT.pm it +relies on L, which uses plain C3 method resolution. + +As L hacks to remember what methods have already been called, this +causes infinite recursion between MyApp::setup and Catalyst::setup. + +Moose method modifiers like C<< before|after|around 'setup => sub { ... }; >> +also will not operate correctly due to backward compatibility issues with the +way plugin setup methods. + +The right way to do it is this: + + after setup_finalize => sub { + ... # things to do after the actual setup + }; + +=head2 Components with a new method which returns false + +Previously, if you had a component which inherited from Catalyst::COMPONENT, +but overrode the new method to return false, then your class' configuration +would be blessed into a hash on your behalf, and this would be returned from +the COMPONENT method. + +This behaviour makes no sense, and so has been removed. Implementing your own +new method in components is B discouraged, instead, you should inherit +the new method from Catalyst::Component, and use Moose's BUILD functionality +to perform any construction work necessary for your sub-class. + +=head2 __PACKAGE__->mk_accessor('meta'); + +Won't work due to a limitation of L. This is currently being fixed +inside Moose. + +=head2 Class::Data::Inheritable side effects + +Previously, writing to a class data accessor would copy the accessor method +down into your package. + +This behavior has been removed. Whilst the class data is still stored +per-class, it is stored on the metaclass of the class defining the accessor. + +Therefore anything relying on the side-effect of the accessor being copied down +will be broken. + +The following example demonstrates the problem: + + { + package BaseClass; + use base qw/Class::Data::Inheritable/; + __PACKAGE__->mk_classdata('foo'); + } + + { + package Child; + use base qw/BaseClass/; + } + + BaseClass->foo('base class'); + Child->foo('sub class'); + + use Test::More; + isnt(BaseClass->can('foo'), Child->can('foo')); + +=head2 Extending Catalyst::Request or other classes in an ad-hoc manor using mk_accessors + +Previously, it was possible to add additional accessors to Catalyst::Request +(or other classes) by calling the mk_accessors class method. + +This is no longer supported - users should make a sub-class of the class whos +behavior they would like to change, rather than globally polluting the +Catalyst objects. + +=head2 Confused multiple inheritance with Catalyst::Component::COMPONENT + +Warning message: + + There is a COMPONENT method resolving after Catalyst::Component + in ${next_package}. + +This means that one of the packages on the right hand side of +Catalyst::Component in your Class' inheritance hierarchy defines a COMPONENT +method. + +Previously, Catalyst's COMPONENT method would delegate to the method on the +right hand side, which could then delegate back again with NEXT. This (as it +is insane), is no longer supported, as it makes no sense with C3 method +dispatch order. + +Therefore the correct fix is to re-arrange your class' inheritance hierarchy +so that the COMPONENT method you would like to inherit is the first COMPONENT +method in your @ISA. + +=head1 WARNINGS + +=head2 Methods in Catalyst::Dispatcher + +The following methods in Catalyst::Dispatcher are both an implementation detail, +and also likely to change significantly in the 5.8X release series, and therefore +their use is highly deprecated. + +=over + +=item tree + +=item dispatch_types + +=item registered_dispatch_types + +=item method_action_class + +=item action_hash + +=item container_hash + +=back + +The first time one of these methods is called, a warning will be emitted: + + Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name,\n" + . "this will be removed in Catalyst 5.9X" + +You should B be calling any of these methods from application code. + +Plugins authors and maintainers whos plugins currently call these methods +should change to using the public API, or, if you do not feel the public API +adaquately supports your use-case, please email the development list to +discuss what API features you need so that you can be appropriately supported. + +=head2 require $class was successful but the package is not defined. + +In this version of Catalyst, if a component is loaded from disk, but no +symbols are defined in that component's namespace after it is loaded, this +warning will be issued. + +This is to protect against confusing bugs caused by mis-typing package names. + +This will become a fatal error in a future version. + +=head2 $c->plugin method + +Calling the plugin method is deprecated, and calling it at runtime is B. + +Instead you are recommended to use L< Catalyst::Model::Adaptor > or similar to +compose the functionality you need outside of the main application namespace. + +=cut diff --git a/lib/Catalyst/Utils.pm b/lib/Catalyst/Utils.pm index f3d8c12..4d5f0ed 100644 --- a/lib/Catalyst/Utils.pm +++ b/lib/Catalyst/Utils.pm @@ -6,10 +6,11 @@ use File::Spec; use HTTP::Request; use Path::Class; use URI; -use Class::Inspector; use Carp qw/croak/; use Cwd; +use namespace::clean; + =head1 NAME Catalyst::Utils - The Catalyst Utils @@ -262,8 +263,11 @@ sub ensure_class_loaded { croak "ensure_class_loaded should be given a classname, not a filename ($class)" if $class =~ m/\.pm$/; + # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even + # if it already has symbol table entries. This is to support things like Schema::Loader, which + # part-generate classes in memory, but then also load some of their contents from disk. return if !$opts->{ ignore_loaded } - && Class::Inspector->loaded( $class ); # if a symbol entry exists we don't load again + && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again # this hack is so we don't overwrite $@ if the load did not generate an error my $error; @@ -276,8 +280,9 @@ sub ensure_class_loaded { } die $error if $error; - die "require $class was successful but the package is not defined" - unless Class::Inspector->loaded($class); + + warn "require $class was successful but the package is not defined." + unless Class::MOP::is_class_loaded($class); return 1; } diff --git a/lib/Catalyst/View.pm b/lib/Catalyst/View.pm index 6c41dd6..7ff0450 100644 --- a/lib/Catalyst/View.pm +++ b/lib/Catalyst/View.pm @@ -1,7 +1,7 @@ package Catalyst::View; -use strict; -use base qw/Catalyst::Component/; +use Moose; +extends qw/Catalyst::Component/; =head1 NAME @@ -63,4 +63,7 @@ the same terms as Perl itself. =cut +no Moose; +__PACKAGE__->meta->make_immutable(); + 1; diff --git a/t/03podcoverage.t b/t/03podcoverage.t index 955f071..61a207b 100644 --- a/t/03podcoverage.t +++ b/t/03podcoverage.t @@ -1,7 +1,13 @@ use Test::More; +eval "use Pod::Coverage 0.19"; +plan skip_all => 'Pod::Coverage 0.19 required' if $@; 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} || -e 'inc/.author'; -all_pod_coverage_ok(); +all_pod_coverage_ok( + { + also_private => ['BUILD'] + } +); diff --git a/t/04critic.rc b/t/04critic.rc deleted file mode 100644 index 412f770..0000000 --- a/t/04critic.rc +++ /dev/null @@ -1,5 +0,0 @@ -include = CodeLayout::ProhibitHardTabs -only = 1 - -[CodeLayout::ProhibitHardTabs] -allow_leading_tabs = 0 \ No newline at end of file diff --git a/t/04critic.t b/t/04critic.t index d94c165..5a4a226 100644 --- a/t/04critic.t +++ b/t/04critic.t @@ -9,14 +9,13 @@ if ( !-e "$FindBin::Bin/../MANIFEST.SKIP" ) { plan skip_all => 'Critic test only for developers.'; } else { - eval { require Test::Perl::Critic }; + eval { require Test::NoTabs }; if ( $@ ) { plan tests => 1; - fail( 'You must install Test::Perl::Critic to run 04critic.t' ); + fail( 'You must install Test::NoTabs to run 04critic.t' ); exit; } } -my $rcfile = File::Spec->catfile( 't', '04critic.rc' ); -Test::Perl::Critic->import( -profile => $rcfile ); -all_critic_ok(); \ No newline at end of file +Test::NoTabs->import; +all_perl_files_ok(qw/lib/); diff --git a/t/aggregate.t b/t/aggregate.t new file mode 100644 index 0000000..9b31a52 --- /dev/null +++ b/t/aggregate.t @@ -0,0 +1,18 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/lib"; + +use Test::Aggregate; + +my $tests = Test::Aggregate->new({ + dirs => 't/aggregate', + verbose => 0, + set_filenames => 1, + findbin => 1, +}); + +$tests->run; diff --git a/t/live_component_controller_action_action.t b/t/aggregate/live_component_controller_action_action.t similarity index 99% rename from t/live_component_controller_action_action.t rename to t/aggregate/live_component_controller_action_action.t index 43af4f9..ea52e78 100644 --- a/t/live_component_controller_action_action.t +++ b/t/aggregate/live_component_controller_action_action.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_auto.t b/t/aggregate/live_component_controller_action_auto.t similarity index 99% rename from t/live_component_controller_action_auto.t rename to t/aggregate/live_component_controller_action_auto.t index bd35306..bf566dc 100644 --- a/t/live_component_controller_action_auto.t +++ b/t/aggregate/live_component_controller_action_auto.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_begin.t b/t/aggregate/live_component_controller_action_begin.t similarity index 97% rename from t/live_component_controller_action_begin.t rename to t/aggregate/live_component_controller_action_begin.t index 43d13c7..49b3163 100644 --- a/t/live_component_controller_action_begin.t +++ b/t/aggregate/live_component_controller_action_begin.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_chained.t b/t/aggregate/live_component_controller_action_chained.t similarity index 97% rename from t/live_component_controller_action_chained.t rename to t/aggregate/live_component_controller_action_chained.t index a8b7e09..74db1f2 100644 --- a/t/live_component_controller_action_chained.t +++ b/t/aggregate/live_component_controller_action_chained.t @@ -4,13 +4,13 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; } -use Test::More tests => 141*$iters; +use Test::More tests => 143*$iters; use Catalyst::Test 'TestApp'; if ( $ENV{CAT_BENCHMARK} ) { @@ -981,4 +981,27 @@ sub run_tests { is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' ); } + + # + # */search + # doc/* + # + # request for doc/search should end up in doc/* + { + my @expected = qw[ + TestApp::Controller::Action::Chained->begin + TestApp::Controller::Action::Chained->doc_star + TestApp::Controller::Action::Chained->end + ]; + + my $expected = join( ", ", @expected ); + + ok( my $response = request('http://localhost/chained/doc/search'), + "we prefer static path parts earlier in the chain" ); + TODO: { + local $TODO = 'gbjk never got off his ass and fixed this'; + is( $response->header('X-Catalyst-Executed'), + $expected, 'Executed actions' ); + } + } } diff --git a/t/live_component_controller_action_default.t b/t/aggregate/live_component_controller_action_default.t similarity index 98% rename from t/live_component_controller_action_default.t rename to t/aggregate/live_component_controller_action_default.t index e3c90fd..935a326 100644 --- a/t/live_component_controller_action_default.t +++ b/t/aggregate/live_component_controller_action_default.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_detach.t b/t/aggregate/live_component_controller_action_detach.t similarity index 98% rename from t/live_component_controller_action_detach.t rename to t/aggregate/live_component_controller_action_detach.t index 5896793..5905596 100644 --- a/t/live_component_controller_action_detach.t +++ b/t/aggregate/live_component_controller_action_detach.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_end.t b/t/aggregate/live_component_controller_action_end.t similarity index 97% rename from t/live_component_controller_action_end.t rename to t/aggregate/live_component_controller_action_end.t index 78d6178..22b8333 100644 --- a/t/live_component_controller_action_end.t +++ b/t/aggregate/live_component_controller_action_end.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_forward.t b/t/aggregate/live_component_controller_action_forward.t similarity index 99% rename from t/live_component_controller_action_forward.t rename to t/aggregate/live_component_controller_action_forward.t index 2479fb6..3000398 100644 --- a/t/live_component_controller_action_forward.t +++ b/t/aggregate/live_component_controller_action_forward.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; @@ -245,7 +245,7 @@ sub run_tests { is( $response->content, '/action/forward/foo/bar', 'forward_to_uri_check correct namespace'); } - + # test forwarding to Catalyst::Action objects { ok( my $response = request( diff --git a/t/live_component_controller_action_global.t b/t/aggregate/live_component_controller_action_global.t similarity index 98% rename from t/live_component_controller_action_global.t rename to t/aggregate/live_component_controller_action_global.t index 50dcf55..5a90084 100644 --- a/t/live_component_controller_action_global.t +++ b/t/aggregate/live_component_controller_action_global.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_go.t b/t/aggregate/live_component_controller_action_go.t similarity index 99% rename from t/live_component_controller_action_go.t rename to t/aggregate/live_component_controller_action_go.t index b1088c9..407d4d2 100644 --- a/t/live_component_controller_action_go.t +++ b/t/aggregate/live_component_controller_action_go.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_index.t b/t/aggregate/live_component_controller_action_index.t similarity index 99% rename from t/live_component_controller_action_index.t rename to t/aggregate/live_component_controller_action_index.t index ba92a78..99e9435 100644 --- a/t/live_component_controller_action_index.t +++ b/t/aggregate/live_component_controller_action_index.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_inheritance.t b/t/aggregate/live_component_controller_action_inheritance.t similarity index 99% rename from t/live_component_controller_action_inheritance.t rename to t/aggregate/live_component_controller_action_inheritance.t index e957329..c58866b 100644 --- a/t/live_component_controller_action_inheritance.t +++ b/t/aggregate/live_component_controller_action_inheritance.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_local.t b/t/aggregate/live_component_controller_action_local.t similarity index 99% rename from t/live_component_controller_action_local.t rename to t/aggregate/live_component_controller_action_local.t index 3670bd9..ae98831 100644 --- a/t/live_component_controller_action_local.t +++ b/t/aggregate/live_component_controller_action_local.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_multipath.t b/t/aggregate/live_component_controller_action_multipath.t similarity index 95% rename from t/live_component_controller_action_multipath.t rename to t/aggregate/live_component_controller_action_multipath.t index 7f026db..e4bb242 100644 --- a/t/live_component_controller_action_multipath.t +++ b/t/aggregate/live_component_controller_action_multipath.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; my $content = q/foo bar @@ -24,11 +24,13 @@ if ( $ENV{CAT_BENCHMARK} ) { } else { for ( 1 .. $iters ) { - run_tests(); + run_tests($content); } } sub run_tests { + my ($content) = @_; + # Local { ok( diff --git a/t/live_component_controller_action_path.t b/t/aggregate/live_component_controller_action_path.t similarity index 99% rename from t/live_component_controller_action_path.t rename to t/aggregate/live_component_controller_action_path.t index 18fc83d..338e696 100644 --- a/t/live_component_controller_action_path.t +++ b/t/aggregate/live_component_controller_action_path.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_private.t b/t/aggregate/live_component_controller_action_private.t similarity index 98% rename from t/live_component_controller_action_private.t rename to t/aggregate/live_component_controller_action_private.t index a7baaf8..44d4f16 100644 --- a/t/live_component_controller_action_private.t +++ b/t/aggregate/live_component_controller_action_private.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_regexp.t b/t/aggregate/live_component_controller_action_regexp.t similarity index 99% rename from t/live_component_controller_action_regexp.t rename to t/aggregate/live_component_controller_action_regexp.t index be005bc..ab5d4ba 100644 --- a/t/live_component_controller_action_regexp.t +++ b/t/aggregate/live_component_controller_action_regexp.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_action_streaming.t b/t/aggregate/live_component_controller_action_streaming.t similarity index 93% rename from t/live_component_controller_action_streaming.t rename to t/aggregate/live_component_controller_action_streaming.t index 6f1e48c..156956b 100644 --- a/t/live_component_controller_action_streaming.t +++ b/t/aggregate/live_component_controller_action_streaming.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; @@ -54,7 +54,7 @@ EOF skip "Using remote server", 5; } - my $file = "$FindBin::Bin/lib/TestApp/Controller/Action/Streaming.pm"; + my $file = "$FindBin::Bin/../lib/TestApp/Controller/Action/Streaming.pm"; my $fh = IO::File->new( $file, 'r' ); my $buffer; if ( defined $fh ) { diff --git a/t/live_component_controller_action_visit.t b/t/aggregate/live_component_controller_action_visit.t similarity index 99% rename from t/live_component_controller_action_visit.t rename to t/aggregate/live_component_controller_action_visit.t index 62d6766..96fe762 100644 --- a/t/live_component_controller_action_visit.t +++ b/t/aggregate/live_component_controller_action_visit.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; our $iters; diff --git a/t/live_component_controller_args.t b/t/aggregate/live_component_controller_args.t similarity index 98% rename from t/live_component_controller_args.t rename to t/aggregate/live_component_controller_args.t index 861b4ad..29d26a1 100644 --- a/t/live_component_controller_args.t +++ b/t/aggregate/live_component_controller_args.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use URI::Escape; diff --git a/t/live_component_controller_moose.t b/t/aggregate/live_component_controller_moose.t similarity index 56% rename from t/live_component_controller_moose.t rename to t/aggregate/live_component_controller_moose.t index 353e515..a9a3ccf 100644 --- a/t/live_component_controller_moose.t +++ b/t/aggregate/live_component_controller_moose.t @@ -1,19 +1,10 @@ use strict; use warnings; -use Test::More; - -BEGIN { - if (eval 'require Moose; 1') { - plan tests => 2; - } - else { - plan skip_all => 'Moose is required for this test'; - } -} use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; +use Test::More tests => 2; use Catalyst::Test 'TestApp'; { diff --git a/t/live_engine_request_auth.t b/t/aggregate/live_engine_request_auth.t similarity index 96% rename from t/live_engine_request_auth.t rename to t/aggregate/live_engine_request_auth.t index b15c4d7..f5370ce 100644 --- a/t/live_engine_request_auth.t +++ b/t/aggregate/live_engine_request_auth.t @@ -6,7 +6,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 7; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_request_body.t b/t/aggregate/live_engine_request_body.t similarity index 78% rename from t/live_engine_request_body.t rename to t/aggregate/live_engine_request_body.t index 06198f0..c6670da 100644 --- a/t/live_engine_request_body.t +++ b/t/aggregate/live_engine_request_body.t @@ -1,12 +1,11 @@ #!perl - use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; -use Test::More tests => 18; +use Test::More tests => 23; use Catalyst::Test 'TestApp'; use Catalyst::Request; @@ -39,6 +38,7 @@ use HTTP::Request::Common; isa_ok( $creq, 'Catalyst::Request' ); is( $creq->method, 'POST', 'Catalyst::Request method' ); is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' ); + is( $creq->{__body_type}, 'File::Temp' ); is( $creq->content_length, $request->content_length, 'Catalyst::Request Content-Length' ); } @@ -72,6 +72,21 @@ use HTTP::Request::Common; isa_ok( $creq, 'Catalyst::Request' ); is( $creq->method, 'POST', 'Catalyst::Request method' ); is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' ); + is( $creq->{__body_type}, 'File::Temp' ); is( $creq->content_length, $request->content_length, 'Catalyst::Request Content-Length' ); } + +# 5.80 regression, see note in Catalyst::Plugin::Test::Plugin +{ + my $request = GET( + 'http://localhost/have_req_body_in_prepare_action', + 'Content-Type' => 'text/plain', + 'Content' => 'x' x 100_000 + ); + + ok( my $response = request($request), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + like( $response->content, qr/^[1-9]/, 'Has body' ); +} + diff --git a/t/live_engine_request_body_demand.t b/t/aggregate/live_engine_request_body_demand.t similarity index 98% rename from t/live_engine_request_body_demand.t rename to t/aggregate/live_engine_request_body_demand.t index 2444dc8..b4d7889 100644 --- a/t/live_engine_request_body_demand.t +++ b/t/aggregate/live_engine_request_body_demand.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 8; use Catalyst::Test 'TestAppOnDemand'; diff --git a/t/live_engine_request_cookies.t b/t/aggregate/live_engine_request_cookies.t similarity index 97% rename from t/live_engine_request_cookies.t rename to t/aggregate/live_engine_request_cookies.t index 4247ca4..5a45acc 100644 --- a/t/live_engine_request_cookies.t +++ b/t/aggregate/live_engine_request_cookies.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 13; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_request_headers.t b/t/aggregate/live_engine_request_headers.t similarity index 98% rename from t/live_engine_request_headers.t rename to t/aggregate/live_engine_request_headers.t index 33c57f9..551561e 100644 --- a/t/live_engine_request_headers.t +++ b/t/aggregate/live_engine_request_headers.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 17; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_request_parameters.t b/t/aggregate/live_engine_request_parameters.t similarity index 87% rename from t/live_engine_request_parameters.t rename to t/aggregate/live_engine_request_parameters.t index 060bc9e..56a7074 100644 --- a/t/live_engine_request_parameters.t +++ b/t/aggregate/live_engine_request_parameters.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 53; use Catalyst::Test 'TestApp'; @@ -32,7 +32,7 @@ use HTTP::Request::Common; ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); isa_ok( $creq, 'Catalyst::Request' ); is( $creq->method, 'GET', 'Catalyst::Request method' ); - is_deeply( $creq->{parameters}, $parameters, + is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' ); } @@ -43,7 +43,7 @@ use HTTP::Request::Common; ok( $response->is_success, 'Response Successful 2xx' ); is( $response->content_type, 'text/plain', 'Response Content-Type' ); ok( eval '$creq = ' . $response->content ); - is $creq->{parameters}->{q}, 'foo+bar', '%2b not double decoded'; + is $creq->parameters->{q}, 'foo+bar', '%2b not double decoded'; } { @@ -53,7 +53,7 @@ use HTTP::Request::Common; ok( $response->is_success, 'Response Successful 2xx' ); is( $response->content_type, 'text/plain', 'Response Content-Type' ); ok( eval '$creq = ' . $response->content ); - is $creq->{parameters}->{q}, 'foo=bar', '= not ignored'; + is $creq->parameters->{q}, 'foo=bar', '= not ignored'; } { @@ -84,10 +84,10 @@ use HTTP::Request::Common; ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); isa_ok( $creq, 'Catalyst::Request' ); is( $creq->method, 'POST', 'Catalyst::Request method' ); - is_deeply( $creq->{parameters}, $parameters, + is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' ); is_deeply( $creq->arguments, [qw(a b)], 'Catalyst::Request arguments' ); - is_deeply( $creq->{uploads}, {}, 'Catalyst::Request uploads' ); + is_deeply( $creq->uploads, {}, 'Catalyst::Request uploads' ); is_deeply( $creq->cookies, {}, 'Catalyst::Request cookie' ); } @@ -109,7 +109,7 @@ use HTTP::Request::Common; ok( my $response = request($request), 'Request' ); ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); - is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' ); + is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' ); } # raw query string support @@ -129,13 +129,13 @@ use HTTP::Request::Common; ok( my $response = request($request), 'Request' ); ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); - is( $creq->{uri}->query, 'query+string', 'Catalyst::Request POST query_string' ); + is( $creq->uri->query, 'query+string', 'Catalyst::Request POST query_string' ); is( $creq->query_keywords, 'query string', 'Catalyst::Request query_keywords' ); - is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' ); + is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' ); ok( $response = request('http://localhost/dump/request/a/b?x=1&y=1&z=1'), 'Request' ); ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); - is( $creq->{uri}->query, 'x=1&y=1&z=1', 'Catalyst::Request GET query_string' ); + is( $creq->uri->query, 'x=1&y=1&z=1', 'Catalyst::Request GET query_string' ); } { diff --git a/t/live_engine_request_uploads.t b/t/aggregate/live_engine_request_uploads.t similarity index 75% rename from t/live_engine_request_uploads.t rename to t/aggregate/live_engine_request_uploads.t index bab8501..df98f08 100644 --- a/t/live_engine_request_uploads.t +++ b/t/aggregate/live_engine_request_uploads.t @@ -4,13 +4,14 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; -use Test::More tests => 88; +use Test::More tests => 105; use Catalyst::Test 'TestApp'; use Catalyst::Request; use Catalyst::Request::Upload; +use HTTP::Body::OctetStream; use HTTP::Headers; use HTTP::Headers::Util 'split_header_words'; use HTTP::Request::Common; @@ -61,7 +62,7 @@ use Path::Class::Dir; my $disposition = $part->header('Content-Disposition'); my %parameters = @{ ( split_header_words($disposition) )[0] }; - my $upload = $creq->{uploads}->{ $parameters{filename} }; + my $upload = $creq->uploads->{ $parameters{filename} }; isa_ok( $upload, 'Catalyst::Request::Upload' ); @@ -69,7 +70,7 @@ use Path::Class::Dir; is( $upload->size, length( $part->content ), 'Upload Content-Length' ); # make sure upload is accessible via legacy params->{$file} - is( $creq->{parameters}->{ $upload->filename }, + is( $creq->parameters->{ $upload->filename }, $upload->filename, 'legacy param method ok' ); SKIP: @@ -127,12 +128,13 @@ use Path::Class::Dir; my $disposition = $part->header('Content-Disposition'); my %parameters = @{ ( split_header_words($disposition) )[0] }; - my $upload = $creq->{uploads}->{ $parameters{name} }->[$i]; + my $upload = $creq->uploads->{ $parameters{name} }->[$i]; isa_ok( $upload, 'Catalyst::Request::Upload' ); is( $upload->type, $part->content_type, 'Upload Content-Type' ); is( $upload->filename, $parameters{filename}, 'Upload filename' ); is( $upload->size, length( $part->content ), 'Upload Content-Length' ); + is( $upload->basename, $parameters{filename}, 'Upload basename' ); SKIP: { @@ -158,6 +160,8 @@ use Path::Class::Dir; ok( $response->is_success, 'Response Successful 2xx' ); is( $response->content_type, 'text/plain', 'Response Content-Type' ); is( $response->content, ( $request->parts )[0]->content, 'Content' ); + + # XXX: no way to test that temporary file for this test was deleted } { @@ -165,7 +169,7 @@ use Path::Class::Dir; 'http://localhost/dump/request', 'Content-Type' => 'multipart/form-data', 'Content' => - [ 'file' => ["$FindBin::Bin/catalyst_130pix.gif"], ] + [ 'file' => ["$FindBin::Bin/../catalyst_130pix.gif"], ] ); # LWP will auto-correct Content-Length when using a remote server @@ -186,8 +190,8 @@ use Path::Class::Dir; 'http://localhost/dump/request', 'Content-Type' => 'multipart/form-data', 'Content' => - [ 'file1' => ["$FindBin::Bin/catalyst_130pix.gif"], - 'file2' => ["$FindBin::Bin/catalyst_130pix.gif"], ] + [ 'file1' => ["$FindBin::Bin/../catalyst_130pix.gif"], + 'file2' => ["$FindBin::Bin/../catalyst_130pix.gif"], ] ); ok( my $response = request($request), 'Request' ); @@ -195,6 +199,26 @@ use Path::Class::Dir; is( $response->content_type, 'text/plain', 'Response Content-Type' ); like( $response->content, qr/file1 => bless/, 'Upload with name file1'); like( $response->content, qr/file2 => bless/, 'Upload with name file2'); + + my $creq; + { + no strict 'refs'; + ok( + eval '$creq = ' . $response->content, + 'Unserialize Catalyst::Request' + ); + } + + for my $file ( $creq->upload ) { + my $upload = $creq->upload($file); + SKIP: + { + if ( $ENV{CATALYST_SERVER} ) { + skip 'Not testing for deleted file on remote server', 1; + } + ok( !-e $upload->tempname, 'Upload temp file was deleted' ); + } + } } { @@ -205,7 +229,7 @@ use Path::Class::Dir; 'Content-Type' => 'form-data', 'Content' => [ 'testfile' => 'textfield value', - 'testfile' => ["$FindBin::Bin/catalyst_130pix.gif"], + 'testfile' => ["$FindBin::Bin/../catalyst_130pix.gif"], ] ); @@ -233,7 +257,7 @@ use Path::Class::Dir; is( $creq->content_length, $request->content_length, 'Catalyst::Request Content-Length' ); - my $param = $creq->{parameters}->{testfile}; + my $param = $creq->parameters->{testfile}; ok( @$param == 2, '2 values' ); is( $param->[0], 'textfield value', 'correct value' ); @@ -246,13 +270,63 @@ use Path::Class::Dir; next unless exists $parameters{filename}; - my $upload = $creq->{uploads}->{ $parameters{name} }; + my $upload = $creq->uploads->{ $parameters{name} }; isa_ok( $upload, 'Catalyst::Request::Upload' ); is( $upload->type, $part->content_type, 'Upload Content-Type' ); is( $upload->size, length( $part->content ), 'Upload Content-Length' ); - is( $upload->filename, 'catalyst_130pix.gif' ); + is( $upload->filename, 'catalyst_130pix.gif', 'Upload Filename' ); + is( $upload->basename, 'catalyst_130pix.gif', 'Upload basename' ); + + SKIP: + { + if ( $ENV{CATALYST_SERVER} ) { + skip 'Not testing for deleted file on remote server', 1; + } + ok( !-e $upload->tempname, 'Upload temp file was deleted' ); + } + } +} + +# Test PUT request with application/octet-stream file gets deleted + +{ + my $body; + + my $request = PUT( + 'http://localhost/dump/body/', + 'Content-Type' => 'application/octet-stream', + 'Content' => 'foobarbaz', + 'Content-Length' => 9, + ); + + ok( my $response = request($request), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + is( $response->content_type, 'text/plain', 'Response Content-Type' ); + like( + $response->content, + qr/bless\( .* 'HTTP::Body::OctetStream' \)/s, + 'Content is a serialized HTTP::Body::OctetStream' + ); + + { + no strict 'refs'; + ok( + eval '$body = ' . substr( $response->content, 8 ), # FIXME - substr not needed in other test cases? + 'Unserialize HTTP::Body::OctetStream' + ) or warn $@; + } + + isa_ok( $body, 'HTTP::Body::OctetStream' ); + isa_ok($body->body, 'File::Temp'); + + SKIP: + { + if ( $ENV{CATALYST_SERVER} ) { + skip 'Not testing for deleted file on remote server', 1; + } + ok( !-e $body->body->filename, 'Upload temp file was deleted' ); } } @@ -260,7 +334,7 @@ use Path::Class::Dir; SKIP: { if ( $ENV{CATALYST_SERVER} ) { - skip 'Not testing uploadtmp on remote server', 13; + skip 'Not testing uploadtmp on remote server', 14; } my $creq; @@ -316,6 +390,8 @@ SKIP: is( $upload->size, length( $part->content ), 'Upload Content-Length' ); like( $upload->tempname, qr{\Q$dir\E}, 'uploadtmp' ); + + ok( !-e $upload->tempname, 'Upload temp file was deleted' ); } } diff --git a/t/live_engine_request_uri.t b/t/aggregate/live_engine_request_uri.t similarity index 88% rename from t/live_engine_request_uri.t rename to t/aggregate/live_engine_request_uri.t index 39e3345..4f60c49 100644 --- a/t/live_engine_request_uri.t +++ b/t/aggregate/live_engine_request_uri.t @@ -2,9 +2,9 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; -use Test::More tests => 66; +use Test::More tests => 68; use Catalyst::Test 'TestApp'; use Catalyst::Request; @@ -60,8 +60,8 @@ SKIP: ok( my $response = request('http://localhost/engine/request/uri?a=1;a=2;b=3'), 'Request' ); ok( $response->is_success, 'Response Successful 2xx' ); ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); - is( $creq->{uri}->query, 'a=1;a=2;b=3', 'Query string ok' ); - is_deeply( $creq->{parameters}, $parameters, 'Parameters ok' ); + is( $creq->uri->query, 'a=1;a=2;b=3', 'Query string ok' ); + is_deeply( $creq->parameters, $parameters, 'Parameters ok' ); } # test that query params are unescaped properly @@ -69,8 +69,8 @@ SKIP: ok( my $response = request('http://localhost/engine/request/uri?text=Catalyst%20Rocks'), 'Request' ); ok( $response->is_success, 'Response Successful 2xx' ); ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); - is( $creq->{uri}->query, 'text=Catalyst%20Rocks', 'Query string ok' ); - is( $creq->{parameters}->{text}, 'Catalyst Rocks', 'Unescaped param ok' ); + is( $creq->uri->query, 'text=Catalyst%20Rocks', 'Query string ok' ); + is( $creq->parameters->{text}, 'Catalyst Rocks', 'Unescaped param ok' ); } # test that uri_with adds params @@ -155,3 +155,16 @@ SKIP: is( $response->header( 'X-Catalyst-Param-c' ), '1', 'param "c" ok' ); } +# Test an overridden uri method which calls the base method, SmartURI does this. +SKIP: +{ + if ( $ENV{CATALYST_SERVER} ) { + skip 'Using remote server', 2; + } + + require TestApp::RequestBaseBug; + TestApp->request_class('TestApp::RequestBaseBug'); + ok( my $response = request('http://localhost/engine/request/uri'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + TestApp->request_class('Catalyst::Request'); +} diff --git a/t/live_engine_response_cookies.t b/t/aggregate/live_engine_response_cookies.t similarity index 98% rename from t/live_engine_response_cookies.t rename to t/aggregate/live_engine_response_cookies.t index cffca3a..5f2f226 100644 --- a/t/live_engine_response_cookies.t +++ b/t/aggregate/live_engine_response_cookies.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 15; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_response_errors.t b/t/aggregate/live_engine_response_errors.t similarity index 98% rename from t/live_engine_response_errors.t rename to t/aggregate/live_engine_response_errors.t index 1fb8842..b991402 100644 --- a/t/live_engine_response_errors.t +++ b/t/aggregate/live_engine_response_errors.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 18; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_response_headers.t b/t/aggregate/live_engine_response_headers.t similarity index 98% rename from t/live_engine_response_headers.t rename to t/aggregate/live_engine_response_headers.t index 1b374e4..0d373c2 100644 --- a/t/live_engine_response_headers.t +++ b/t/aggregate/live_engine_response_headers.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 18; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_response_large.t b/t/aggregate/live_engine_response_large.t similarity index 95% rename from t/live_engine_response_large.t rename to t/aggregate/live_engine_response_large.t index 86665f2..84b796b 100644 --- a/t/live_engine_response_large.t +++ b/t/aggregate/live_engine_response_large.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 6; use Catalyst::Test 'TestApp'; diff --git a/t/aggregate/live_engine_response_print.t b/t/aggregate/live_engine_response_print.t new file mode 100644 index 0000000..ad00ea3 --- /dev/null +++ b/t/aggregate/live_engine_response_print.t @@ -0,0 +1,24 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; + +use Test::More tests => 9; +use Catalyst::Test 'TestApp'; + +my $expected = { + one => "foo", + two => "foobar", + three => "foo,bar,baz", +}; + +for my $action ( sort keys %{$expected} ) { + ok( my $response = request('http://localhost/engine/response/print/' . $action ), + 'Request' ); + ok( $response->is_success, "Response $action successful 2xx" ); + + is( $response->content, $expected->{$action}, "Content $action OK" ); +} diff --git a/t/live_engine_response_redirect.t b/t/aggregate/live_engine_response_redirect.t similarity index 98% rename from t/live_engine_response_redirect.t rename to t/aggregate/live_engine_response_redirect.t index 3812120..a01b9d0 100644 --- a/t/live_engine_response_redirect.t +++ b/t/aggregate/live_engine_response_redirect.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 26; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_response_status.t b/t/aggregate/live_engine_response_status.t similarity index 98% rename from t/live_engine_response_status.t rename to t/aggregate/live_engine_response_status.t index 51f6373..a37c9b6 100644 --- a/t/live_engine_response_status.t +++ b/t/aggregate/live_engine_response_status.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 30; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_setup_basics.t b/t/aggregate/live_engine_setup_basics.t similarity index 89% rename from t/live_engine_setup_basics.t rename to t/aggregate/live_engine_setup_basics.t index 7d3d2d3..c2b81ba 100644 --- a/t/live_engine_setup_basics.t +++ b/t/aggregate/live_engine_setup_basics.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 1; use Catalyst::Test 'TestApp'; diff --git a/t/live_engine_setup_plugins.t b/t/aggregate/live_engine_setup_plugins.t similarity index 90% rename from t/live_engine_setup_plugins.t rename to t/aggregate/live_engine_setup_plugins.t index d280551..419982b 100644 --- a/t/live_engine_setup_plugins.t +++ b/t/aggregate/live_engine_setup_plugins.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 2; use Catalyst::Test 'TestApp'; diff --git a/t/live_loop.t b/t/aggregate/live_loop.t similarity index 94% rename from t/live_loop.t rename to t/aggregate/live_loop.t index 34fea5f..e7b59f9 100644 --- a/t/live_loop.t +++ b/t/aggregate/live_loop.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 3; use Catalyst::Test 'TestApp'; diff --git a/t/live_plugin_loaded.t b/t/aggregate/live_plugin_loaded.t similarity index 91% rename from t/live_plugin_loaded.t rename to t/aggregate/live_plugin_loaded.t index de27574..835f85c 100644 --- a/t/live_plugin_loaded.t +++ b/t/aggregate/live_plugin_loaded.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 5; use Catalyst::Test 'TestApp'; @@ -14,6 +14,7 @@ my @expected = qw[ Catalyst::Plugin::Test::Headers Catalyst::Plugin::Test::Inline Catalyst::Plugin::Test::Plugin + TestApp::Plugin::AddDispatchTypes TestApp::Plugin::FullyQualified ]; diff --git a/t/live_priorities.t b/t/aggregate/live_priorities.t similarity index 98% rename from t/live_priorities.t rename to t/aggregate/live_priorities.t index e726027..1e05747 100644 --- a/t/live_priorities.t +++ b/t/aggregate/live_priorities.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 28; use Catalyst::Test 'TestApp'; diff --git a/t/live_recursion.t b/t/aggregate/live_recursion.t similarity index 95% rename from t/live_recursion.t rename to t/aggregate/live_recursion.t index 6e55877..a2fcea8 100644 --- a/t/live_recursion.t +++ b/t/aggregate/live_recursion.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More tests => 3; use Catalyst::Test 'TestApp'; diff --git a/t/unit_core_action_for.t b/t/aggregate/unit_core_action_for.t similarity index 68% rename from t/unit_core_action_for.t rename to t/aggregate/unit_core_action_for.t index 71772f8..3e75eaa 100644 --- a/t/unit_core_action_for.t +++ b/t/aggregate/unit_core_action_for.t @@ -4,11 +4,11 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More; -plan tests => 3; +plan tests => 4; use_ok('TestApp'); @@ -18,3 +18,6 @@ is(TestApp->action_for('global_action')->code, TestApp->can('global_action'), is(TestApp->controller('Args')->action_for('args')->code, TestApp::Controller::Args->can('args'), 'action_for on controller ok'); + is(TestApp->controller('Args')->action_for('args').'', + 'args/args', + 'action stringifies'); diff --git a/t/unit_core_component_layers.t b/t/aggregate/unit_core_component_layers.t similarity index 78% rename from t/unit_core_component_layers.t rename to t/aggregate/unit_core_component_layers.t index 4261365..c15bc73 100644 --- a/t/unit_core_component_layers.t +++ b/t/aggregate/unit_core_component_layers.t @@ -1,4 +1,4 @@ -use Test::More tests => 5; +use Test::More tests => 6; use strict; use warnings; use lib 't/lib'; @@ -19,3 +19,8 @@ my $model_foo_bar = $model_foo->bar; can_ok($model_foo_bar, 'model_foo_bar_method_from_foo'); can_ok($model_foo_bar, 'model_foo_bar_method_from_foo_bar'); + +TestApp->setup; + +is($model_foo->model_quux_method, 'chunkybacon', 'Model method getting $self->{quux} from config'); + diff --git a/t/unit_core_uri_for_action.t b/t/aggregate/unit_core_uri_for_action.t similarity index 92% rename from t/unit_core_uri_for_action.t rename to t/aggregate/unit_core_uri_for_action.t index a0297f4..d4f4148 100644 --- a/t/unit_core_uri_for_action.t +++ b/t/aggregate/unit_core_uri_for_action.t @@ -4,7 +4,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib"; +use lib "$FindBin::Bin/../lib"; use Test::More; @@ -120,17 +120,17 @@ is($context->uri_for($chained_action, [ 1 ], 2, { q => 1 }), # More Chained with Context Tests # { - sub __action { $dispatcher->get_action_by_path( @_ ) } + sub __action { shift->get_action_by_path( @_ ) } - is( $context->uri_for( __action( '/action/chained/endpoint2' ), [1,2], (3,4), { x => 5 } ), + is( $context->uri_for( __action( $dispatcher, '/action/chained/endpoint2' ), [1,2], (3,4), { x => 5 } ), 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/4?x=5', 'uri_for correct for chained with multiple captures and args' ); - is( $context->uri_for( __action( '/action/chained/three_end' ), [1,2,3], (4,5,6) ), + is( $context->uri_for( __action( $dispatcher, '/action/chained/three_end' ), [1,2,3], (4,5,6) ), 'http://127.0.0.1/foo/chained/one/1/two/2/3/three/4/5/6', 'uri_for correct for chained with multiple capturing actions' ); - my $action_needs_two = __action( '/action/chained/endpoint2' ); + my $action_needs_two = __action( $dispatcher, '/action/chained/endpoint2' ); ok( ! defined( $context->uri_for($action_needs_two, [1], (2,3)) ), 'uri_for returns undef for not enough captures' ); @@ -162,7 +162,7 @@ is($context->uri_for($chained_action, [ 1 ], 2, { q => 1 }), 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/', 'uri_for returns uri with empty arg on undef last argument' ); - my $complex_chained = __action( '/action/chained/empty_chain_f' ); + my $complex_chained = __action( $dispatcher, '/action/chained/empty_chain_f' ); is( $context->uri_for( $complex_chained, [23], (13), {q => 3} ), 'http://127.0.0.1/foo/chained/empty/23/13?q=3', 'uri_for returns correct uri for chain with many empty path parts' ); diff --git a/t/unit_core_uri_for_multibytechar.t b/t/aggregate/unit_core_uri_for_multibytechar.t similarity index 93% rename from t/unit_core_uri_for_multibytechar.t rename to t/aggregate/unit_core_uri_for_multibytechar.t index b0ccdc5..3320491 100644 --- a/t/unit_core_uri_for_multibytechar.t +++ b/t/aggregate/unit_core_uri_for_multibytechar.t @@ -2,8 +2,7 @@ use strict; use warnings; use FindBin; -use File::Spec; -use lib File::Spec->catfile($FindBin::Bin, 'lib'); +use lib "$FindBin::Bin/../lib"; use Test::More tests => 5; diff --git a/t/c3_mro.t b/t/c3_mro.t index c731202..d987544 100644 --- a/t/c3_mro.t +++ b/t/c3_mro.t @@ -4,9 +4,7 @@ use warnings; use Test::More; require Catalyst; require Module::Pluggable::Object; - -eval "require Class::C3"; -plan skip_all => "This test requires Class::C3" if $@; +use MRO::Compat; # Get a list of all Catalyst:: packages in blib via M::P::O my @cat_mods; @@ -34,7 +32,7 @@ plan tests => scalar @cat_mods; # foreach my $cat_mod (@cat_mods) { eval " require $cat_mod "; - eval { Class::C3::calculateMRO($cat_mod) }; - ok(!$@, "calculateMRO for $cat_mod"); + eval { mro::get_linear_isa($cat_mod, 'c3') }; + ok(!$@, "calculateMRO for $cat_mod: $@"); } diff --git a/t/caf_backcompat.t b/t/caf_backcompat.t new file mode 100644 index 0000000..d8c67c2 --- /dev/null +++ b/t/caf_backcompat.t @@ -0,0 +1,29 @@ +use strict; +use warnings; +use Test::More; +use Test::Exception; +use Class::MOP (); +use Moose::Util (); + +# List of everything which used Class::Accessor::Fast in 5.70. +my @modules = qw/ + Catalyst::Action + Catalyst::ActionContainer + Catalyst::Component + Catalyst::Dispatcher + Catalyst::DispatchType + Catalyst::Engine::HTTP::Restarter::Watcher + Catalyst::Engine + Catalyst::Log + Catalyst::Request::Upload + Catalyst::Request + Catalyst::Response +/; + +plan tests => scalar @modules; + +foreach my $module (@modules) { + Class::MOP::load_class($module); + ok Moose::Util::does_role($module => 'MooseX::Emulate::Class::Accessor::Fast'), + "$module has Class::Accessor::Fast back-compat"; +} diff --git a/t/cdi_backcompat_plugin_accessor_override.t b/t/cdi_backcompat_plugin_accessor_override.t new file mode 100644 index 0000000..d3efa18 --- /dev/null +++ b/t/cdi_backcompat_plugin_accessor_override.t @@ -0,0 +1,39 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Test::More tests => 2; +use Test::Exception; + +# Force a stack trace. +use Carp; +$SIG{__DIE__} = \&Carp::confess; + +{ + package CDICompatTestApp; + use Catalyst qw/ + +CDICompatTestPlugin + /; + # Calling ->config here (before we call setup). With CDI/Cat 5.70 this + # causes *CDICompatTestApp::_config to have a class data accessor created. + + # If this doesn't happen, then later when we've added CDICompatTestPlugin + # to @ISA, we fail in the overridden ->setup method when we call ->config + # again, as we get the CAF accessor from CDICompatTestPlugin, not the one + # created in this package as a side-effect of this call. :-( + __PACKAGE__->config; +} + +SKIP: { + skip 'Not trying to replicate the nasty CDI hackness', 2; + lives_ok { + CDICompatTestApp->setup; + } 'Setup app with plugins which says use base qw/Class::Accessor::Fast/'; + + # And the plugin's setup_finished method should have been run, as accessors + # are not created in MyApp until the data is written to. + { + no warnings 'once'; + is $CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED, 1, 'Plugin setup_finish run'; + } +} \ No newline at end of file diff --git a/t/lib/CDICompatTestPlugin.pm b/t/lib/CDICompatTestPlugin.pm new file mode 100644 index 0000000..f7e2d05 --- /dev/null +++ b/t/lib/CDICompatTestPlugin.pm @@ -0,0 +1,42 @@ +package CDICompatTestPlugin; + +# This plugin specificially tests an edge case of C::D::I compat, +# where you load a plugin which creates an accessor with the same +# name as a class data accessor (_config in this case).. + +# This is what happens if you use the authentication back-compat +# stuff, as C::A::Plugin::Credential::Password is added to the plugin +# list, and that uses base C::A::C::P class, does the mk_accessors. + +# If a class data method called _config hasn't been created in +# MyApp ($app below), then our call to ->config gets our accessor +# (rather than the class data one), and we fail.. + +use strict; +use warnings; +use base qw/Class::Accessor::Fast/; +use MRO::Compat; +__PACKAGE__->mk_accessors(qw/_config/); + +sub setup { + my $app = shift; + + $app->config; + $app->next::method(@_); +} + +# However, if we are too enthusiastic about adding accessors to the +# MyApp package, then this method isn't called (as there is a local +# symbol already). + +# Note - use a different package here, so that Moose's +# package detection code doesn't get confused.. +$CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED = 0; + +sub setup_finished { + my $app = shift; + $CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED = 1; + $app->next::method(@_); +} + +1; diff --git a/t/lib/Catalyst/Action/TestAfter.pm b/t/lib/Catalyst/Action/TestAfter.pm index 61fb9d7..199ea25 100644 --- a/t/lib/Catalyst/Action/TestAfter.pm +++ b/t/lib/Catalyst/Action/TestAfter.pm @@ -8,7 +8,7 @@ use base qw/Catalyst::Action/; sub execute { my $self = shift; my ( $controller, $c ) = @_; - $self->NEXT::execute( @_ ); + $self->next::method( @_ ); $c->res->header( 'X-Action-After', $c->stash->{after_message} ); } diff --git a/t/lib/Catalyst/Action/TestBefore.pm b/t/lib/Catalyst/Action/TestBefore.pm index 8bc2e64..456a990 100644 --- a/t/lib/Catalyst/Action/TestBefore.pm +++ b/t/lib/Catalyst/Action/TestBefore.pm @@ -9,7 +9,7 @@ sub execute { my $self = shift; my ( $controller, $c ) = @_; $c->stash->{test} = 'works'; - $self->NEXT::execute( @_ ); + $self->next::method( @_ ); } 1; diff --git a/t/lib/Catalyst/Plugin/Test/Errors.pm b/t/lib/Catalyst/Plugin/Test/Errors.pm index 92fa63c..51e4873 100644 --- a/t/lib/Catalyst/Plugin/Test/Errors.pm +++ b/t/lib/Catalyst/Plugin/Test/Errors.pm @@ -1,12 +1,13 @@ package Catalyst::Plugin::Test::Errors; use strict; +use MRO::Compat; sub error { my $c = shift; unless ( $_[0] ) { - return $c->NEXT::error(@_); + return $c->next::method(@_); } if ( $_[0] =~ /^(Unknown resource|No default action defined)/ ) { @@ -26,7 +27,7 @@ sub error { $c->response->headers->push_header( 'X-Catalyst-Error' => $error ); - $c->NEXT::error(@_); + $c->next::method(@_); } 1; diff --git a/t/lib/Catalyst/Plugin/Test/Headers.pm b/t/lib/Catalyst/Plugin/Test/Headers.pm index ac47209..3d4feb3 100644 --- a/t/lib/Catalyst/Plugin/Test/Headers.pm +++ b/t/lib/Catalyst/Plugin/Test/Headers.pm @@ -1,11 +1,12 @@ package Catalyst::Plugin::Test::Headers; use strict; +use MRO::Compat; sub prepare { my $class = shift; - my $c = $class->NEXT::prepare(@_); + my $c = $class->next::method(@_); $c->response->header( 'X-Catalyst-Engine' => $c->engine ); $c->response->header( 'X-Catalyst-Debug' => $c->debug ? 1 : 0 ); @@ -26,7 +27,7 @@ sub prepare { sub prepare_action { my $c = shift; - $c->NEXT::prepare_action(@_); + $c->next::method(@_); $c->res->header( 'X-Catalyst-Action' => $c->req->action ); } diff --git a/t/lib/Catalyst/Plugin/Test/Plugin.pm b/t/lib/Catalyst/Plugin/Test/Plugin.pm index 62b2cad..5cb6e4a 100644 --- a/t/lib/Catalyst/Plugin/Test/Plugin.pm +++ b/t/lib/Catalyst/Plugin/Test/Plugin.pm @@ -1,6 +1,8 @@ package Catalyst::Plugin::Test::Plugin; use strict; +use warnings; +use MRO::Compat; use base qw/Catalyst::Base Class::Data::Inheritable/; @@ -15,6 +17,9 @@ sub prepare { my $class = shift; +# Note: This use of NEXT is deliberately left here (without a use NEXT) +# to ensure back compat, as NEXT always used to be loaded, but +# is now replaced by Class::C3::Adopt::NEXT. my $c = $class->NEXT::prepare(@_); $c->response->header( 'X-Catalyst-Plugin-Setup' => $c->ran_setup ); @@ -22,6 +27,24 @@ sub prepare { } +# Note: This is horrible, but Catalyst::Plugin::Server forces the body to +# be parsed, by calling the $c->req->body method in prepare_action. +# We need to test this, as this was broken by 5.80. See also +# t/aggregate/live_engine_request_body.t. Better ways to test this +# appreciated if you have suggestions :) +{ + my $have_req_body = 0; + sub prepare_action { + my $c = shift; + $have_req_body++ if $c->req->body; + $c->next::method(@_); + } + sub have_req_body_in_prepare_action : Local { + my ($self, $c) = @_; + $c->res->body($have_req_body); + } +} + sub end : Private { my ($self,$c) = @_; } diff --git a/t/lib/NullPackage.pm b/t/lib/NullPackage.pm new file mode 100644 index 0000000..47dcfda --- /dev/null +++ b/t/lib/NullPackage.pm @@ -0,0 +1,7 @@ +package NullPackage; +# Do nothing class, there should be no code or symbols defined here.. +# Loading this works fine in 5.70, but a die was introduced in 5.80 which caused +# it to fail. This has been changed to a warning to maintain back-compat. +# See Catalyst::Utils::ensure_class_loaded() for more info. +1; + diff --git a/t/lib/TestApp.pm b/t/lib/TestApp.pm index d903b3c..058084f 100644 --- a/t/lib/TestApp.pm +++ b/t/lib/TestApp.pm @@ -7,6 +7,7 @@ use Catalyst qw/ Test::Plugin Test::Inline +TestApp::Plugin::FullyQualified + +TestApp::Plugin::AddDispatchTypes /; use Catalyst::Utils; @@ -14,10 +15,6 @@ our $VERSION = '0.01'; TestApp->config( name => 'TestApp', root => '/some/dir' ); -unless (eval 'require Moose; 1') { - TestApp->config(setup_components => { except => 'TestApp::Controller::Moose' }); -} - TestApp->setup; sub index : Private { @@ -33,7 +30,7 @@ sub global_action : Private { sub execute { my $c = shift; my $class = ref( $c->component( $_[0] ) ) || $_[0]; - my $action = "$_[1]"; + my $action = $_[1]->reverse; my $method; @@ -65,7 +62,7 @@ sub execute { sub finalize_error { my $c = shift; - $c->NEXT::finalize_error(@_); + $c->next::method(@_); $c->res->status(500); $c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) ); diff --git a/t/lib/TestApp/Action/TestBefore.pm b/t/lib/TestApp/Action/TestBefore.pm index 0d802bf..c0db6fe 100644 --- a/t/lib/TestApp/Action/TestBefore.pm +++ b/t/lib/TestApp/Action/TestBefore.pm @@ -9,7 +9,7 @@ sub execute { my $self = shift; my ( $controller, $c, $test ) = @_; $c->res->header( 'X-TestAppActionTestBefore', $test ); - $self->NEXT::execute( @_ ); + $self->next::method( @_ ); } 1; diff --git a/t/lib/TestApp/Action/TestMyAction.pm b/t/lib/TestApp/Action/TestMyAction.pm index 66bcdf9..5a83aee 100644 --- a/t/lib/TestApp/Action/TestMyAction.pm +++ b/t/lib/TestApp/Action/TestMyAction.pm @@ -9,7 +9,7 @@ sub execute { my $self = shift; my ( $controller, $c, $test ) = @_; $c->res->header( 'X-TestAppActionTestMyAction', 'MyAction works' ); - $self->NEXT::execute(@_); + $self->next::method(@_); } 1; diff --git a/t/lib/TestApp/Controller/Action/Chained.pm b/t/lib/TestApp/Controller/Action/Chained.pm index 90b1efe..6acc378 100644 --- a/t/lib/TestApp/Controller/Action/Chained.pm +++ b/t/lib/TestApp/Controller/Action/Chained.pm @@ -185,6 +185,12 @@ sub wurst : Chained('apan') CaptureArgs(1) PathPart('') { } sub static_end : Chained('korv') Args(0) { } sub capture_end : Chained('wurst') Args(0) PathPart('') { } + +# */search vs doc/* +sub view : Chained('/') PathPart('chained') CaptureArgs(1) {} +sub star_search : Chained('view') PathPart('search') Args(0) { } +sub doc_star : Chained('/') PathPart('chained/doc') Args(1) {} + sub end :Private { my ($self, $c) = @_; return if $c->stash->{no_end}; diff --git a/t/lib/TestApp/Controller/Action/Forward.pm b/t/lib/TestApp/Controller/Action/Forward.pm index d3ed612..062d6a1 100644 --- a/t/lib/TestApp/Controller/Action/Forward.pm +++ b/t/lib/TestApp/Controller/Action/Forward.pm @@ -56,13 +56,12 @@ sub with_method_and_args : Local { $c->forward( qw/TestApp::Controller::Action::Forward args/, [qq/new/] ); $c->res->body( $c->req->args->[0] ); } - + sub to_action_object : Local { my ( $self, $c ) = @_; $c->forward($self->action_for('embed'), [qw/mtfnpy/]); } - sub args : Local { my ( $self, $c, $val ) = @_; die "Expected argument 'new', got '$val'" unless $val eq 'new'; diff --git a/t/lib/TestApp/Controller/Action/Streaming.pm b/t/lib/TestApp/Controller/Action/Streaming.pm index f1a2908..5a757b0 100644 --- a/t/lib/TestApp/Controller/Action/Streaming.pm +++ b/t/lib/TestApp/Controller/Action/Streaming.pm @@ -17,7 +17,7 @@ EOF sub body : Local { my ( $self, $c ) = @_; - my $file = "$FindBin::Bin/lib/TestApp/Controller/Action/Streaming.pm"; + my $file = "$FindBin::Bin/../lib/TestApp/Controller/Action/Streaming.pm"; my $fh = IO::File->new( $file, 'r' ); if ( defined $fh ) { $c->res->body( $fh ); diff --git a/t/lib/TestApp/Controller/Dump.pm b/t/lib/TestApp/Controller/Dump.pm index df33eb5..5ea3ba0 100644 --- a/t/lib/TestApp/Controller/Dump.pm +++ b/t/lib/TestApp/Controller/Dump.pm @@ -10,8 +10,7 @@ sub default : Action Private { sub env : Action Relative { my ( $self, $c ) = @_; - $c->stash( env => \%ENV ); - $c->forward('TestApp::View::Dump'); + $c->forward('TestApp::View::Dump', [\%ENV]); } sub parameters : Action Relative { @@ -29,4 +28,9 @@ sub response : Action Relative { $c->forward('TestApp::View::Dump::Response'); } +sub body : Action Relative { + my ( $self, $c ) = @_; + $c->forward('TestApp::View::Dump::Body'); +} + 1; diff --git a/t/lib/TestApp/Controller/Engine/Response/Print.pm b/t/lib/TestApp/Controller/Engine/Response/Print.pm new file mode 100644 index 0000000..1d1f52d --- /dev/null +++ b/t/lib/TestApp/Controller/Engine/Response/Print.pm @@ -0,0 +1,25 @@ +package TestApp::Controller::Engine::Response::Print; + +use strict; +use base 'Catalyst::Base'; + +sub one :Relative { + my ( $self, $c ) = @_; + + $c->res->print("foo"); +} + +sub two :Relative { + my ( $self, $c ) = @_; + + $c->res->print(qw/foo bar/); +} + +sub three :Relative { + my ( $self, $c ) = @_; + + local $, = ','; + $c->res->print(qw/foo bar baz/); +} + +1; diff --git a/t/lib/TestApp/Controller/Fork.pm b/t/lib/TestApp/Controller/Fork.pm index 648b2fb..086d149 100644 --- a/t/lib/TestApp/Controller/Fork.pm +++ b/t/lib/TestApp/Controller/Fork.pm @@ -7,7 +7,8 @@ package TestApp::Controller::Fork; use strict; use warnings; use base 'Catalyst::Controller'; -use YAML; + +eval 'use YAML'; sub system : Local { my ($self, $c, $ls) = @_; diff --git a/t/lib/TestApp/Controller/Immutable.pm b/t/lib/TestApp/Controller/Immutable.pm new file mode 100644 index 0000000..8368889 --- /dev/null +++ b/t/lib/TestApp/Controller/Immutable.pm @@ -0,0 +1,5 @@ +package TestApp::Controller::Immutable; +use Moose; +BEGIN { extends 'Catalyst::Controller' } +no Moose; +__PACKAGE__->meta->make_immutable; diff --git a/t/lib/TestApp/Controller/Immutable/HardToReload.pm b/t/lib/TestApp/Controller/Immutable/HardToReload.pm new file mode 100644 index 0000000..599ecc8 --- /dev/null +++ b/t/lib/TestApp/Controller/Immutable/HardToReload.pm @@ -0,0 +1,30 @@ +package TestApp::Controller::Immutable::HardToReload::Role; +use Moose::Role; # Role metaclass does not have make_immutable.. +no Moose::Role; + +package TestApp::Controller::Immutable::HardToReload; +use Moose; +BEGIN { extends 'Catalyst::Controller' } +no Moose; +__PACKAGE__->meta->make_immutable; + +package # Standard PAUSE hiding technique + TestApp::Controller::Immutable::HardToReload::PAUSEHide; +use Moose; +BEGIN { extends 'Catalyst::Controller' } +no Moose; +__PACKAGE__->meta->make_immutable; + +# Not an inner package +package TestApp::Controller::Immutable2; +use Moose; +BEGIN { extends 'Catalyst::Controller' } +no Moose; +__PACKAGE__->meta->make_immutable; + +# Not even in the app namespace +package Frobnitz; +use Moose; +BEGIN { extends 'Catalyst::Controller' } +no Moose; +__PACKAGE__->meta->make_immutable; diff --git a/t/lib/TestApp/DispatchType/CustomPostLoad.pm b/t/lib/TestApp/DispatchType/CustomPostLoad.pm new file mode 100644 index 0000000..fcd6145 --- /dev/null +++ b/t/lib/TestApp/DispatchType/CustomPostLoad.pm @@ -0,0 +1,10 @@ +package TestApp::DispatchType::CustomPostLoad; +use strict; +use warnings; +use base qw/Catalyst::DispatchType::Path/; + +# Never match anything.. +sub match { } + +1; + diff --git a/t/lib/TestApp/DispatchType/CustomPreLoad.pm b/t/lib/TestApp/DispatchType/CustomPreLoad.pm new file mode 100644 index 0000000..277779a --- /dev/null +++ b/t/lib/TestApp/DispatchType/CustomPreLoad.pm @@ -0,0 +1,10 @@ +package TestApp::DispatchType::CustomPreLoad; +use strict; +use warnings; +use base qw/Catalyst::DispatchType::Path/; + +# Never match anything.. +sub match { } + +1; + diff --git a/t/lib/TestApp/Model/Foo.pm b/t/lib/TestApp/Model/Foo.pm index b0418e8..d4af11c 100644 --- a/t/lib/TestApp/Model/Foo.pm +++ b/t/lib/TestApp/Model/Foo.pm @@ -5,8 +5,12 @@ use warnings; use base qw/ Catalyst::Model /; +__PACKAGE__->config( 'quux' => 'chunkybacon' ); + sub model_foo_method { 1 } +sub model_quux_method { shift->{quux} } + package TestApp::Model::Foo::Bar; sub model_foo_bar_method_from_foo { 1 } diff --git a/t/lib/TestApp/Plugin/AddDispatchTypes.pm b/t/lib/TestApp/Plugin/AddDispatchTypes.pm new file mode 100644 index 0000000..c1d30e5 --- /dev/null +++ b/t/lib/TestApp/Plugin/AddDispatchTypes.pm @@ -0,0 +1,26 @@ +package TestApp::Plugin::AddDispatchTypes; +use strict; +use warnings; +use MRO::Compat; + +sub setup_dispatcher { + my $class = shift; + + ### Load custom DispatchTypes, as done by Catalyst::Plugin::Server + # There should be a waaay less ugly method for doing this, + # FIXME in 5.9 + $class->next::method( @_ ); + $class->dispatcher->preload_dispatch_types( + @{$class->dispatcher->preload_dispatch_types}, + qw/ +TestApp::DispatchType::CustomPreLoad / + ); + $class->dispatcher->postload_dispatch_types( + @{$class->dispatcher->postload_dispatch_types}, + qw/ +TestApp::DispatchType::CustomPostLoad / + ); + + return $class; +} + +1; + diff --git a/t/lib/TestApp/RequestBaseBug.pm b/t/lib/TestApp/RequestBaseBug.pm new file mode 100644 index 0000000..da0b47d --- /dev/null +++ b/t/lib/TestApp/RequestBaseBug.pm @@ -0,0 +1,14 @@ +package TestApp::RequestBaseBug; + +use base 'Catalyst::Request'; + +sub uri { + my $self = shift; + +# this goes into infinite mutual recursion + $self->base; + + $self->SUPER::uri(@_) +} + +1; diff --git a/t/lib/TestApp/View/Dump.pm b/t/lib/TestApp/View/Dump.pm index 7acfa6d..c4c29db 100644 --- a/t/lib/TestApp/View/Dump.pm +++ b/t/lib/TestApp/View/Dump.pm @@ -4,7 +4,7 @@ use strict; use base 'Catalyst::View'; use Data::Dumper (); -use Scalar::Util qw(weaken); +use Scalar::Util qw(blessed weaken); sub dump { my ( $self, $reference ) = @_; @@ -28,14 +28,16 @@ sub process { # Force processing of on-demand data $c->prepare_body; - # Remove context from reference if needed - my $context = delete $reference->{_context}; - # Remove body from reference if needed + $reference->{__body_type} = blessed $reference->body + if (blessed $reference->{_body}); my $body = delete $reference->{_body}; + # Remove context from reference if needed + my $context = delete $reference->{_context}; + if ( my $output = - $self->dump( $reference || $c->stash->{dump} || $c->stash ) ) + $self->dump( $reference ) ) { $c->res->headers->content_type('text/plain'); @@ -46,6 +48,7 @@ sub process { weaken( $reference->{_context} ); # Repair body + delete $reference->{__body_type}; $reference->{_body} = $body; return 1; diff --git a/t/lib/TestApp/View/Dump/Body.pm b/t/lib/TestApp/View/Dump/Body.pm new file mode 100644 index 0000000..369ccbd --- /dev/null +++ b/t/lib/TestApp/View/Dump/Body.pm @@ -0,0 +1,11 @@ +package TestApp::View::Dump::Body; + +use strict; +use base qw[TestApp::View::Dump]; + +sub process { + my ( $self, $c ) = @_; + return $self->SUPER::process( $c, $c->request->{_body} ); # FIXME, accessor doesn't work? +} + +1; diff --git a/t/lib/TestAppDoubleAutoBug.pm b/t/lib/TestAppDoubleAutoBug.pm index 5c72461..00855cd 100644 --- a/t/lib/TestAppDoubleAutoBug.pm +++ b/t/lib/TestAppDoubleAutoBug.pm @@ -18,7 +18,7 @@ __PACKAGE__->setup; sub execute { my $c = shift; my $class = ref( $c->component( $_[0] ) ) || $_[0]; - my $action = "$_[1]"; + my $action = $_[1]->reverse(); my $method; diff --git a/t/live_catalyst_test.t b/t/live_catalyst_test.t new file mode 100644 index 0000000..f4f695e --- /dev/null +++ b/t/live_catalyst_test.t @@ -0,0 +1,32 @@ +use FindBin; +use lib "$FindBin::Bin/lib"; +use Catalyst::Test 'TestApp', {default_host => 'default.com'}; +use Catalyst::Request; + +use Test::More tests => 8; + +content_like('/',qr/root/,'content check'); +action_ok('/','Action ok ok','normal action ok'); +action_redirect('/engine/response/redirect/one','redirect check'); +action_notfound('/engine/response/status/s404','notfound check'); +contenttype_is('/action/local/one','text/plain','Contenttype check'); + +my $creq; +my $req = '/dump/request'; + +{ + eval '$creq = ' . request($req)->content; + is( $creq->uri->host, 'default.com', 'request targets default host set via import' ); +} + +{ + local $Catalyst::Test::default_host = 'localized.com'; + eval '$creq = ' . request($req)->content; + is( $creq->uri->host, 'localized.com', 'target host is mutable via package var' ); +} + +{ + my %opts = ( host => 'opthash.com' ); + eval '$creq = ' . request($req, \%opts)->content; + is( $creq->uri->host, $opts{host}, 'target host is mutable via options hashref' ); +} diff --git a/t/live_fork.t b/t/live_fork.t index bd7054e..d10e9d5 100644 --- a/t/live_fork.t +++ b/t/live_fork.t @@ -1,5 +1,5 @@ #!/usr/bin/perl -# live_fork.t +# live_fork.t # Copyright (c) 2006 Jonathan Rockway =head1 SYNOPSIS @@ -10,17 +10,19 @@ Tests if Catalyst can fork/exec other processes successfully use strict; use warnings; use Test::More; -use YAML; use FindBin; use lib "$FindBin::Bin/lib"; use Catalyst::Test qw(TestApp); -plan skip_all => 'Using remote server' - if $ENV{CATALYST_SERVER}; - +eval 'use YAML'; +plan skip_all => 'YAML required' if $@; + +plan skip_all => 'Using remote server (and REMOTE_FORK not set)' + if $ENV{CATALYST_SERVER} && !$ENV{REMOTE_FORK}; + plan skip_all => 'Skipping fork tests: no /bin/ls' if !-e '/bin/ls'; # see if /bin/ls exists - + plan tests => 13; # otherwise { @@ -28,30 +30,30 @@ plan tests => 13; # otherwise ok(my $result = get('/fork/system/%2Fbin%2Fls'), 'system'); my @result = split /$/m, $result; $result = join q{}, @result[-4..-1]; - + my $result_ref = eval { Load($result) }; ok($result_ref, 'is YAML'); is($result_ref->{result}, 0, 'exited OK'); } -{ +{ backticks: ok(my $result = get('/fork/backticks/%2Fbin%2Fls'), '`backticks`'); my @result = split /$/m, $result; $result = join q{}, @result[-4..-1]; - + my $result_ref = eval { Load($result) }; ok($result_ref, 'is YAML'); is($result_ref->{code}, 0, 'exited successfully'); like($result_ref->{result}, qr{^/bin/ls[^:]}, 'contains ^/bin/ls$'); like($result_ref->{result}, qr{\n.*\n}m, 'contains two newlines'); } -{ +{ fork: ok(my $result = get('/fork/fork'), 'fork'); my @result = split /$/m, $result; $result = join q{}, @result[-4..-1]; - + my $result_ref = eval { Load($result) }; ok($result_ref, 'is YAML'); isnt($result_ref->{pid}, 0, q{fork's "pid" wasn't 0}); diff --git a/t/live_stats.t b/t/live_stats.t index 48bffd1..a8c9c13 100644 --- a/t/live_stats.t +++ b/t/live_stats.t @@ -23,7 +23,7 @@ else { { ok( my $response = request('http://localhost/'), 'Request' ); ok( $response->is_success, 'Response Successful 2xx' ); - ok( $response->content =~ m/\/default.*?[\d.]+s.*- test.*[\d.]+s/s, 'Stats report'); + like( $response->content, qr/\/default.*?[\d.]+s.*- test.*[\d.]+s/s, 'Stats report'); } diff --git a/t/meta_method_unneeded.t b/t/meta_method_unneeded.t new file mode 100644 index 0000000..f083fce --- /dev/null +++ b/t/meta_method_unneeded.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More tests => 1; +use Test::Exception; +use Carp (); +$SIG{__DIE__} = \&Carp::confess; # Stacktrace please. + +# Doing various silly things, like for example +# use CGI qw/:stanard/ in your conrtoller / app +# will overwrite your meta method, therefore Catalyst +# can't depend on it being there correctly. + +# This is/was demonstrated by Catalyst::Controller::WrapCGI +# and Catalyst::Plugin::Cache::Curried + +{ + package TestAppWithMeta; + use Catalyst; + no warnings 'redefine'; + sub meta {} +} + +lives_ok { TestAppWithMeta->setup } 'Can setup an app which defines its own meta method'; diff --git a/t/optional_apache-cgi-rewrite.pl b/t/optional_apache-cgi-rewrite.pl index ce4d9c8..8ce1d6b 100755 --- a/t/optional_apache-cgi-rewrite.pl +++ b/t/optional_apache-cgi-rewrite.pl @@ -37,7 +37,7 @@ if ( !-e 't/optional_apache-cgi-rewrite.pl' ) { die "ERROR: Please run test from the Catalyst-Runtime directory\n"; } -push @ARGV, glob( 't/live_*' ); +push @ARGV, glob( 't/aggregate/live_*' ); Apache::TestRun->new->run(@ARGV); diff --git a/t/optional_apache-cgi.pl b/t/optional_apache-cgi.pl index 160ec7a..fd2d9a6 100755 --- a/t/optional_apache-cgi.pl +++ b/t/optional_apache-cgi.pl @@ -37,7 +37,7 @@ if ( !-e 't/optional_apache-cgi.pl' ) { die "ERROR: Please run test from the Catalyst-Runtime directory\n"; } -push @ARGV, glob( 't/live_*' ); +push @ARGV, glob( 't/aggregate/live_*' ); Apache::TestRun->new->run(@ARGV); diff --git a/t/optional_apache-fastcgi-non-root.pl b/t/optional_apache-fastcgi-non-root.pl index 11eb8ca..23ea42d 100755 --- a/t/optional_apache-fastcgi-non-root.pl +++ b/t/optional_apache-fastcgi-non-root.pl @@ -37,7 +37,7 @@ if ( !-e 't/optional_apache-fastcgi.pl' ) { die "ERROR: Please run test from the Catalyst-Runtime directory\n"; } -push @ARGV, glob( 't/live_*' ); +push @ARGV, glob( 't/aggregate/live_*' ); Apache::TestRun->new->run(@ARGV); diff --git a/t/optional_apache-fastcgi.pl b/t/optional_apache-fastcgi.pl index 9ad2ca6..715a623 100755 --- a/t/optional_apache-fastcgi.pl +++ b/t/optional_apache-fastcgi.pl @@ -37,7 +37,7 @@ if ( !-e 't/optional_apache-fastcgi.pl' ) { die "ERROR: Please run test from the Catalyst-Runtime directory\n"; } -push @ARGV, glob( 't/live_*' ); +push @ARGV, glob( 't/aggregate/live_*' ); Apache::TestRun->new->run(@ARGV); diff --git a/t/optional_http-server-restart.t b/t/optional_http-server-restart.t index 48e7013..39f475a 100644 --- a/t/optional_http-server-restart.t +++ b/t/optional_http-server-restart.t @@ -3,16 +3,20 @@ use strict; use warnings; +use Test::More; +BEGIN { + plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP}; +} + use File::Path; use FindBin; use LWP::Simple; use IO::Socket; use IPC::Open3; -use Test::More; +use Catalyst::Engine::HTTP::Restarter::Watcher; use Time::HiRes qw/sleep/; eval "use Catalyst::Devel 1.0;"; -plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP}; plan skip_all => 'Catalyst::Devel required' if $@; plan skip_all => 'Catalyst::Devel >= 1.04 required' if $Catalyst::Devel::VERSION <= 1.03; eval "use File::Copy::Recursive"; @@ -29,7 +33,7 @@ rmtree $tmpdir if -d $tmpdir; mkdir $tmpdir; chdir $tmpdir; -system( 'perl', "-I$FindBin::Bin/../lib", "$FindBin::Bin/../script/catalyst.pl", 'TestApp' ); +system( $^X, "-I$FindBin::Bin/../lib", "$FindBin::Bin/../script/catalyst.pl", 'TestApp' ); chdir "$FindBin::Bin/.."; File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' ); @@ -42,7 +46,7 @@ my $port = 30000 + int rand( 1 + 10000 ); my( $server, $pid ); $pid = open3( undef, $server, undef, - 'perl', "-I$FindBin::Bin/../lib", + $^X, "-I$FindBin::Bin/../lib", "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', $port, '-restart' ) or die "Unable to spawn standalone HTTP server: $!"; @@ -62,9 +66,12 @@ while ( check_port( 'localhost', $port ) != 1 ) { my @files = ( "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp.pm", "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm", -"$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Engine/Request/URI.pm", + "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable.pm", ); +push(@files, "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable/HardToReload.pm") + if Catalyst::Engine::HTTP::Restarter::Watcher::DETECT_PACKAGE_COMPILATION(); + # change some files and make sure the server restarts itself NON_ERROR_RESTART: for ( 1 .. 20 ) { @@ -173,7 +180,7 @@ my $restartdirs = join ' ', map{ } qw/Action Engine/; $pid = open3( undef, $server, undef, - 'perl', "-I$FindBin::Bin/../lib", + $^X, "-I$FindBin::Bin/../lib", "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', $port, '-restart', $restartdirs ) or die "Unable to spawn standalone HTTP server: $!"; @@ -204,7 +211,7 @@ for ( 1 .. 20 ) { sleep 0.1; if ( $count++ > 100 ) { fail "Server restarted"; - SKIP_NO_RESTART_2: { + SKIP: { skip "Server didn't restart, no sense in checking response", 1; } next MULTI_DIR_RESTART; diff --git a/t/optional_http-server.t b/t/optional_http-server.t index bf1878b..60f9259 100644 --- a/t/optional_http-server.t +++ b/t/optional_http-server.t @@ -1,13 +1,16 @@ use strict; use warnings; +use Test::More; +BEGIN { + plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP}; +} + use File::Path; use FindBin; use IPC::Open3; use IO::Socket; -use Test::More; -plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP}; eval "use Catalyst::Devel 1.0"; plan skip_all => 'Catalyst::Devel required' if $@; eval "use File::Copy::Recursive"; @@ -25,7 +28,7 @@ rmtree $tmpdir if -d $tmpdir; # create a TestApp and copy the test libs into it mkdir $tmpdir; chdir $tmpdir; -system( 'perl', "-I$FindBin::Bin/../lib", "$FindBin::Bin/../script/catalyst.pl", 'TestApp' ); +system( $^X, "-I$FindBin::Bin/../lib", "$FindBin::Bin/../script/catalyst.pl", 'TestApp' ); chdir "$FindBin::Bin/.."; File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' ); @@ -35,7 +38,7 @@ rmtree 't/tmp/TestApp/t'; # spawn the standalone HTTP server my $port = 30000 + int rand(1 + 10000); my $pid = open3( undef, my $server, undef, - 'perl', "-I$FindBin::Bin/../lib", + $^X, "-I$FindBin::Bin/../lib", "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', $port ) or die "Unable to spawn standalone HTTP server: $!"; @@ -50,10 +53,10 @@ $ENV{CATALYST_SERVER} = "http://localhost:$port"; my $return; if ( $single_test ) { - $return = system( "perl -Ilib/ $single_test" ); + $return = system( "$^X -Ilib/ $single_test" ); } else { - $return = system( 'prove -r -Ilib/ t/live_*.t' ); + $return = prove( '-r', '-Ilib/', glob('t/aggregate/live_*.t') ); } # shut it down @@ -81,3 +84,15 @@ sub check_port { return 0; } } + +sub prove { + if (!(my $pid = fork)) { + require App::Prove; + my $prove = App::Prove->new; + $prove->process_args(@_); + exit( $prove->run ? 0 : 1 ); + } else { + waitpid $pid, 0; + return $?; + } +} diff --git a/t/optional_lighttpd-fastcgi-non-root.t b/t/optional_lighttpd-fastcgi-non-root.t index f27ee28..db191f3 100644 --- a/t/optional_lighttpd-fastcgi-non-root.t +++ b/t/optional_lighttpd-fastcgi-non-root.t @@ -3,14 +3,16 @@ use strict; use warnings; +use Test::More; +BEGIN { + plan skip_all => 'set TEST_LIGHTTPD to enable this test' + unless $ENV{TEST_LIGHTTPD}; +} + use File::Path; use FindBin; use IO::Socket; -use Test::More; -plan skip_all => 'set TEST_LIGHTTPD to enable this test' - unless $ENV{TEST_LIGHTTPD}; - eval "use FCGI"; plan skip_all => 'FCGI required' if $@; @@ -37,7 +39,7 @@ rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp"; # create a TestApp and copy the test libs into it mkdir "$FindBin::Bin/../t/tmp"; chdir "$FindBin::Bin/../t/tmp"; -system "perl -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp"; +system "$^X -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp"; chdir "$FindBin::Bin/.."; File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' ); @@ -107,7 +109,7 @@ while ( check_port( 'localhost', $port ) != 1 ) { # run the testsuite against the server $ENV{CATALYST_SERVER} = "http://localhost:$port/deep/path"; -my @tests = (shift) || glob('t/live_*'); +my @tests = (shift) || glob('t/aggregate/live_*'); eval { runtests(@tests); }; diff --git a/t/optional_lighttpd-fastcgi.t b/t/optional_lighttpd-fastcgi.t index b64c186..98567f7 100644 --- a/t/optional_lighttpd-fastcgi.t +++ b/t/optional_lighttpd-fastcgi.t @@ -3,14 +3,16 @@ use strict; use warnings; +use Test::More; +BEGIN { + plan skip_all => 'set TEST_LIGHTTPD to enable this test' + unless $ENV{TEST_LIGHTTPD}; +} + use File::Path; use FindBin; use IO::Socket; -use Test::More; -plan skip_all => 'set TEST_LIGHTTPD to enable this test' - unless $ENV{TEST_LIGHTTPD}; - eval "use FCGI"; plan skip_all => 'FCGI required' if $@; @@ -37,7 +39,7 @@ rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp"; # create a TestApp and copy the test libs into it mkdir "$FindBin::Bin/../t/tmp"; chdir "$FindBin::Bin/../t/tmp"; -system "perl -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp"; +system "$^X -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp"; chdir "$FindBin::Bin/.."; File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' ); @@ -102,7 +104,7 @@ while ( check_port( 'localhost', $port ) != 1 ) { # run the testsuite against the server $ENV{CATALYST_SERVER} = "http://localhost:$port"; -my @tests = (shift) || glob('t/live_*'); +my @tests = (shift) || glob('t/aggregate/live_*'); eval { runtests(@tests); }; diff --git a/t/optional_memleak.t b/t/optional_memleak.t index 35e0365..ba193a3 100644 --- a/t/optional_memleak.t +++ b/t/optional_memleak.t @@ -3,21 +3,25 @@ use strict; use warnings; +use Test::More; +BEGIN { + plan skip_all => 'set TEST_MEMLEAK to enable this test' + unless $ENV{TEST_MEMLEAK}; +} + use FindBin; use lib "$FindBin::Bin/lib"; - -use Test::More; use Catalyst::Test 'TestApp'; -use YAML; -eval "use Proc::ProcessTable"; -plan skip_all => 'set TEST_MEMLEAK to enable this test' - unless $ENV{TEST_MEMLEAK}; +eval "use Proc::ProcessTable"; plan skip_all => 'Proc::ProcessTable required for this test' if $@; eval "use HTTP::Body 0.03"; plan skip_all => 'HTTP::Body >= 0.03 required for this test' if $@; +eval "use YAML"; +plan skip_all => 'YAML required for this test' if $@; + our $t = Proc::ProcessTable->new( cache_ttys => 1 ); our ( $initial, $final ) = ( 0, 0 ); our $tests = YAML::LoadFile("$FindBin::Bin/optional_stress.yml"); @@ -63,7 +67,7 @@ sub run_test { print "Final Size: $final\n"; if ( $final > $initial ) { - print "Leaked: " . ($final - $initial) . " K\n"; + print "Leaked: " . ($final - $initial) . "K\n"; } is( $final, $initial, "'$uri' memory is not leaking" ); diff --git a/t/optional_stress.t b/t/optional_stress.t index eed111a..c4ccee2 100644 --- a/t/optional_stress.t +++ b/t/optional_stress.t @@ -3,18 +3,21 @@ use strict; use warnings; +use Test::More; +BEGIN { + plan skip_all => 'set TEST_STRESS to enable this test' + unless $ENV{TEST_STRESS}; +} + use FindBin; use lib "$FindBin::Bin/lib"; - -use Test::More; use Catalyst::Test 'TestApp'; -use YAML; our ( $iters, $tests ); BEGIN { - plan skip_all => 'set TEST_STRESS to enable this test' - unless $ENV{TEST_STRESS}; + eval "use YAML"; + plan skip_all => 'YAML is required for this test' if $@; $iters = $ENV{TEST_STRESS} || 10; $tests = YAML::LoadFile("$FindBin::Bin/optional_stress.yml"); diff --git a/t/optional_threads.t b/t/optional_threads.t index 05b4c96..baa4089 100644 --- a/t/optional_threads.t +++ b/t/optional_threads.t @@ -3,18 +3,19 @@ use strict; use warnings; +use Test::More; +BEGIN { + plan skip_all => 'set TEST_THREADS to enable this test' + unless $ENV{TEST_THREADS}; +} + use FindBin; use lib "$FindBin::Bin/lib"; - -use Test::More; use Catalyst::Test 'TestApp'; use Catalyst::Request; use Config; use HTTP::Response; -plan skip_all => 'set TEST_THREADS to enable this test' - unless $ENV{TEST_THREADS}; - if ( $Config{useithreads} && !$ENV{CATALYST_SERVER} ) { require threads; plan tests => 3; diff --git a/t/plugin_new_method_backcompat.t b/t/plugin_new_method_backcompat.t new file mode 100644 index 0000000..74e8f10 --- /dev/null +++ b/t/plugin_new_method_backcompat.t @@ -0,0 +1,52 @@ +# Test that plugins with their own new method don't break applications. + +# 5.70 creates all of the request/response structure itself in prepare, +# and as the new method in our plugin just blesses our args, that works nicely. + +# In 5.80, we rely on the new method to appropriately initialise data +# structures, and therefore we need to inline a new method on MyApp to ensure +# that plugins don't get it wrong for us. + +# Also tests method modifiers and etc in MyApp.pm still work as expected. +use Test::More tests => 3; + +{ + package NewTestPlugin; + use strict; + use warnings; + sub new { + my $class = shift; + return bless $_[0], $class; + } +} + +{ # This is all in the same file so that the setup method on the + # application is called at runtime, rather than at compile time. + # This ensures that the end of scope hook has to happen at runtime + # correctly, otherwise the test will fail (ergo the switch from + # B::Hooks::EndOfScope to Sub::Uplevel) + package TestAppPluginWithNewMethod; + use Test::Exception; + use Catalyst qw/+NewTestPlugin/; + + sub foo : Local { + my ($self, $c) = @_; + $c->res->body('foo'); + } + + use Moose; # Just testing method modifiers still work. + __PACKAGE__->setup; + our $MODIFIER_FIRED = 0; + + lives_ok { + before 'dispatch' => sub { $MODIFIER_FIRED = 1 } + } 'Can apply method modifier'; + no Moose; +} + +use FindBin; +use lib "$FindBin::Bin/lib"; + +use Catalyst::Test qw/TestAppPluginWithNewMethod/; +ok request('/foo')->is_success; +is $TestAppPluginWithNewMethod::MODIFIER_FIRED, 1, 'Before modifier was fired correctly.'; diff --git a/t/unit_core_classdata.t b/t/unit_core_classdata.t new file mode 100644 index 0000000..6d60a96 --- /dev/null +++ b/t/unit_core_classdata.t @@ -0,0 +1,102 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Scalar::Util qw/refaddr blessed/; +use Test::More tests => 37; + +{ + package ClassDataTest; + use Moose; + with 'Catalyst::ClassData'; + + package ClassDataTest2; + use Moose; + extends 'ClassDataTest'; + +} + + my $scalar = '100'; + my $arrayref = []; + my $hashref = {}; + my $scalarref = \$scalar; + my $coderef = sub { "beep" }; + + my $scalar2 = '200'; + my $arrayref2 = []; + my $hashref2 = {}; + my $scalarref2 = \$scalar2; + my $coderef2 = sub { "beep" }; + + my $scalar3 = '300'; + my $arrayref3 = []; + my $hashref3 = {}; + my $scalarref3 = \$scalar3; + my $coderef3 = sub { "beep" }; + + +my @accessors = qw/_arrayref _hashref _scalarref _coderef _scalar/; +ClassDataTest->mk_classdata($_) for @accessors; +can_ok('ClassDataTest', @accessors); + +ClassDataTest2->mk_classdata("beep", "meep"); +is(ClassDataTest2->beep, "meep"); + +ClassDataTest->_arrayref($arrayref); +ClassDataTest->_hashref($hashref); +ClassDataTest->_scalarref($scalarref); +ClassDataTest->_coderef($coderef); +ClassDataTest->_scalar($scalar); + +is(ref(ClassDataTest->_arrayref), 'ARRAY'); +is(ref(ClassDataTest->_hashref), 'HASH'); +is(ref(ClassDataTest->_scalarref), 'SCALAR'); +is(ref(ClassDataTest->_coderef), 'CODE'); +ok( !ref(ClassDataTest->_scalar) ); +is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref)); +is(refaddr(ClassDataTest->_hashref), refaddr($hashref)); +is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref)); +is(refaddr(ClassDataTest->_coderef), refaddr($coderef)); +is(ClassDataTest->_scalar, $scalar); + + +is(ref(ClassDataTest2->_arrayref), 'ARRAY'); +is(ref(ClassDataTest2->_hashref), 'HASH'); +is(ref(ClassDataTest2->_scalarref), 'SCALAR'); +is(ref(ClassDataTest2->_coderef), 'CODE'); +ok( !ref(ClassDataTest2->_scalar) ); +is(refaddr(ClassDataTest2->_arrayref), refaddr($arrayref)); +is(refaddr(ClassDataTest2->_hashref), refaddr($hashref)); +is(refaddr(ClassDataTest2->_scalarref), refaddr($scalarref)); +is(refaddr(ClassDataTest2->_coderef), refaddr($coderef)); +is(ClassDataTest2->_scalar, $scalar); + +ClassDataTest2->_arrayref($arrayref2); +ClassDataTest2->_hashref($hashref2); +ClassDataTest2->_scalarref($scalarref2); +ClassDataTest2->_coderef($coderef2); +ClassDataTest2->_scalar($scalar2); + +is(refaddr(ClassDataTest2->_arrayref), refaddr($arrayref2)); +is(refaddr(ClassDataTest2->_hashref), refaddr($hashref2)); +is(refaddr(ClassDataTest2->_scalarref), refaddr($scalarref2)); +is(refaddr(ClassDataTest2->_coderef), refaddr($coderef2)); +is(ClassDataTest2->_scalar, $scalar2); + +is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref)); +is(refaddr(ClassDataTest->_hashref), refaddr($hashref)); +is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref)); +is(refaddr(ClassDataTest->_coderef), refaddr($coderef)); +is(ClassDataTest->_scalar, $scalar); + +ClassDataTest->_arrayref($arrayref3); +ClassDataTest->_hashref($hashref3); +ClassDataTest->_scalarref($scalarref3); +ClassDataTest->_coderef($coderef3); +ClassDataTest->_scalar($scalar3); + +is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref3)); +is(refaddr(ClassDataTest->_hashref), refaddr($hashref3)); +is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref3)); +is(refaddr(ClassDataTest->_coderef), refaddr($coderef3)); +is(ClassDataTest->_scalar, $scalar3); diff --git a/t/unit_core_component.t b/t/unit_core_component.t index 250960a..368f163 100644 --- a/t/unit_core_component.t +++ b/t/unit_core_component.t @@ -73,16 +73,20 @@ is_deeply([ MyApp->comp('Foo') ], \@complist, 'Fallthrough return ok'); { my $args; - no warnings; - *MyApp::M::Model::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; + { + no warnings 'once'; + *MyApp::M::Model::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; + } + + my $c = bless {}, 'MyApp'; - MyApp->component('MyApp::M::Model', qw/foo bar/); + $c->component('MyApp::M::Model', qw/foo bar/); is_deeply($args, [qw/foo bar/], 'args passed to ACCEPT_CONTEXT ok'); - MyApp->component('M::Model', qw/foo2 bar2/); + $c->component('M::Model', qw/foo2 bar2/); is_deeply($args, [qw/foo2 bar2/], 'args passed to ACCEPT_CONTEXT ok'); - MyApp->component('Mode', qw/foo3 bar3/); + $c->component('Mode', qw/foo3 bar3/); is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok'); } diff --git a/t/unit_core_component_loading.t b/t/unit_core_component_loading.t index 5b6a4a7..6b9f8da 100644 --- a/t/unit_core_component_loading.t +++ b/t/unit_core_component_loading.t @@ -63,9 +63,10 @@ sub make_component_file { write_component_file(\@dir_list, $name_final, <NEXT::COMPONENT(\@_); + my \$self = shift->next::method(\@_); no strict 'refs'; *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; }; \$self; @@ -165,7 +166,7 @@ package ${appclass}::Model::TopLevel; use base 'Catalyst::Model'; sub COMPONENT { - my \$self = shift->NEXT::COMPONENT(\@_); + my \$self = shift->next::method(\@_); no strict 'refs'; *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; }; \$self; @@ -184,7 +185,7 @@ package ${appclass}::Model::TopLevel::Nested; use base 'Catalyst::Model'; no warnings 'redefine'; -sub COMPONENT { return shift->NEXT::COMPONENT(\@_); } +sub COMPONENT { return shift->next::method(\@_); } 1; EOF diff --git a/t/unit_core_component_mro.t b/t/unit_core_component_mro.t new file mode 100644 index 0000000..a8699c3 --- /dev/null +++ b/t/unit_core_component_mro.t @@ -0,0 +1,29 @@ +use Test::More tests => 1; +use strict; +use warnings; + +{ + package MyApp::Component; + use Test::More; + + sub COMPONENT { + fail 'This no longer gets dispatched to'; + } + + package MyApp::MyComponent; + + use base 'Catalyst::Component', 'MyApp::Component'; + +} + +my $warn = ''; +{ + local $SIG{__WARN__} = sub { + $warn .= $_[0]; + }; + MyApp::MyComponent->COMPONENT('MyApp'); +} + +like($warn, qr/after Catalyst::Component in MyApp::Component/, + 'correct warning thrown'); + diff --git a/t/unit_core_mvc.t b/t/unit_core_mvc.t index f641014..0953e2c 100644 --- a/t/unit_core_mvc.t +++ b/t/unit_core_mvc.t @@ -150,22 +150,28 @@ is ( MyApp->model , 'MyApp::Model::M', 'default_model in class method ok'); { my $args; - no warnings; - *MyApp::Model::M::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; - *MyApp::View::V::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; + { + no warnings 'once'; + *MyApp::Model::M::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; + *MyApp::View::V::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; + } + + my $c = bless {}, 'MyApp'; # test accept-context with class rather than instance MyApp->model('M', qw/foo bar/); - is_deeply($args, [qw/foo bar/], '$c->model args passed to ACCEPT_CONTEXT ok'); + is_deeply($args, [qw/foo bar/], 'MyApp->model args passed to ACCEPT_CONTEXT ok'); - MyApp->model('M', qw/foo bar/); + $c->model('M', qw/foo bar/); is_deeply($args, [qw/foo bar/], '$c->model args passed to ACCEPT_CONTEXT ok'); - my $x = MyApp->view('V', qw/foo2 bar2/); + my $x = $c->view('V', qw/foo2 bar2/); is_deeply($args, [qw/foo2 bar2/], '$c->view args passed to ACCEPT_CONTEXT ok'); # regexp fallback - MyApp->view('::View::V', qw/foo3 bar3/); + $c->view('::View::V', qw/foo3 bar3/); is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok'); + + } diff --git a/t/unit_core_plugin.t b/t/unit_core_plugin.t index 8781eba..97f8d7b 100644 --- a/t/unit_core_plugin.t +++ b/t/unit_core_plugin.t @@ -19,6 +19,8 @@ use lib 't/lib'; use Catalyst::Test qw/PluginTestApp/; ok( get("/compile_time_plugins"), "get ok" ); +# FIXME - Run time plugin support is insane, and should be removed +# for Catalyst 5.9 ok( get("/run_time_plugins"), "get ok" ); use_ok 'TestApp'; @@ -27,6 +29,7 @@ my @expected = qw( Catalyst::Plugin::Test::Headers Catalyst::Plugin::Test::Inline Catalyst::Plugin::Test::Plugin + TestApp::Plugin::AddDispatchTypes TestApp::Plugin::FullyQualified ); diff --git a/t/unit_core_setup.t b/t/unit_core_setup.t new file mode 100644 index 0000000..70b649e --- /dev/null +++ b/t/unit_core_setup.t @@ -0,0 +1,61 @@ +use strict; +use warnings; +use Catalyst::Runtime; + +use Test::More tests => 20; + +{ + # Silence the log. + no warnings 'redefine'; + *Catalyst::Log::_send_to_log = sub {}; +} + +TESTDEBUG: { + package MyTestDebug; + use base qw/Catalyst/; + __PACKAGE__->setup( + '-Debug', + ); +} + +ok my $c = MyTestDebug->new, 'Get debug app object'; +ok my $log = $c->log, 'Get log object'; +isa_ok $log, 'Catalyst::Log', 'It should be a Catalyst::Log object'; +ok !$log->is_warn, 'Warnings should be disabled'; +ok !$log->is_error, 'Errors should be disabled'; +ok !$log->is_fatal, 'Fatal errors should be disabled'; +ok !$log->is_info, 'Info should be disabled'; +ok $log->is_debug, 'Debugging should be enabled'; +can_ok 'MyTestDebug', 'debug'; +ok +MyTestDebug->debug, 'And it should return true'; + + +TESTAPP: { + package MyTestLog; + use base qw/Catalyst/; + __PACKAGE__->setup( + '-Log=warn,error,fatal' + ); +} + +ok $c = MyTestLog->new, 'Get log app object'; +ok $log = $c->log, 'Get log object'; +isa_ok $log, 'Catalyst::Log', 'It should be a Catalyst::Log object'; +ok $log->is_warn, 'Warnings should be enabled'; +ok $log->is_error, 'Errors should be enabled'; +ok $log->is_fatal, 'Fatal errors should be enabled'; +ok !$log->is_info, 'Info should be disabled'; +ok !$log->is_debug, 'Debugging should be disabled'; + +TESTOWNLOGGER: { + package MyTestAppWithOwnLogger; + use base qw/Catalyst/; + use Test::MockObject; + my $log = Test::MockObject->new; + $log->set_false(qw/debug error fatal info warn/); + __PACKAGE__->log($log); + __PACKAGE__->setup('-Debug'); +} + +ok $c = MyTestAppWithOwnLogger->new, 'Get with own logger app object'; +ok $c->debug, '$c->debug is true'; diff --git a/t/unit_core_uri_for.t b/t/unit_core_uri_for.t index c767ff2..fb5ea1e 100644 --- a/t/unit_core_uri_for.t +++ b/t/unit_core_uri_for.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 15; +use Test::More tests => 16; use URI; use_ok('Catalyst'); @@ -103,3 +103,8 @@ is( is( $warnings, 0, "no warnings emitted" ); } +# Test with parameters '/', 'foo', 'bar' - should not generate a // +is( Catalyst::uri_for( $context, qw| / foo bar | )->as_string, + 'http://127.0.0.1/foo/bar', 'uri is /foo/bar, not //foo/bar' +); + diff --git a/t/unit_dispatcher_requestargs_restore.t b/t/unit_dispatcher_requestargs_restore.t new file mode 100644 index 0000000..731c4da --- /dev/null +++ b/t/unit_dispatcher_requestargs_restore.t @@ -0,0 +1,57 @@ +# Insane test case for the behavior needed by Plugin::Auhorization::ACL + +# We have to localise $c->request->{arguments} in +# Catalyst::Dispatcher::_do_forward, rather than using save and restore, +# as otherwise, the calling $c->detach on an action which says +# die $Catalyst:DETACH causes the request arguments to not get restored, +# and therefore sub gorch gets the wrong string $frozjob parameter. + +# Please feel free to break this behavior once a sane hook for safely +# executing another action from the dispatcher (i.e. wrapping actions) +# is present, so that the Authorization::ACL plugin can be re-written +# to not be full of such crazy shit. +{ + package ACLTestApp; + use Test::More; + + use strict; + use warnings; + use MRO::Compat; + use Scalar::Util (); + + use base qw/Catalyst Catalyst::Controller/; + use Catalyst qw//; + + sub execute { + my $c = shift; + my ( $class, $action ) = @_; + + if ( Scalar::Util::blessed($action) + and $action->name ne "foobar" ) { + eval { $c->detach( 'foobar', [$action, 'foo'] ) }; + } + + $c->next::method( @_ ); + } + + sub foobar : Private { + die $Catalyst::DETACH; + } + + sub gorch : Local { + my ( $self, $c, $frozjob ) = @_; + is $frozjob, 'wozzle'; + $c->res->body("gorch"); + } + + __PACKAGE__->setup; +} + +use strict; +use warnings; +use FindBin qw/$Bin/; +use lib "$Bin/lib"; +use Catalyst::Test 'ACLTestApp'; +use Test::More tests => 1; + +request('http://localhost/gorch/wozzle'); diff --git a/t/unit_load_catalyst_test.t b/t/unit_load_catalyst_test.t index 0dbf8e3..3c9eca9 100644 --- a/t/unit_load_catalyst_test.t +++ b/t/unit_load_catalyst_test.t @@ -4,8 +4,13 @@ use strict; use warnings; use Test::More; +use FindBin qw/$Bin/; +use lib "$Bin/lib"; +use Catalyst::Utils; +use HTTP::Request::Common; +use Test::Exception; -plan tests => 3; +plan tests => 11; use_ok('Catalyst::Test'); @@ -14,3 +19,51 @@ isnt( $@, "", "get returns an error message with no app specified"); eval "request('http://localhost')"; isnt( $@, "", "request returns an error message with no app specified"); + +# FIXME - These vhosts in tests tests should be somewhere else... + +sub customize { Catalyst::Test::_customize_request(@_) } + +{ + my $req = Catalyst::Utils::request('/dummy'); + customize( $req ); + is( $req->header('Host'), undef, 'normal request is unmodified' ); +} + +{ + my $req = Catalyst::Utils::request('/dummy'); + customize( $req, { host => 'customized.com' } ); + like( $req->header('Host'), qr/customized.com/, 'request is customizable via opts hash' ); +} + +{ + my $req = Catalyst::Utils::request('/dummy'); + local $Catalyst::Test::default_host = 'localized.com'; + customize( $req ); + like( $req->header('Host'), qr/localized.com/, 'request is customizable via package var' ); +} + +{ + my $req = Catalyst::Utils::request('/dummy'); + local $Catalyst::Test::default_host = 'localized.com'; + customize( $req, { host => 'customized.com' } ); + like( $req->header('Host'), qr/customized.com/, 'opts hash takes precedence over package var' ); +} + +{ + my $req = Catalyst::Utils::request('/dummy'); + local $Catalyst::Test::default_host = 'localized.com'; + customize( $req, { host => '' } ); + is( $req->header('Host'), undef, 'default value can be temporarily cleared via opts hash' ); +} + +# Back compat test, extra args used to be ignored, now a hashref of options. +use_ok('Catalyst::Test', 'TestApp', 'foobar'); + +# Back compat test, ensure that request ignores anything which isn't a hash. +lives_ok { + request(GET('/dummy'), 'foo'); +} 'scalar additional param to request method ignored'; +lives_ok { + request(GET('/dummy'), []); +} 'array additional param to request method ignored'; diff --git a/t/unit_stats.t b/t/unit_stats.t index e46baf4..928b48e 100644 --- a/t/unit_stats.t +++ b/t/unit_stats.t @@ -69,6 +69,10 @@ BEGIN { use_ok("Catalyst::Stats") }; $stats->profile(comment => "interleave 2"); push(@expected, [ 4, "- interleave 2", 0.2, 0 ]); + $fudge_t[1] = 550000; + $stats->profile(begin => "begin with no end"); + push(@expected, [ 4, "begin with no end", 0.05, 1 ]); + $fudge_t[1] = 600000; # end badly nested block time $stats->profile(end => "badly nested block 1"); @@ -85,6 +89,8 @@ BEGIN { use_ok("Catalyst::Stats") }; my @report = $stats->report; is_deeply(\@report, \@expected, "report"); + # print scalar($stats->report); + is ($stats->elapsed, 14, "elapsed"); } diff --git a/t/unit_utils_load_class.t b/t/unit_utils_load_class.t index 8fe1828..881b1ff 100644 --- a/t/unit_utils_load_class.t +++ b/t/unit_utils_load_class.t @@ -3,7 +3,8 @@ use strict; use warnings; -use Test::More tests => 16; +use Test::More tests => 18; +use Class::MOP; use lib "t/lib"; @@ -15,13 +16,16 @@ BEGIN { use_ok("Catalyst::Utils") }; } my $warnings = 0; -$SIG{__WARN__} = sub { $warnings++ }; +$SIG{__WARN__} = sub { + return if $_[0] =~ /Subroutine (?:un|re|)initialize redefined at .*C3\.pm/; + $warnings++; +}; -ok( !Class::Inspector->loaded("TestApp::View::Dump"), "component not yet loaded" ); +ok( !Class::MOP::is_class_loaded("TestApp::View::Dump"), "component not yet loaded" ); Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump"); -ok( Class::Inspector->loaded("TestApp::View::Dump"), "loaded ok" ); +ok( Class::MOP::is_class_loaded("TestApp::View::Dump"), "loaded ok" ); is( $warnings, 0, "no warnings emitted" ); $warnings = 0; @@ -29,10 +33,10 @@ $warnings = 0; Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump"); is( $warnings, 0, "calling again doesn't reaload" ); -ok( !Class::Inspector->loaded("TestApp::View::Dump::Request"), "component not yet loaded" ); +ok( !Class::MOP::is_class_loaded("TestApp::View::Dump::Request"), "component not yet loaded" ); Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump::Request"); -ok( Class::Inspector->loaded("TestApp::View::Dump::Request"), "loaded ok" ); +ok( Class::MOP::is_class_loaded("TestApp::View::Dump::Request"), "loaded ok" ); is( $warnings, 0, "calling again doesn't reaload" ); @@ -62,3 +66,9 @@ undef $@; eval { Catalyst::Utils::ensure_class_loaded('Silly::File::Name.pm') }; like($@, qr/Malformed class Name/, 'errored sanely when given a classname ending in .pm'); +undef $@; +$warnings = 0; +Catalyst::Utils::ensure_class_loaded("NullPackage"); +is( $warnings, 1, 'Loading a package which defines no symbols warns'); +is( $@, undef, '$@ still undef' ); +