Create branch register_actions.
Florian Ragwitz [Thu, 19 Feb 2009 05:16:12 +0000 (05:16 +0000)]
151 files changed:
Changes
IDEAS [new file with mode: 0644]
Makefile.PL
README [new file with mode: 0644]
TODO [new file with mode: 0644]
lib/Catalyst.pm
lib/Catalyst/Action.pm
lib/Catalyst/ActionChain.pm
lib/Catalyst/ActionContainer.pm
lib/Catalyst/AttrContainer.pm
lib/Catalyst/Base.pm
lib/Catalyst/ClassData.pm [new file with mode: 0644]
lib/Catalyst/Component.pm
lib/Catalyst/Component/ApplicationAttribute.pm [new file with mode: 0644]
lib/Catalyst/Controller.pm
lib/Catalyst/DispatchType.pm
lib/Catalyst/DispatchType/Chained.pm
lib/Catalyst/DispatchType/Default.pm
lib/Catalyst/DispatchType/Index.pm
lib/Catalyst/DispatchType/Path.pm
lib/Catalyst/DispatchType/Regex.pm
lib/Catalyst/Dispatcher.pm
lib/Catalyst/Engine.pm
lib/Catalyst/Engine/CGI.pm
lib/Catalyst/Engine/FastCGI.pm
lib/Catalyst/Engine/HTTP.pm
lib/Catalyst/Engine/HTTP/Restarter.pm
lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm
lib/Catalyst/Exception.pm
lib/Catalyst/Log.pm
lib/Catalyst/Manual.pm
lib/Catalyst/Manual/Installation.pod
lib/Catalyst/Manual/Installation/CentOS4.pod
lib/Catalyst/Model.pm
lib/Catalyst/ROADMAP.pod
lib/Catalyst/Request.pm
lib/Catalyst/Request/Upload.pm
lib/Catalyst/Response.pm
lib/Catalyst/Runtime.pm
lib/Catalyst/Stats.pm
lib/Catalyst/Test.pm
lib/Catalyst/Upgrading.pod [new file with mode: 0644]
lib/Catalyst/Utils.pm
lib/Catalyst/View.pm
t/03podcoverage.t
t/04critic.rc [deleted file]
t/04critic.t
t/aggregate.t [new file with mode: 0644]
t/aggregate/live_component_controller_action_action.t [moved from t/live_component_controller_action_action.t with 99% similarity]
t/aggregate/live_component_controller_action_auto.t [moved from t/live_component_controller_action_auto.t with 99% similarity]
t/aggregate/live_component_controller_action_begin.t [moved from t/live_component_controller_action_begin.t with 97% similarity]
t/aggregate/live_component_controller_action_chained.t [moved from t/live_component_controller_action_chained.t with 97% similarity]
t/aggregate/live_component_controller_action_default.t [moved from t/live_component_controller_action_default.t with 98% similarity]
t/aggregate/live_component_controller_action_detach.t [moved from t/live_component_controller_action_detach.t with 98% similarity]
t/aggregate/live_component_controller_action_end.t [moved from t/live_component_controller_action_end.t with 97% similarity]
t/aggregate/live_component_controller_action_forward.t [moved from t/live_component_controller_action_forward.t with 99% similarity]
t/aggregate/live_component_controller_action_global.t [moved from t/live_component_controller_action_global.t with 98% similarity]
t/aggregate/live_component_controller_action_go.t [moved from t/live_component_controller_action_go.t with 99% similarity]
t/aggregate/live_component_controller_action_index.t [moved from t/live_component_controller_action_index.t with 99% similarity]
t/aggregate/live_component_controller_action_inheritance.t [moved from t/live_component_controller_action_inheritance.t with 99% similarity]
t/aggregate/live_component_controller_action_local.t [moved from t/live_component_controller_action_local.t with 99% similarity]
t/aggregate/live_component_controller_action_multipath.t [moved from t/live_component_controller_action_multipath.t with 95% similarity]
t/aggregate/live_component_controller_action_path.t [moved from t/live_component_controller_action_path.t with 99% similarity]
t/aggregate/live_component_controller_action_private.t [moved from t/live_component_controller_action_private.t with 98% similarity]
t/aggregate/live_component_controller_action_regexp.t [moved from t/live_component_controller_action_regexp.t with 99% similarity]
t/aggregate/live_component_controller_action_streaming.t [moved from t/live_component_controller_action_streaming.t with 93% similarity]
t/aggregate/live_component_controller_action_visit.t [moved from t/live_component_controller_action_visit.t with 99% similarity]
t/aggregate/live_component_controller_args.t [moved from t/live_component_controller_args.t with 98% similarity]
t/aggregate/live_component_controller_moose.t [moved from t/live_component_controller_moose.t with 56% similarity]
t/aggregate/live_engine_request_auth.t [moved from t/live_engine_request_auth.t with 96% similarity]
t/aggregate/live_engine_request_body.t [moved from t/live_engine_request_body.t with 78% similarity]
t/aggregate/live_engine_request_body_demand.t [moved from t/live_engine_request_body_demand.t with 98% similarity]
t/aggregate/live_engine_request_cookies.t [moved from t/live_engine_request_cookies.t with 97% similarity]
t/aggregate/live_engine_request_headers.t [moved from t/live_engine_request_headers.t with 98% similarity]
t/aggregate/live_engine_request_parameters.t [moved from t/live_engine_request_parameters.t with 87% similarity]
t/aggregate/live_engine_request_uploads.t [moved from t/live_engine_request_uploads.t with 75% similarity]
t/aggregate/live_engine_request_uri.t [moved from t/live_engine_request_uri.t with 88% similarity]
t/aggregate/live_engine_response_cookies.t [moved from t/live_engine_response_cookies.t with 98% similarity]
t/aggregate/live_engine_response_errors.t [moved from t/live_engine_response_errors.t with 98% similarity]
t/aggregate/live_engine_response_headers.t [moved from t/live_engine_response_headers.t with 98% similarity]
t/aggregate/live_engine_response_large.t [moved from t/live_engine_response_large.t with 95% similarity]
t/aggregate/live_engine_response_print.t [new file with mode: 0644]
t/aggregate/live_engine_response_redirect.t [moved from t/live_engine_response_redirect.t with 98% similarity]
t/aggregate/live_engine_response_status.t [moved from t/live_engine_response_status.t with 98% similarity]
t/aggregate/live_engine_setup_basics.t [moved from t/live_engine_setup_basics.t with 89% similarity]
t/aggregate/live_engine_setup_plugins.t [moved from t/live_engine_setup_plugins.t with 90% similarity]
t/aggregate/live_loop.t [moved from t/live_loop.t with 94% similarity]
t/aggregate/live_plugin_loaded.t [moved from t/live_plugin_loaded.t with 91% similarity]
t/aggregate/live_priorities.t [moved from t/live_priorities.t with 98% similarity]
t/aggregate/live_recursion.t [moved from t/live_recursion.t with 95% similarity]
t/aggregate/unit_core_action_for.t [moved from t/unit_core_action_for.t with 68% similarity]
t/aggregate/unit_core_component_layers.t [moved from t/unit_core_component_layers.t with 78% similarity]
t/aggregate/unit_core_uri_for_action.t [moved from t/unit_core_uri_for_action.t with 92% similarity]
t/aggregate/unit_core_uri_for_multibytechar.t [moved from t/unit_core_uri_for_multibytechar.t with 93% similarity]
t/c3_mro.t
t/caf_backcompat.t [new file with mode: 0644]
t/cdi_backcompat_plugin_accessor_override.t [new file with mode: 0644]
t/lib/CDICompatTestPlugin.pm [new file with mode: 0644]
t/lib/Catalyst/Action/TestAfter.pm
t/lib/Catalyst/Action/TestBefore.pm
t/lib/Catalyst/Plugin/Test/Errors.pm
t/lib/Catalyst/Plugin/Test/Headers.pm
t/lib/Catalyst/Plugin/Test/Plugin.pm
t/lib/NullPackage.pm [new file with mode: 0644]
t/lib/TestApp.pm
t/lib/TestApp/Action/TestBefore.pm
t/lib/TestApp/Action/TestMyAction.pm
t/lib/TestApp/Controller/Action/Chained.pm
t/lib/TestApp/Controller/Action/Forward.pm
t/lib/TestApp/Controller/Action/Streaming.pm
t/lib/TestApp/Controller/Dump.pm
t/lib/TestApp/Controller/Engine/Response/Print.pm [new file with mode: 0644]
t/lib/TestApp/Controller/Fork.pm
t/lib/TestApp/Controller/Immutable.pm [new file with mode: 0644]
t/lib/TestApp/Controller/Immutable/HardToReload.pm [new file with mode: 0644]
t/lib/TestApp/DispatchType/CustomPostLoad.pm [new file with mode: 0644]
t/lib/TestApp/DispatchType/CustomPreLoad.pm [new file with mode: 0644]
t/lib/TestApp/Model/Foo.pm
t/lib/TestApp/Plugin/AddDispatchTypes.pm [new file with mode: 0644]
t/lib/TestApp/RequestBaseBug.pm [new file with mode: 0644]
t/lib/TestApp/View/Dump.pm
t/lib/TestApp/View/Dump/Body.pm [new file with mode: 0644]
t/lib/TestAppDoubleAutoBug.pm
t/live_catalyst_test.t [new file with mode: 0644]
t/live_fork.t
t/live_stats.t
t/meta_method_unneeded.t [new file with mode: 0644]
t/optional_apache-cgi-rewrite.pl
t/optional_apache-cgi.pl
t/optional_apache-fastcgi-non-root.pl
t/optional_apache-fastcgi.pl
t/optional_http-server-restart.t
t/optional_http-server.t
t/optional_lighttpd-fastcgi-non-root.t
t/optional_lighttpd-fastcgi.t
t/optional_memleak.t
t/optional_stress.t
t/optional_threads.t
t/plugin_new_method_backcompat.t [new file with mode: 0644]
t/unit_core_classdata.t [new file with mode: 0644]
t/unit_core_component.t
t/unit_core_component_loading.t
t/unit_core_component_mro.t [new file with mode: 0644]
t/unit_core_mvc.t
t/unit_core_plugin.t
t/unit_core_setup.t [new file with mode: 0644]
t/unit_core_uri_for.t
t/unit_dispatcher_requestargs_restore.t [new file with mode: 0644]
t/unit_load_catalyst_test.t
t/unit_stats.t
t/unit_utils_load_class.t

diff --git a/Changes b/Changes
index 53d3d18..f5d21d8 100644 (file)
--- a/Changes
+++ b/Changes
 # 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 <cub.uanic@gmail.com>
-        - 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 (file)
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?
index 12fc01e..524248a 100644 (file)
@@ -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 (file)
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 (file)
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!).
index 5294064..8805134 100644 (file)
@@ -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<Catalyst::Plugin::ConfigLoader>.
 
 =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<Catalyst::Dispatcher>.
+Returns the dispatcher instance. See L<Catalyst::Dispatcher>.
 
 =head2 $c->engine
 
-Returns the engine instance. Stringifies to the class name. See
-L<Catalyst::Engine>.
+Returns the engine instance. See L<Catalyst::Engine>.
 
 
 =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<Note:> This method of adding plugins is deprecated. The ability
+to add plugins like this B<will be removed> 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<action_for> on it.
-
-This method must be used to create URIs for
-L<Catalyst::DispatchType::Chained> 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<Chained>
-action in the parts where the definitions contain I<CaptureArgs>. 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<Chained> action these are the equivalent to the
-endpoint L<Args>.
+    }
 
-=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<URI> 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<action_for> 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{(?<!/)$}{/};
@@ -1278,7 +1307,7 @@ sub welcome_message {
                          <a href="http://dev.catalyst.perl.org">Wiki</a>
                      </li>
                      <li>
-                         <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
+                         <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
                      </li>
                      <li>
                          <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
@@ -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{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
             );
         }
     }
 
     # 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<Catalyst::Log|Catalyst::Log> object and
+passing it to C<log()>. Pass in a comma-delimited list of levels to set the
+log to.
+This method also installs a C<debug> 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<setup_log> 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<Catalyst::Plugin::>.
         # 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 <bricas@cpan.org>
 
+Caelum: Rafael Kitover <rkitover@io.com>
+
 chansen: Christian Hansen
 
 chicks: Christopher Hicks
 
+David E. Wheeler
+
 dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
 
 Drew Taylor
@@ -2561,6 +2595,8 @@ Gary Ashton Jones
 
 Geoff Richards
 
+ilmari: Dagfinn Ilmari MannsÃ¥ker <ilmari@ilmari.org>
+
 jcamacho: Juan Camacho
 
 jhannah: Jay Hannah <jay@jays.net>
@@ -2595,16 +2631,18 @@ Oleg Kostyuk <cub.uanic@gmail.com>
 
 phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
 
+rafl: Florian Ragwitz <rafl@debian.org>
+
 sky: Arthur Bergman
 
 the_jester: Jesse Sheidlower
 
+t0m: Tomas Doran <bobtfish@bobtfish.net>
+
 Ulf Edvinsson
 
 willert: Sebastian Willert <willert@cpan.org>
 
-batman: Jan Henning Thorsen <pm@flodhest.net>
-
 =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;
index 6c9e9a1..b96bfbc 100644 (file)
@@ -1,16 +1,12 @@
 package Catalyst::Action;
 
-use strict;
-use base qw/Class::Accessor::Fast/;
-
-
 =head1 NAME
 
 Catalyst::Action - Catalyst Action
 
 =head1 SYNOPSIS
 
-    <form action="[%c.uri_for(c.action.reverse)%]">
+    <form action="[%c.uri_for(c.action)%]">
 
 =head1 DESCRIPTION
 
@@ -21,7 +17,18 @@ L<Catalyst::Controller> 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
index 9ef1513..1518802 100644 (file)
@@ -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
index 9adab59..848f71a 100644 (file)
@@ -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
index f699d9f..443b416 100644 (file)
@@ -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 {
index e6bd821..659a97d 100644 (file)
@@ -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 (file)
index 0000000..72062d9
--- /dev/null
@@ -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<Class::Data::Inheritable> that borrows some ideas from
+L<Class::Accessor::Grouped>;
+
+=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
index 0b48725..80fc838 100644 (file)
@@ -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<Catalyst::Utils>.
 
 =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 (file)
index 0000000..78b292a
--- /dev/null
@@ -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<Catalyst::Component>,
+L<Catalyst::Controller>.
+
+=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
index 5902597..18c8259 100644 (file)
@@ -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__
index ce16150..6ac653d 100644 (file)
@@ -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<Catalyst::Dispatcher> 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<Catalyst::Dispatcher> 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;
index dccd3c9..3b7502e 100644 (file)
@@ -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<recurse_match> 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
index e1d0050..2fc3bc9 100644 (file)
@@ -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;
index 8a85c50..610e0a4 100644 (file)
@@ -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;
index 9135d70..d58f1fd 100644 (file)
@@ -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;
index d6d283d..1ffa932 100644 (file)
@@ -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;
index 2b81250..08652e5 100644 (file)
@@ -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<Catalyst>
-
-=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<Catalyst>
 
 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<Catalyst>
+
+=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
index 18addd4..8d66546 100644 (file)
@@ -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  = "<h1>$name</h1>";
 
         # 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;
     
index ca86d79..fa2e23e 100644 (file)
@@ -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;
index ec85acd..85dee52 100644 (file)
@@ -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',
index 6f66a39..62481ea 100644 (file)
@@ -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<Catalyst>, L<Catalyst::Engine>
index c23390b..c2db065 100644 (file)
@@ -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;
index 0ff3916..6aada3e 100644 (file)
@@ -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<B::Hooks::OP::Check::StashChange> is installed and
+can be used to detect when files are compiled. This is used internally
+to make the L<Moose> metaclass of any class being reloaded immutable.
+
+If L<B::Hooks::OP::Check::StashChange> 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<Catalyst>, L<Catalyst::Engine::HTTP::Restarter>, L<File::Modified>
index 14cf555..41b411a 100644 (file)
@@ -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;
index de89a06..5557066 100644 (file)
@@ -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<Catalyst>.
@@ -232,4 +253,6 @@ it under the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
index 0f1c842..79fa318 100644 (file)
@@ -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
 
index cb1343a..24900cb 100644 (file)
@@ -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<http://www.amazon.com/EC2-AWS-Service-Pricing/b/ref=sc_fe_l_2?ie=UTF8&node=201590011>,
+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 <ami here> -k gsg-keypair
+
+Refer to the Amazon EC2 documentation from the "Amazon Web Services"
+section of the L<Amazon.com| Amazon.com> 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
index 79c1205..ccaf39a 100644 (file)
@@ -306,7 +306,7 @@ Note: Once the C<perl cat-install> is complete, you may want to rerun the
 command to check the status of the packages listed in <cat-install>. Ideally, 
 everything should return a I<name> C<is up to date> message.  If any packages 
 try to re-install, the you could need to manually install the package with the 
-C<force> option.  Also, look for new optional dependences that C<cat-install> 
+C<force> option.  Also, look for new optional dependencies that C<cat-install>
 was not able to automatically handle. You can address these by manually 
 installing the dependency and then re-running C<perl cat-install>.  
 
index e52fe46..05c913f 100644 (file)
@@ -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;
index 7c79f7c..e872e5e 100644 (file)
@@ -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
index 7210360..c859fd2 100644 (file)
 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       = \&parameters;
-*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<http://.../foo/moose/bah>, the string C<bah>
 would be the first and only argument.
 
+Arguments just get passed through and B<don't> 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<http://localhost:3000/some/path> then C<base> is C<http://localhost:3000/>.
 
-=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<application/x-www-form-urlencoded> or C<multipart/form-data>.
 
-=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<HTTP::Headers> 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<query_parameters> and C<body_parameters>.
 
 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<CGI>.
+Alias for path, added for compatibility with L<CGI>.
 
 =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<captures> used to be called snippets. This is still available for backwoards
+C<captures> used to be called snippets. This is still available for backwards
 compatibility, but is considered deprecated.
 
 =head2 $req->upload
@@ -509,15 +536,6 @@ L<Catalyst::Request::Upload> 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;
index 224b29c..ed3b0f5 100644 (file)
@@ -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<IO::File> 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<filename>.
@@ -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;
index 0107be0..3203b2d 100644 (file)
@@ -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<IO::Handle> 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<IO::Handle>.
+
 =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;
index 26861b4..e68266c 100644 (file)
@@ -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; 
 
index b22ad04..0f7dc4a 100644 (file)
@@ -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;
index f3d4de3..2535f76 100644 (file)
@@ -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<HTTP::Request::AsCGI> 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 </get> and </request> functions take either a URI or an L<HTTP::Request>
 object.
@@ -80,39 +157,11 @@ method and the L<request> method below:
 
 =head2 request
 
-Returns a C<HTTP::Response> object.
+Returns a C<HTTP::Response> 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<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
diff --git a/lib/Catalyst/Upgrading.pod b/lib/Catalyst/Upgrading.pod
new file mode 100644 (file)
index 0000000..5918872
--- /dev/null
@@ -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<Catalyst::Component> inherits from C<Moose::Object>, and so C< @ISA > fails
+to linearise.
+
+The fix for this, is to not inherit directly from C<Moose::Object>
+yourself. Having components which do not inherit their constructor from
+C<Catalyst::Component> is B<unsupported>, 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<attributes> 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<Sub::Name> 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<Class::MOP> 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<Class::C3::Adopt::NEXT>, which uses plain C3 method resolution.
+
+As L<NEXTs|NEXT> 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<highly> 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<Moose>. 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<NEVER> 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<highly
+deprecated>.
+
+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
index f3d8c12..4d5f0ed 100644 (file)
@@ -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;
 }
index 6c41dd6..7ff0450 100644 (file)
@@ -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;
index 955f071..61a207b 100644 (file)
@@ -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 (file)
index 412f770..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-include  = CodeLayout::ProhibitHardTabs
-only     = 1
-
-[CodeLayout::ProhibitHardTabs]
-allow_leading_tabs = 0
\ No newline at end of file
index d94c165..5a4a226 100644 (file)
@@ -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 (file)
index 0000000..9b31a52
--- /dev/null
@@ -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;
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -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' );
+        }
+    }
 }
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -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(
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
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 (file)
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -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(
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
@@ -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 ) {
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 our $iters;
 
similarity index 98%
rename from t/live_component_controller_args.t
rename to t/aggregate/live_component_controller_args.t
index 861b4ad..29d26a1 100644 (file)
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
 
 use URI::Escape;
 
similarity index 56%
rename from t/live_component_controller_moose.t
rename to t/aggregate/live_component_controller_moose.t
index 353e515..a9a3ccf 100644 (file)
@@ -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';
 
 {
similarity index 96%
rename from t/live_engine_request_auth.t
rename to t/aggregate/live_engine_request_auth.t
index b15c4d7..f5370ce 100644 (file)
@@ -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';
similarity index 78%
rename from t/live_engine_request_body.t
rename to t/aggregate/live_engine_request_body.t
index 06198f0..c6670da 100644 (file)
@@ -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' );
+}
+
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 (file)
@@ -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';
similarity index 97%
rename from t/live_engine_request_cookies.t
rename to t/aggregate/live_engine_request_cookies.t
index 4247ca4..5a45acc 100644 (file)
@@ -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';
similarity index 98%
rename from t/live_engine_request_headers.t
rename to t/aggregate/live_engine_request_headers.t
index 33c57f9..551561e 100644 (file)
@@ -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';
similarity index 87%
rename from t/live_engine_request_parameters.t
rename to t/aggregate/live_engine_request_parameters.t
index 060bc9e..56a7074 100644 (file)
@@ -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' );
 }
 
 {
similarity index 75%
rename from t/live_engine_request_uploads.t
rename to t/aggregate/live_engine_request_uploads.t
index bab8501..df98f08 100644 (file)
@@ -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' );
     }
 }
 
similarity index 88%
rename from t/live_engine_request_uri.t
rename to t/aggregate/live_engine_request_uri.t
index 39e3345..4f60c49 100644 (file)
@@ -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');
+}
similarity index 98%
rename from t/live_engine_response_cookies.t
rename to t/aggregate/live_engine_response_cookies.t
index cffca3a..5f2f226 100644 (file)
@@ -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';
similarity index 98%
rename from t/live_engine_response_errors.t
rename to t/aggregate/live_engine_response_errors.t
index 1fb8842..b991402 100644 (file)
@@ -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';
similarity index 98%
rename from t/live_engine_response_headers.t
rename to t/aggregate/live_engine_response_headers.t
index 1b374e4..0d373c2 100644 (file)
@@ -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';
similarity index 95%
rename from t/live_engine_response_large.t
rename to t/aggregate/live_engine_response_large.t
index 86665f2..84b796b 100644 (file)
@@ -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 (file)
index 0000000..ad00ea3
--- /dev/null
@@ -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" );
+}
similarity index 98%
rename from t/live_engine_response_redirect.t
rename to t/aggregate/live_engine_response_redirect.t
index 3812120..a01b9d0 100644 (file)
@@ -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';
similarity index 98%
rename from t/live_engine_response_status.t
rename to t/aggregate/live_engine_response_status.t
index 51f6373..a37c9b6 100644 (file)
@@ -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';
similarity index 89%
rename from t/live_engine_setup_basics.t
rename to t/aggregate/live_engine_setup_basics.t
index 7d3d2d3..c2b81ba 100644 (file)
@@ -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';
similarity index 90%
rename from t/live_engine_setup_plugins.t
rename to t/aggregate/live_engine_setup_plugins.t
index d280551..419982b 100644 (file)
@@ -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';
similarity index 94%
rename from t/live_loop.t
rename to t/aggregate/live_loop.t
index 34fea5f..e7b59f9 100644 (file)
@@ -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';
similarity index 91%
rename from t/live_plugin_loaded.t
rename to t/aggregate/live_plugin_loaded.t
index de27574..835f85c 100644 (file)
@@ -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
 ];
 
similarity index 98%
rename from t/live_priorities.t
rename to t/aggregate/live_priorities.t
index e726027..1e05747 100644 (file)
@@ -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';
similarity index 95%
rename from t/live_recursion.t
rename to t/aggregate/live_recursion.t
index 6e55877..a2fcea8 100644 (file)
@@ -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';
similarity index 68%
rename from t/unit_core_action_for.t
rename to t/aggregate/unit_core_action_for.t
index 71772f8..3e75eaa 100644 (file)
@@ -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');
similarity index 78%
rename from t/unit_core_component_layers.t
rename to t/aggregate/unit_core_component_layers.t
index 4261365..c15bc73 100644 (file)
@@ -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');
+