[Catalyst-commits] r8539 - in Catalyst-Runtime/5.70/tags/5.7015: .
lib lib/Catalyst lib/Catalyst/DispatchType
lib/Catalyst/Engine lib/Catalyst/Engine/HTTP
lib/Catalyst/Engine/HTTP/Restarter lib/Catalyst/Manual
lib/Catalyst/Manual/Installation lib/Catalyst/Request script
t t/conf t/lib t/lib/Catalyst t/lib/Catalyst/Action
t/lib/Catalyst/Plugin t/lib/Catalyst/Plugin/Test
t/lib/TestApp t/lib/TestApp/Action t/lib/TestApp/Controller
t/lib/TestApp/Controller/Action t/lib/TestApp/Controller/Action/Auto
t/lib/TestApp/Controller/Action/Chained
t/lib/TestApp/Controller/Action/Chained/Auto
t/lib/TestApp/Controller/Engine
t/lib/TestApp/Controller/Engine/Request
t/lib/TestApp/Controller/Engine/Response
t/lib/TestApp/Controller/Priorities t/lib/TestApp/Model
t/lib/TestApp/Model/Foo t/lib/TestApp/Plugin
t/lib/TestApp/View t/lib/TestApp/View/Dump
t/lib/TestAppChainedAbsolutePathPart
t/lib/TestAppChainedAbsolutePathPart/Controller
t/lib/TestAppChainedRecursive
t/lib/TestAppChainedRecursive/Controller
t/lib/TestAppOnDemand t/lib/TestAppOnDemand/Controller
t/something t/something/script t/something/script/foo
t/something/script/foo/bar
marcus at dev.catalyst.perl.org
marcus at dev.catalyst.perl.org
Wed Oct 15 22:03:21 BST 2008
Author: marcus
Date: 2008-10-15 22:03:20 +0100 (Wed, 15 Oct 2008)
New Revision: 8539
Added:
Catalyst-Runtime/5.70/tags/5.7015/Changes
Catalyst-Runtime/5.70/tags/5.7015/META.yml
Catalyst-Runtime/5.70/tags/5.7015/Makefile.PL
Catalyst-Runtime/5.70/tags/5.7015/lib/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Action.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/ActionChain.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/ActionContainer.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/AttrContainer.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Base.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Build.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Component.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Controller.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Chained.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Default.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Index.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Path.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Regex.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Dispatcher.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/CGI.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/FastCGI.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Exception.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Log.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation.pod
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation/CentOS4.pod
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Model.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request/
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request/Upload.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Response.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Runtime.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Stats.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Test.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Utils.pm
Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/View.pm
Catalyst-Runtime/5.70/tags/5.7015/script/
Catalyst-Runtime/5.70/tags/5.7015/script/catalyst.pl
Catalyst-Runtime/5.70/tags/5.7015/t/
Catalyst-Runtime/5.70/tags/5.7015/t/01use.t
Catalyst-Runtime/5.70/tags/5.7015/t/02pod.t
Catalyst-Runtime/5.70/tags/5.7015/t/03podcoverage.t
Catalyst-Runtime/5.70/tags/5.7015/t/04critic.rc
Catalyst-Runtime/5.70/tags/5.7015/t/04critic.t
Catalyst-Runtime/5.70/tags/5.7015/t/c3_mro.t
Catalyst-Runtime/5.70/tags/5.7015/t/catalyst_130pix.gif
Catalyst-Runtime/5.70/tags/5.7015/t/conf/
Catalyst-Runtime/5.70/tags/5.7015/t/conf/extra.conf.in
Catalyst-Runtime/5.70/tags/5.7015/t/custom_live_component_controller_action_auto_doublebug.t
Catalyst-Runtime/5.70/tags/5.7015/t/custom_live_path_bug.t
Catalyst-Runtime/5.70/tags/5.7015/t/dead_load_multiple_chained_attributes.t
Catalyst-Runtime/5.70/tags/5.7015/t/lib/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/TestAfter.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/TestBefore.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Errors.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Headers.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Plugin.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/PluginTestApp.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/TestBefore.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/TestMyAction.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Action.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Abort.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Deep.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Default.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Begin.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/ArgsOrder.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Bar.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Detach.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Foo.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Forward.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Bar.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Foo.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/ParentChain.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/PassedArgs.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Root.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Default.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Detach.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/End.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Forward.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/ForwardTo.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Global.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Index.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Inheritance.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Local.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Path.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Private.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Regexp.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Streaming.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/TestMultipath.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/TestRelative.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Args.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Dump.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/URI.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/Uploads.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Cookies.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Errors.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Headers.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Large.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Redirect.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Status.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Fork.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Index.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/MultiMethod.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/loc_vs_index.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/locre_vs_index.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/path_vs_index.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/re_vs_index.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Root.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo/Bar.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Plugin/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Plugin/FullyQualified.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Parameters.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Request.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Response.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart/Controller/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart/Controller/Foo.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive/Controller/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive/Controller/Foo.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppDoubleAutoBug.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand/Controller/
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand/Controller/Body.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppPathBug.pm
Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppStats.pm
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_action.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_auto.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_begin.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_chained.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_default.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_detach.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_end.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_forward.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_global.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_index.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_inheritance.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_local.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_multipath.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_path.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_private.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_regexp.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_streaming.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_args.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_auth.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_body.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_body_demand.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_cookies.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_headers.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_parameters.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_uploads.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_uri.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_cookies.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_errors.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_headers.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_large.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_redirect.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_status.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_setup_basics.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_setup_plugins.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_fork.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_loop.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_plugin_loaded.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_priorities.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_recursion.t
Catalyst-Runtime/5.70/tags/5.7015/t/live_stats.t
Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi-rewrite.pl
Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi.pl
Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi-non-root.pl
Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi.pl
Catalyst-Runtime/5.70/tags/5.7015/t/optional_http-server-restart.t
Catalyst-Runtime/5.70/tags/5.7015/t/optional_http-server.t
Catalyst-Runtime/5.70/tags/5.7015/t/optional_lighttpd-fastcgi-non-root.t
Catalyst-Runtime/5.70/tags/5.7015/t/optional_lighttpd-fastcgi.t
Catalyst-Runtime/5.70/tags/5.7015/t/optional_memleak.t
Catalyst-Runtime/5.70/tags/5.7015/t/optional_stress.t
Catalyst-Runtime/5.70/tags/5.7015/t/optional_stress.yml
Catalyst-Runtime/5.70/tags/5.7015/t/optional_threads.t
Catalyst-Runtime/5.70/tags/5.7015/t/something/
Catalyst-Runtime/5.70/tags/5.7015/t/something/Makefile.PL
Catalyst-Runtime/5.70/tags/5.7015/t/something/script/
Catalyst-Runtime/5.70/tags/5.7015/t/something/script/foo/
Catalyst-Runtime/5.70/tags/5.7015/t/something/script/foo/bar/
Catalyst-Runtime/5.70/tags/5.7015/t/something/script/foo/bar/for_dist
Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_config.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_namespace.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_action_for.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component_layers.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component_loading.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_log.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_merge_config_hashes.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_mvc.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_path_to.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_plugin.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for_action.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for_multibytechar.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_load_catalyst_test.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_stats.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_env_value.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_load_class.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_prefix.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_request.t
Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_subdir.t
Log:
Import merge of CPAN distribution of 5.7014 + r8533 to fix LWP failure
Added: Catalyst-Runtime/5.70/tags/5.7015/Changes
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/Changes (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/Changes 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,746 @@
+# This file documents the revision history for Perl extension Catalyst.
+
+5.7015 2008-10-15 22:57:00
+ - Workaround change in LWP that broke a cookie test (RT #40037)
+
+5.7014 2008-05-25 15:26:00
+ - Addition of .conf in restart regex in Catalyst::Engine::HTTP::Restarter::Watcher
+ - Fix regression for relative uri_for arguments after a forward()
+ introduced in 5.7013 (Peter Karman) -
+ - Fix regression for "sub foo : Path {}" in the root controller which
+ was introduced when attempting to allow "0" as a Path.}))
+
+5.7013 2008-05-16 18:20:00
+ - Provide backwards compatability methods in Catalyst::Stats
+ - Fix subdirs for scripts that run in subdirs more than one level deep.
+ - Added test and updated docs for handling the Authorization header
+ under mod_fastcgi/mod_cgi.
+ - Fixed bug in HTTP engine where the connection was not closed properly if the
+ client disconnected before sending any headers. (Ton Voon)
+ - POD fix, IO::FileHandle => IO::Handle (RT #35690)
+ - Fix grammar on welcome page (RT #33236)
+ - Fix for Path('0') handling (RT #29334)
+ - Workaround for Win32 and c3_mro.t (RT #26452, tested by Kenichi Ishigaki)
+ - Fix for encoding query parameters (edenc)
+ - Fix Chained multiple test (t0m)
+
+5.7012 2007-12-16 23:44:00
+ - Fix uri_for()'s and uri_with()'s handling of multibyte chars
+ (Daisuke Murase)
+ - Fix __PACKAGE__->config->{foo} = 'bar' case with subclassing
+ - Add Catalyst::Stats (Jon Schutz)
+ - Fixed a bug where ?q=bar=baz is decoded as q=>'bar', not 'bar=baz'.
+ (Tatsuhiko Miyagawa, Masahiro Nagano)
+ - Fixed a bug where -rr (restart regex) command line option could cause
+ shell errors. (Aristotle Pagaltzis, Chisel Wright)
+
+5.7011 2007-10-18 20:40:00
+ - Allow multiple restart directories and added option to follow
+ symlinks in the HTTP::Restarter engine (Sebastian Willert)
+ - Fixed t/optional_http-server-restart.t so it actually tests
+ if the server restarted or notified of an error (Sebastian Willert)
+ - Return child PID from the HTTP engine when run with the 'background' option.
+ (Emanuele Zeppieri)
+ - Fixed bug in HTTP engine where writes could fail with
+ 'Resource temporarily unavailable'.
+ - Fixed bug where %2b in query parameter is doubly decoded to ' ', instead of '+'
+ (RT #30087, Gavin Henry, Tatsuhiko Miyagawa, Oleg Pronin)
+ - Fixed bug where req->base and req->uri would include a port number when running
+ in SSL mode.
+ - Removed unnecessary sprintf in debug mode that caused warnings on locales where
+ commas are used for decimal markers.
+ - Improved error message for case when server picks up editor save
+ files as module names. (James Mastros)
+
+5.7010 2007-08-22 07:41:00
+ - Resource forks in 5.7009
+
+5.7009 2007-08-22 00:14:00
+ - Moved Manual.pod to Manual.pm and clarified status of
+ Catalyst-Manual dist
+ - Doc patches to Catalyst::Controller
+ - remove ignore_loaded from plugin load, commenting why
+ - document the ignore_loaded feature in Catalyst::Utils
+ - Add testing of inline plugins.
+
+5.7008 2007-08-13 08:40:00
+ - Added $c->request->query_keywords for getting the keywords
+ (a query string with no parameters).
+ - Add undef warning for uri_for.
+ - Fix bug where a nested component would be setup twice.
+ - Make ensure_class_loaded behave better with malformed class name.
+ - Make _register_plugin use ensure_class_loaded.
+ - Remove 'Argument "??" isn't numeric in sprintf' warning.
+ (Emanuele Zeppieri)
+ - Fixed a bug where Content-Length could be set to 0 if a filehandle
+ object in $c->response->body did not report a size.
+ - Fixed issue where development server running in fork mode did not
+ properly exit after a write error.
+ (http://rt.cpan.org/Ticket/Display.html?id=27135)
+ - Remove warning for captures that are undef.
+ - Fixed $c->read and parse_on_demand mode.
+ - Fixed a bug with the HTTP engine where very large response bodies
+ would not be sent properly.
+
+5.7007 2007-03-13 14:18:00
+ - Many performance improvements by not using URI.pm:
+ * $c->uri_for (approx. 8x faster)
+ * $c->engine->prepare_path (approx. 27x faster)
+ * $c->engine->prepare_query_parameters (approx. 5x faster)
+ - Updated HTTP::Body dependency to 0.9 which fixes the following issues:
+ * Handle when IE sometimes sends an extra CRLF after the POST body.
+ * Empty fields in multipart/form-data POSTs are no longer ignored.
+ * Uploaded files with the name "0" are no longer ignored.
+ - Sending SIGHUP to the dev server will now cause it to restart.
+ - Allow "0" for a path in uri_for.
+ - Performance and stability improvements to the built-in HTTP server.
+ - Don't ignore file uploads if form contains a text field with the same name.
+ (Carl Franks)
+ - Support restart_delay of 0 (for use in the POE engine).
+ - Skip body processing if we don't have a Content-Length header.
+ Results in about a 9% performance increase when handling GET/HEAD
+ requests.
+ - Add a default body to redirect responses.
+ - MyApp->model/view now looks at MyApp->config->{default_view/model}
+ (Bogdan Lucaciu)
+
+5.7006 2006-11-15 14.18
+ - Updated manifest
+ - Fix Slurp dependency
+ - Updated HTTP::Body dependency to 0.6, 0.5 can break on large POST
+ requests.
+ - Skip utf8 fix for undef values in uri_with() and uri_for()
+
+5.7005 2006-11-07 19:37:35
+ - Fixed lighttpd tests to be properly skipped.
+ - Moved IE workarounds to exist only in the HTTP engine.
+ - Added installation instructions (from Catalyst-Manual dist)
+
+5.7004 2006-11-06 20:48:35
+ - Fix Engine::HTTP crash when using IE. (Jesper Krogh, Peter Edwards)
+ - clean up Catalyst::Utils to handle some edge cases
+ - Properly work around lighttpd PATH_INFO vs. SCRIPT_NAME bug
+ (Mark Blythe)
+ - add _application accessor to Catalyst::Base
+ - Support current_view
+ - Allow use of Catalyst::Test without app name (Ton Voon, Altinity)
+ - Catalyst::Manual moved to its own package
+ - Add option to FastCGI engine to send errors to stdout, not the web server
+ - Use Module::Install's auto_install to install prerequisite modules
+ - various documentation fixes and improvements
+
+5.7003 2006-09-21 16:29:45
+ - Additions and updates to tutorial
+
+5.7002 2006-09-17 19:35:32
+ - unescape captures to match args
+ - fix for relative Chained under namespace '' (root)
+ - fix for hashrefs in action attributes from config
+ - fix for Chained to require correct number of CaptureArgs
+
+5.7001 2006-07-19 23:46:54
+ - fix for component loading
+ - uri_for and uri_with now behave as they used to with non-
+ array references
+
+5.7000 2006-07-07 08:08:08
+ - fix FCGI.pm warning message with FastCGI engine
+ - bumped inc::Module::Install to 0.63 in Makefile.PL
+ - fixes to uri_for_action for DispatchType::Chained
+ - Further doc work.
+ - Minor code cleanups
+ - Changed catalyst.pl to depend on Catalyst::Devel
+
+5.70_03 2006-06-28 16:42:00
+ - fixup to registered plugins debug at app startup
+ - refactored Catalyst::Utils::home
+
+5.70_02 2006-06-27 11:51:00
+ - Updated tutorial.
+
+5.70_01 2006-06-26 10:49:00
+
+ - fixed a Catalyst::Base bug causing duplicate action registrations
+ - modified DispatchTypes to support multiple registrations
+ - added Catalyst::Runtime module as dist marker
+ - added Catalyst::ActionChain and Chained DispatchType
+ - removed retarded registration requirement in dispatcher
+ - removed Module::Pluggable::Fast hack in favor of
+ Module::Pluggable::Object
+ - extended uri_for, added dispatcher->uri_for_action
+ - added Catalyst::Base->action_for('methodname')
+ - checked and tested :Args multimethod dispatch
+ - added ability to set action attributes from controller config
+ - added merge_config_hashes() as a convenience method
+ - Swapped out CGI::Cookie in favour of CGI::Simple::Cookie
+ - Removed test dependencies on Test::NoWarnings, Test::MockObject
+ - Removed dependency on UNIVERSAL::require
+ - Split out Catalyst::Helper into a new distribution
+ - un-bundled the plugins as they are now pre-reqs for Catalyst::Helper
+ - nuked each() out of core with prejudice (due to lurking buglets)
+ - Added tests from phaylon for dispatcher precedence
+ - Use Class::Inspector->loaded($class) instead of $class->can('can')
+ - Added ActionClass attribute
+ - Removed Test::WWW::Mechanize::Catalyst from Makefile.PL (circular dep)
+ - Updated docs for Catalyst::Component
+ - Separated execute and dispatch on Catalyst::Action
+ - cleaned up logging and debug output
+ - significant documentation revisions
+ - Added warning for setup being called twice
+ - Fix pod to use DBIC::Schema instead of DBIC model
+ - Fix ->config failing to copy _config for subclassing
+ - Updated log format
+ - Updated debug dump
+
+5.6902 2006-05-04 13:00:00
+ - Remove tarballs and OSX metadata files.
+
+5.6901 2006-05-03 11.17:00
+ - Module::Install didn't overwrite META.yml.
+
+5.6900 2006-05-03 11.17:00
+ - Stupid pause indexer can't count.
+ - Better fix for Catalyst::Test
+ - more tests.
+
+5.682 2006-04-27 13:51:00
+ - Damn OSX attributes again :(
+
+5.681 2006-04-27 08:47:00
+ - Updated manifest.
+ - Add basename to core . (Deprecates Catalyst::Plugin::Basename)
+
+5.68 2006-04-26 12:23:00
+ - ConfigLoader: Updated to version 0.06
+ - fixed undef warnings in uri_for() and uri_with()
+ - Fixed Catalyst::Test to report errors on failed Class load
+
+5.678 2006-04-24 12:30:00
+ - Re-release of 5.67 without OSX metadata files.
+
+5.67 2006-04-23 08:50:00
+ - Added $c->req->uri_with() helper
+ - ConfigLoader: Updated to version 0.05
+ - Fix up Engine to avoid a new 5.8.8 warning
+ - Added app name with :: support for PAR
+ - Added $c->models/views/controllers
+ - Static::Simple: Unescape the URI path before looking for the file.
+ This fixes issues with files that have spaces.
+ - Looping and recursion tests plus a fix
+ - Added lots of API documentation. Refactored main pod.
+ - Changed default behaviors for $c->model/$c->controller/$c->view
+ to more sane settings.
+ - added the clear_errors method - an alias for error(0)
+ - Added tmpdir option for uploads (woremacx)
+ - Applied patch from GEOFFR to allow normal filehandles.
+ - Refactored Dispatcher internals for better readability and speedup
+ (stress tests run 12% faster)
+ - Allow $c->error to run as a class method
+
+5.66 2006-03-10 17:48:00
+ - Added Test::WWW::Mechanize::Catalyst support
+ - Cleaned generated tests
+ - Added Root controller concept
+ - Updated ConfigLoader plugin to version 0.04
+
+5.65 2006-02-21 10:34:00
+ - Added plugin introspection.
+ - Support optional hashref as last param for parameters in uri_for.
+ - Updated tutorial to be more complete.
+ - Applied args patch from antirice (Fixes Ticket #67)
+
+5.64 2006-02-07 20:29:00
+ - Fixed bug in FastCGI proc manager mode where pm_post_dispatch
+ was not run. (Eric Wong)
+ - Cleaned up generated tests
+ - Updated YAML support to use ConfigLoader
+ - Fixed path dispatch to canonicalise correctly
+ (see http://dev.catalyst.perl.org/ticket/62)
+ - Added Catalyst::Manual::About
+
+5.63 2006-01-22 00:00:00
+ - Updated prereq versions
+
+5.62 2006-01-17 16:30:00
+ - Large update to the tutorial (castaway)
+ - Added YAML config support
+ - Added COMPONENT() and ACCEPT_CONTEXT() support
+ - Action list in debug mode is now displayed as a tree in the
+ correct execution order.
+ - Fixed engine detection to allow custom mod_perl engines.
+ - Static::Simple: Fixed bug in ignore_dirs under win32.
+ - Display version numbers of loaded plugins. (Curtis Poe)
+ - Added class and method for caught exception messages.
+ - Updated PAR support to use "make catalyst_par",
+ packages are no longer written by Makefile.PL.
+ - Automatically determine Content-Length when serving a
+ filehandle.
+ - Exceptions now return status 500.
+ - Updated for Module::Install 0.44.
+ - Fixed additional file installation for multi level app names.
+ - Added REDIRECT_URL support for applications running behind
+ a RewriteRule in Apache. (Carl Franks)
+ - Fixed FastCGI engine under win32. (Carl Franks)
+ - FastCGI doc updates (Bill Moseley)
+ - Bugfix for $c->model and friends (defined).
+
+5.61 2005-12-02 00:00:00
+ - Fixed ExtUtils::AutoInstall Bootstrap Code in Makefile.PL
+
+5.60 2005-12-01 22:15:00
+ - Fixed Path and index actions in the appclass,
+ including those that attach to /
+ - Index is now weighted higher than Path
+ - Fixed restarter and -d debug switch in server.pl.
+ - Added a warning if you attempt to retrieve a parameter
+ using $c->req->params('foo').
+ - Fixed the Module::Install::Catalyst @ISA bug
+
+5.59 2005-11-30 13:25:00
+ - Fixed shebang line for generated scripts
+ - Fixed forward to classes ($c->forward(qw/MyApp foo/))
+ - Wrap use block in begin to quelch C:C3 warnings
+ - Removed scrollbar from debug output
+ - Fixed catalyst_par_core() and catalyst_par_multiarch()
+
+5.58 2005-11-24 10:51:00
+ - Added ExtUtils::AutoInstall support
+ - Allow overriding path in Catalyst::Helper.
+ - Added -makefile to catalyst.pl to generate a new Makefile.PL.
+ - Restored Catalyst::Build with a deprecation notice.
+ - Improved PAR support
+ - Replaced -short with auto-detection
+ - Fixed prereqs, added File::Copy::Recursive
+ - Static::Simple changes:
+ - Made prepare_action play nice with other plugins by not short-
+ circuiting.
+ - Added tmpl to the ignored extensions.
+ - Fixed security problem if req->path contained '..'.
+
+5.57 2005-11-20 22:45:00
+ - Updated uri_for to accept undef actions
+ - Switched to Module::Install
+ - Renamed tests for easier editing
+ - Reformatted documentation
+ - Renamed -nonew to -force
+ - Added PAR support
+ - Added keep-alive support and bug fixes to HTTP engine.
+ (Sascha Kiefer)
+ - Added daemonize option to FastCGI engine. (Sam Vilain)
+
+5.56 2005-11-16 10:33:00
+ - Fixed FastCGI engine to not clobber the global %ENV on each
+ request. (Sam Vilain)
+ - Updated benchmarking to work with detach
+ - Fixed dispatcher, so $c->req->action(undef) works again
+ - Updated Catalyst::Test to use HTTP::Request::AsCGI
+ - Added -pidfile to external FastCGI server.
+
+5.55 2005-11-15 12:55:00
+ - Fixed multiple cookie handling
+
+5.54 2005-11-14 22:55:00
+ - Fixed a Module::Pluggable::Fast related bug
+
+5.53 2005-11-14 15:55:00
+ - Removed t/04prereq.t that was testing for non-required
+ modules.
+
+5.52 2005-11-14 10:57:00
+ - Strip '..'s in static urls to fix security issue.
+
+5.51 2005-11-14 00:45:00
+ - Changed uri_for to use namespace instead of match.
+
+5.50 2005-11-13 20:45:00
+ - Fixed minor bugs.
+ - Updated docs.
+
+5.49_05 2005-11-12 20:45:00
+ - Large update to the documentation. (David Kamholz)
+ - Fixed args handling in forward()
+ - Fixed forwarding to classes
+ - Fixed catalyst.pl-generated Build.PL Makefile section.
+ - Fixed relative forwarding
+ - Fixed forward arrows in debug output
+
+5.49_04 2005-11-09 23:00:00
+ - Made context, dispatcher, engine, request and response classes
+ configurable.
+ - Added $c->stack.
+ - Fixed dispatcher to ignore unknown attributes.
+ - Improved format of startup debug log.
+ - Updated built in server to restart on win32. (Will Hawes)
+ - Fixed streaming write from a filehandle to stop writing
+ if the browser is closed.
+ - Added $c->controller, $c->model and $c->view shortcuts.
+ - Switched to Text::SimpleTable.
+
+5.49_03 2005-11-03 12:00:00
+ - Fixed $c->req->{path} for backwards-compatibility.
+ - Allow debug to be disabled via ENV as well as enabled.
+ - Added -scripts option to catalyst.pl for script updating
+ - Changed helpers to default to long types, Controller instead of C
+ - Added Catalyst::Controller, Catalyst::Model and Catalyst::View
+ base classes
+ - Added JavaScript to debug screen to show and hide specific dumps
+ - Added _DISPATCH, _BEGIN, _AUTO, _ACTION and _END actions
+ - Added multi process external FastCGI support
+ (see myapp_fastcgi.pl -help) (Sam Vilain)
+ - Restarter process in HTTP engine now properly exits when the
+ parent app is shut down.
+ - Improved performance of restarter loop while watching for
+ changed files.
+ - Restarter will now detect new files added to an app on systems
+ that change directory mtimes when new files are created.
+ - Restarter now properly handles modules that are deleted from an
+ application.
+ - Fixed memory leak in TestApp.
+
+5.49_02 2005-10-26 12:39:00
+ - Whole new dispatcher!
+ - Added index action
+ - Added path_to method
+ - Added support for passing an IO::Handle object to $c->res->body.
+ (Andrew Bramble)
+ - Added a new welcome screen.
+ - Included Catalyst buttons and icons in helper.
+ - Added Static::Simple plugin to core.
+ - Added self restarting test server
+ - Added filename to debug output for uploaded files.
+ - Fixed forwarding with embedded arguments.
+ - Fixed handling of escaped query strings.
+ - Added upload parameters back into $c->req->params.
+ - Added multiple paths support to dispatcher
+ - Fixed bug in req->path where changing the path added a trailing
+ slash.
+ - Removed req->handle and res->handle
+ - Added prepare_body_chunk method as a hook for upload progress.
+ - Fixed bug in uri_for method when base has no path.
+ - Added automated tests for HTTP, CGI, and FastCGI servers.
+
+5.49_01 2005-10-10 10:15:00
+ - Refactored all internals, should be 99% compatible to previous
+ versions.
+ - *IMPORTANT* The Apache engines have been moved to a separate package
+ for this release. Please install Catalyst::Engine::Apache if you
+ need Apache support.
+
+ - Added support for calling forward with arguments in the path, i.e.
+ $c->forward('/foo/bar/arg1/arg2')
+ - Made $c->req->uri a URI object, added req->path_info for CGI compat.
+ Raw query string is available as $c->req->uri->query.
+ - Made $c->req->base a URI object.
+ - Parameters with multiple values (?a=1&a=2) now display properly
+ in the debug output.
+ - Semi-colon separators in query strings now work properly.
+ - Expanded documentation of catalyst.pl (Andrew Ford)
+ - Added support for running as a backend server behind a frontend
+ proxy so req->base and req->address are set properly.
+ - Added an 'abort' method to the Log api, so that you can
+ kill loggging for a whole request.
+ - Added $c->uri_for method to simplify url handling.
+ - Added more tests and reorganized the t directory.
+ - Reimplemented core engines, all are now CGI based for better test
+ coverage and maintainability.
+ - Added fork support to built in test server.
+ - Fixed all memory leaks.
+ - Thread-related bug fixes and tests. We now believe the Catalyst
+ core to be thread-safe.
+ - Added streaming IO support through $c->req->read() and
+ $c->res->write()
+ - Added MyApp->config->{parse_on_demand} (streaming input)
+ - Added $c->req->handle and $c->res->handle
+ - Improved documentation
+ - Fixed mkpath in Catalyst::Helper (Autrijus Tang)
+ - Fixed bug in dispatcher where an invalid path could call a valid
+ action. (Andy Grundman)
+ - Fixed Helper so it works with CRLF line-endings. (Andy Grundman)
+
+5.33 2005-08-10 15:25:00
+ - Now with updated manifest.
+
+5.32 2005-08-10 15:10:00
+ - Dispatcher might fail if object returns false. (Florian Ragwitz)
+
+5.31 2005-06-04 12:35:00 (never released to CPAN)
+
+ - helpers now create .new files where files already exist and differ
+ - fixed $Data::Dumper::Terse (Robin Berjon)
+ - added arguments for detach
+ - new credits section in pod
+ - fixed detach to allow relative action names (Matt and Robert)
+ - added the ability to have whitespaces in Path( '' ) and Regex( '' )
+
+5.30 2005-06-04 12:35:00
+
+ - Fixed a bug where it was not possible to $c->forward to a
+ component
+ that was not inheriting from Catalyst::Base.
+ - Fix for inheritance bug.
+ - Allow forward with arguments.
+ - Updated cookbook
+ - Allow overriding home/root in config.
+ - make module build cons README automatically.
+ - prettify home path by resolving '..' (Andy Grundman)
+ - improved helper templates a bit, new naming scheme for tests.
+ - added support for case sensitivity, MyApp->config->{case_sensitive}
+ - added $c->detach for non-returning forwards
+ - added unified error handling, Catalyst::Exception
+ - added section on param handling in Intro.pod
+ - added $c->request->cookie
+ - added Catalyst::Setup
+ - refactored Catalyst::import()
+ - improved rendering of error messages in debug mode
+ - fixed a bug in Catalyst::Helper::mk_dir
+ - further doc changes, esp. to Intro.pod
+
+5.23 2005-06-03 02:30:00
+ - added support for non Catalyst::Base components to live in namespace
+ - improved concurrency connections in Catalyst::Engine::HTTP::Daemon
+
+5.22 2005-05-26 14:24:00
+ - improved base locating in MP engines
+ - improved error messages in C::E::HTTP::Daemon
+ - hostnames are now resolved on demand unless provided by engine
+ - fixed memory leak in $c->execute (Michael Reece, Matt S Trout)
+
+5.21 2005-05-24 14:56:00
+ - fixed a bug in https detection
+ - fixed auto chain finally
+ - added MYAPP_HOME and CATALYST_HOME environment variables
+
+5.20 2005-05-18 19:52:00
+ - improved uploads and parameters
+ - added $c->req->protocol and $c->req->secure
+ - added $c->req->user and $c->req->uri
+ - improved error message when forwarding to unknown module
+ - fixed win32 installer
+ - added deep recursion detection
+ - fixed auto actions
+ - fixed inheritance in dispatcher
+ - allow whitespaces between brackets and quoted string
+ in Path and Regex attributes
+ - new helper templates
+ - installer now supports install_base and destdir
+ - allow multiple Catalyst apps to run on the same mod_perl
+ instance (not the same app!)
+ - fixed MP2 engines
+ - removed apreq dependency from all MP engines
+ - added support for MP registry scripts
+ - added support for LocationMatch and ScriptAliasMatch in MP engines
+ - added SpeedyCGI engine
+
+5.10 2005-04-23 11:16:00
+ - updated dependencies to require latest module::pluggable::fast
+ - new installer for templates and stuff using Module::Build
+ - scripts are now prefixed, for being installable
+ IMPORTANT: You have to regenerate the script directory,
+ remove Makefile.PL and add Build.PL
+ - Added compat to install Module::Build if required.
+ - Improved: Params handling with MP engines
+ - Fixed: Params handling on POST with CGI engine (Andy Grundman)
+ - Fixed: Helper.pm on Win32 (Matt S Trout)
+
+5.03 2005-04-19 20:35:00 (Revision 462)
+ - fixed Test example (Torsten Seeman)
+ - added Plugins chapter to manual
+ - applied doc patch from Robert Boone <robert at rlb3.com>
+ - improved Dispatcher error messages.
+ - refactored so we don't need to include helper from
+ Catalyst.pm - Fixes issues with FindBin
+ - applied HTTP.pm patch from Andy Grundman <andy at hybridized.org>
+ - added plugin() method for instant plugins
+ - FCGI is no more considered experimental
+
+5.02 2005-04-18 10:00:00
+ - fixed manifest
+
+5.01 2005-04-17 23:00:00
+ - some documentation bugs fixed
+ - added Catalyst::Utils
+ - fixed regexp bug (Matt S Trout)
+ - fixed upload bug with MP19
+ - added $c->req->body
+ - aliased $c->res->output to $c->res->body
+ - Read AUTHOR from passwd or $ENV{AUTHOR} when
+ generating code.
+ - extended attribute handling
+ - added global config for components
+
+5.00 2005-04-15 18:00:00
+ - new core to support inheritance trees
+ - new syntax for action declaration
+ - new helper system using TT2
+ - problems with mod_perl2 fixed
+ - added Test::Pod support
+ - added new server backend with HTTP/1.1 support
+ - added option to run tests against a remote server
+ - renamed errors() to error()
+ - more better docs
+ - countless minor improvements
+ IMPORTANT: This release is very incompatible to previous ones
+ and you have to regenerate the helper scripts again...
+
+4.34 2005-03-23 07:00:00 2005
+ - added some messages to Makefile.PL
+ - added Catalyst::Engine::Test
+ - added Catalyst::Engine::CGI::NPH
+ - simplified Catalyst::Log to be easier to implement/subclass
+ - added cgi.pl
+ - updated Catalyst::Test to use Catalyst::Engine::Test
+ - updated helper scripts
+ IMPORTANT: this will be the last time you'll have to regenerate
+ the script directory. We promise!
+
+4.33 2005-03-23 01:00:00 2005
+ - documented the log() accessor method in Catalyst (Andrew Ford)
+ - added optional arguments to Catalyst::Log methods (Andrew Ford)
+ - removed cgi-server.pl
+ - added fcgi.pl and Catalyst::Engine::FCGI
+ - fixed an undef durng make test (Dan Sully)
+ - new path test (Christian Hansen)
+ IMPORTANT: you have to regenerate the script directory again
+
+4.32 2005-03-22 02:10:00 2005
+ - made a damn typo *AAAAAAAAAAAAAAHHHH!!!*
+
+4.31 2005-03-22 02:00:00
+ - fixed inheritance (Christian Hansen)
+ - previous release was borked!
+ fixed that, but you have to regenerate the scripts again :(
+
+4.30 2005-03-21 23:00:00
+ - more documentation (Andrew Ford)
+ - added connection informations (Christian Hansen)
+ - HTTP::Request support in Catalyst::Test (Christian Hansen)
+ - moved cgi.pl to nph-cgi.pl
+ - added Catalyst::Engine::Server (Christian Hansen)
+ - removed Catalyst::Test::server
+ - updated helper scripts
+ IMPORTANT: note that you have to regenerate script/server.pl,
+ script/cgi-server.pl and script/cgi.pl (now nph-cgi.pl)
+
+4.28 2005-03-19 22:00:00
+ - fixed isa tree (Christian Hansen)
+ - added script/cgi-server.pl, so no more server restarting after
+ code changes
+ - reworked documentation (Andrew Ford <A.Ford at ford-mason.co.uk>)
+
+4.27 2005-03-19 01:00:00
+ - debug message for parameters
+ - Fix redirects (Christian Hansen <ch at ngmedia.com>)
+ - some random fixes
+ - new helper api for Catalyst::Helper::* support
+ you have to update script/create.pl to use it
+
+4.26 2005-03-16 10:00:00
+ - fixed the weird bug that caused regex actions to fail on every
+ second request
+ - more debug messages
+ - 100% pod coverage.
+
+4.25 2005-03-12 18:00:00
+ - correct perl pathes for helper generated scripts (Tatsuhiko Miyagawa)
+ - improved cgi engine docs (Christoper Hicks)
+
+4.24 2005-03-12 01:00:00
+ - updated cookbook example
+ - fixed base for apache and https (Andrew Ruthven)
+
+4.23 2005-03-09 20:00:00
+ - no more regex actions in forward
+ - added support for test directories t/m, t/v and t/c
+
+4.22 2005-03-08 20:00:00
+ - catch errors in application class
+ - handle die properly.
+
+4.21 2005-03-05 17:00:00
+ - fixed docs
+
+4.20 2005-03-04 22:00:00
+ - moved bin to script
+
+4.13 2005-03-03 11:00:00
+ - improved documentation
+ - pod coverage test for helper generated apps
+ - new helper api
+
+4.12 2005-03-02 11:00:00 2005
+ - server_base sucks, removed
+ - added $c->log->dump()
+
+4.11 2005-03-02 11:00:00 2005
+ - removed some warnings
+ - improved docs
+ - private prefixed actions override private non prefixed actions
+ - added server_base
+ - updated Catalyst::Manual::Intro
+
+4.10 2005-03-02 10:00:00 2005
+ - improved documentation
+ - fixed upload bug
+ - fixed prefixed private actions bug
+ - fixed more little bugs
+
+4.01 2005-03-01 10:00:00 2005
+ - improved documentation
+ - documentation fixes (Johan Lindstrom)
+
+4.00 2005-02-27 22:00:00
+ - more verbose debug messages, especially for forward()
+ - implemented prefixed prvate actions, icluding built in
+ !?default, !?begin and !?end
+ - new Catalyst::Manual::Intro
+ - new helpers, bin/catalyst
+ - helper api
+
+3.11 2005-02-23 21:00:00
+ - added dependency to UNIVERSAL::require (Marcus Ramberg)
+ - added a little workaround for a warning in Catalyst::Test
+ (Marcus Ramberg)
+ - improved documentation for actions
+
+3.10 2005-02-19 20:00:00
+ - removed roles management from Catalyst::Engine
+ and added it to Catalyst::Plugin::Authentication::CDBI
+
+3.04 2005-02-17 21:00:00
+ - error reporting for app class
+ - no more engine debug messages
+ - class->method forwards get resolved now
+
+3.03 2005-02-16 23:00:00
+ - friendlier statistics
+
+3.02 2005-02-16 22:00:00
+ - fixed unintialized actions (Marcus Ramberg)
+
+3.01 2005-02-16 20:30:00
+ - better statistics
+
+3.00 2005-02-16 20:00:00
+ - real version number for CPAN.pm
+ - fixed redirect in CGI engine
+ - more statistics in debug logs
+ - ? prefix for forward()
+
+2.99_15 2005-02-02 22:00:00
+ - support for short namespaces, MyApp::M, MyApp::V and MyApp::C
+ - Replaced "Catched" with "Caught" in Catalyst::Engine
+ (Gary Ashton Jones)
+ - replaced _ with ! for private actions
+ - added ? for prefixed actions
+ - misc improvememts
+
+2.99_14 2005-01-31 22:00:00 2005
+ - arguments for _default
+ - $c->entrance removed for more flexibility
+ - added $c->req->method
+
+2.99_13 2005-01-30 18:00:00 2005
+ - POD fixes and improvements
+
+2.99_12 2005-01-28 22:00:00 2005
+ - first development release
Added: Catalyst-Runtime/5.70/tags/5.7015/META.yml
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/META.yml (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/META.yml 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,45 @@
+---
+abstract: Catalyst Runtime version
+author: The Catalyst Core Team - see http://catalyst.perl.org/
+build_requires:
+ Test::Perl::Critic: 0
+ Test::Pod: 1.14
+ Test::Pod::Coverage: 1.04
+distribution_type: module
+generated_by: Module::Install version 0.67
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
+name: Catalyst-Runtime
+no_index:
+ directory:
+ - inc
+ - t
+requires:
+ CGI::Simple::Cookie: 0
+ Carp: 0
+ Class::Accessor::Fast: 0
+ Class::Data::Inheritable: 0
+ Class::Inspector: 1.06
+ Data::Dump: 0
+ File::Modified: 0
+ HTML::Entities: 0
+ HTTP::Body: 0.9
+ HTTP::Headers: 1.64
+ HTTP::Request: 0
+ HTTP::Request::AsCGI: 0.5
+ HTTP::Response: 0
+ LWP::UserAgent: 0
+ Module::Pluggable: 3.01
+ NEXT: 0
+ Path::Class: 0.09
+ Scalar::Util: 0
+ Text::Balanced: 0
+ Text::SimpleTable: 0.03
+ Time::HiRes: 0
+ Tree::Simple: 1.15
+ Tree::Simple::Visitor::FindByPath: 0
+ URI: 1.35
+ perl: 5.8.1
+version: 5.7013
Added: Catalyst-Runtime/5.70/tags/5.7015/Makefile.PL
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/Makefile.PL (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/Makefile.PL 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,73 @@
+use inc::Module::Install 0.64;
+
+perl_version '5.008001';
+
+name 'Catalyst-Runtime';
+all_from 'lib/Catalyst/Runtime.pm';
+
+requires 'Carp';
+requires 'Class::Accessor::Fast';
+requires 'Class::Data::Inheritable';
+requires 'Class::Inspector' => '1.06';
+requires 'CGI::Simple::Cookie';
+requires 'Data::Dump';
+requires 'File::Modified';
+requires 'HTML::Entities';
+requires 'HTTP::Body' => '0.9';
+requires 'HTTP::Headers' => '1.64';
+requires 'HTTP::Request';
+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 '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
+
+
+if (-e 'inc/.author') {
+ build_requires 'Test::Perl::Critic';
+ build_requires 'Test::Pod' => 1.14;
+ build_requires 'Test::Pod::Coverage' => 1.04;
+
+ 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';
+
+ 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');
+auto_install;
+WriteAll;
+
+print <<"EOF";
+
+ Important:
+
+ This library is for running Catalyst applications.
+
+ For development and use of catalyst.pl and myapp_create.pl, make sure
+ you also install the development tools package Catalyst::Devel.
+
+ perl -MCPANPLUS -e 'install Catalyst::Devel' # or
+ perl -MCPAN -e 'install Catalyst::Devel'
+
+ To get some commonly used plugins, as well as the TT view and DBIC
+ model, install Task::Catalyst in the same way.
+
+ Have fun!
+EOF
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Action.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Action.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Action.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,111 @@
+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)%]">
+
+=head1 DESCRIPTION
+
+This class represents a Catalyst Action. You can access the object for the
+currently dispatched action via $c->action. See the L<Catalyst::Dispatcher>
+for more information on how actions are dispatched. Actions are defined in
+L<Catalyst::Controller> subclasses.
+
+=cut
+
+__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/);
+
+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 { # Execute ourselves against a context
+ my ( $self, $c ) = @_;
+ return $c->execute( $self->class, $self );
+}
+
+sub execute {
+ my $self = shift;
+ $self->{code}->(@_);
+}
+
+sub match {
+ my ( $self, $c ) = @_;
+ 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;
+}
+
+1;
+
+__END__
+
+=head1 METHODS
+
+=head2 attributes
+
+The sub attributes that are set for this action, like Local, Path, Private
+and so on. This determines how the action is dispatched to.
+
+=head2 class
+
+Returns the class name where this action is defined.
+
+=head2 code
+
+Returns a code reference to this action.
+
+=head2 dispatch( $c )
+
+Dispatch this action against a context
+
+=head2 execute( $controller, $c, @args )
+
+Execute this action's coderef against a given controller with a given
+context and arguments
+
+=head2 match( $c )
+
+Check Args attribute, and makes sure number of args matches the setting.
+Always returns true if Args is omitted.
+
+=head2 namespace
+
+Returns the private namespace this action lives in.
+
+=head2 reverse
+
+Returns the private path for this action.
+
+=head2 name
+
+returns the sub name of this action.
+
+=head1 AUTHOR
+
+Matt S. Trout
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/ActionChain.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/ActionChain.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/ActionChain.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,93 @@
+package Catalyst::ActionChain;
+
+use strict;
+use base qw/Catalyst::Action/;
+
+
+=head1 NAME
+
+Catalyst::ActionChain - Chain of Catalyst Actions
+
+=head1 SYNOPSIS
+
+See L<Catalyst::Manual::Intro> for more info about Chained actions.
+
+=head1 DESCRIPTION
+
+This class represents a chain of Catalyst Actions. It behaves exactly like
+the action at the *end* of the chain except on dispatch it will execute all
+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||[]};
+ my @chain = @{ $self->chain };
+ my $last = pop(@chain);
+ foreach my $action ( @chain ) {
+ my @args;
+ if (my $cap = $action->attributes->{CaptureArgs}) {
+ @args = splice(@captures, 0, $cap->[0]);
+ }
+ local $c->request->{arguments} = \@args;
+ $action->dispatch( $c );
+ }
+ $last->dispatch( $c );
+}
+
+sub from_chain {
+ my ( $self, $actions ) = @_;
+ my $final = $actions->[-1];
+ return $self->new({ %$final, chain => $actions });
+}
+
+1;
+
+__END__
+
+=head1 METHODS
+
+=head2 chain
+
+Accessor for the action chain; will be an arrayref of the Catalyst::Action
+objects encapsulated by this chain.
+
+=head2 dispatch( $c )
+
+Dispatch this action chain against a context; will dispatch the encapsulated
+actions in order.
+
+=head2 from_chain( \@actions )
+
+Takes a list of Catalyst::Action objects and constructs and returns a
+Catalyst::ActionChain object representing a chain of these actions
+
+=cut
+
+=head1 AUTHOR
+
+Matt S. Trout
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/ActionContainer.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/ActionContainer.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/ActionContainer.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,92 @@
+package Catalyst::ActionContainer;
+
+use strict;
+use base qw/Class::Accessor::Fast/;
+
+=head1 NAME
+
+Catalyst::ActionContainer - Catalyst Action Container
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This is a container for actions. The dispatcher sets up a tree of these
+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} },
+
+);
+
+sub new {
+ my ( $class, $fields ) = @_;
+
+ $fields = { part => $fields, actions => {} } unless ref $fields;
+
+ $class->SUPER::new($fields);
+}
+
+
+
+sub get_action {
+ my ( $self, $name ) = @_;
+ return $self->actions->{$name} if defined $self->actions->{$name};
+ return;
+}
+
+sub add_action {
+ my ( $self, $action, $name ) = @_;
+ $name ||= $action->name;
+ $self->actions->{$name} = $action;
+}
+
+1;
+
+__END__
+
+=head1 METHODS
+
+=head2 new(\%data | $part)
+
+Can be called with { part => $part, actions => \%actions } for full
+construction or with just a part, which will result in an empty actions
+hashref to be populated via add_action later
+
+=head2 get_action($name)
+
+Returns an action from this container based on the action name, or undef
+
+=head2 add_action($action, [ $name ])
+
+Adds an action, optionally providing a name to override $action->name
+
+=head2 actions
+
+Accessor to the actions hashref, containing all actions in this container.
+
+=head2 part
+
+Accessor to the path part this container resolves to. Also what the container
+stringifies to.
+
+=head1 AUTHOR
+
+Matt S. Trout
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/AttrContainer.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/AttrContainer.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/AttrContainer.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,62 @@
+package Catalyst::AttrContainer;
+
+use strict;
+use base qw/Class::Accessor::Fast Class::Data::Inheritable/;
+
+use Catalyst::Exception;
+use NEXT;
+
+__PACKAGE__->mk_classdata($_) for qw/_attr_cache _action_cache/;
+__PACKAGE__->_attr_cache( {} );
+__PACKAGE__->_action_cache( [] );
+
+# note - see attributes(3pm)
+sub MODIFY_CODE_ATTRIBUTES {
+ my ( $class, $code, @attrs ) = @_;
+ $class->_attr_cache( { %{ $class->_attr_cache }, $code => [@attrs] } );
+ $class->_action_cache(
+ [ @{ $class->_action_cache }, [ $code, [@attrs] ] ] );
+ return ();
+}
+
+sub FETCH_CODE_ATTRIBUTES { $_[0]->_attr_cache->{ $_[1] } || () }
+
+=head1 NAME
+
+Catalyst::AttrContainer
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This class sets up the code attribute cache. It's a base class for
+L<Catalyst::Controller>.
+
+=head1 METHODS
+
+=head2 FETCH_CODE_ATTRIBUTES
+
+Attribute function. See attributes(3pm)
+
+=head2 MODIFY_CODE_ATTRIBUTES
+
+Attribute function. See attributes(3pm)
+
+=head1 SEE ALSO
+
+L<Catalyst::Dispatcher>
+L<Catalyst>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+Marcus Ramberg, C<mramberg at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Base.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Base.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Base.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,34 @@
+package Catalyst::Base;
+
+use strict;
+use base qw/Catalyst::Controller/;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catalyst::Base - Deprecated base class
+
+=head1 DESCRIPTION
+
+This used to be the base class for Catalyst Controllers. It
+remains here for compability reasons.
+
+=head1 SEE ALSO
+
+L<Catalyst>, L<Catalyst::Controller>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+Marcus Ramberg, C<mramberg at cpan.org>
+Matt S Trout, C<mst at shadowcatsystems.co.uk>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
\ No newline at end of file
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Build.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Build.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Build.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,141 @@
+package Catalyst::Build;
+
+use strict;
+use Module::Build;
+use Path::Class;
+use File::Find 'find';
+
+our @ISA;
+eval "require Module::Build";
+die "Please install Module::Build\n" if $@;
+push @ISA, 'Module::Build';
+
+our @ignore =
+ qw/Build Build.PL Changes MANIFEST META.yml Makefile.PL Makefile README
+ _build blib lib script t/;
+
+our $FAKE;
+our $ignore = '^(' . join( '|', @ignore ) . ')$';
+
+=head1 NAME
+
+Catalyst::Build - Module::Build extension for Catalyst
+
+=head1 SYNOPSIS
+
+See L<Catalyst>
+
+=head1 DESCRIPTION
+
+L<Module::Build> extension for Catalyst.
+
+=head1 DEPRECATION NOTICE
+
+This module is deprecated in favor of L<Module::Install::Catalyst>. It's
+only left here for compability with older applications.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+
+ my $app_name = $self->{properties}{module_name};
+ warn <<"EOF";
+
+ Note:
+
+ The use of Build.PL for building and distributing Catalyst
+ applications is deprecated in Catalyst 5.58.
+
+ We recommend using the new Module::Install-based Makefile
+ system. You can generate a new Makefile.PL for your application
+ by running:
+
+ catalyst.pl -force -makefile $app_name
+
+EOF
+
+ return $self;
+}
+
+=item ACTION_install
+
+=cut
+
+sub ACTION_install {
+ my $self = shift;
+ $self->SUPER::ACTION_install;
+ $self->ACTION_install_extras;
+}
+
+=item ACTION_fakeinstall
+
+=cut
+
+sub ACTION_fakeinstall {
+ my $self = shift;
+ $self->SUPER::ACTION_fakeinstall;
+ local $FAKE = 1;
+ $self->ACTION_install_extras;
+}
+
+=item ACTION_install_extras
+
+=cut
+
+sub ACTION_install_extras {
+ my $self = shift;
+ my $prefix = $self->{properties}{destdir} || undef;
+ my $sitelib = $self->install_destination('lib');
+ my @path = defined $prefix ? ( $prefix, $sitelib ) : ($sitelib);
+ my $path = dir( @path, split( '::', $self->{properties}{module_name} ) );
+ my @files = $self->_find_extras;
+ print "Installing extras to $path\n";
+ for (@files) {
+ $FAKE
+ ? print "$_ -> $path (FAKE)\n"
+ : $self->copy_if_modified( $_, $path );
+ }
+}
+
+sub _find_extras {
+ my $self = shift;
+ my @all = glob '*';
+ my @files;
+ for my $file (@all) {
+ next if $file =~ /$ignore/;
+ if ( -d $file ) {
+ find(
+ sub {
+ return if -d;
+ push @files, $File::Find::name;
+ },
+ $file
+ );
+ }
+ else { push @files, $file }
+ }
+ return @files;
+}
+
+=back
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at oook.de>
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Component.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Component.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Component.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,201 @@
+package Catalyst::Component;
+
+use strict;
+use base qw/Class::Accessor::Fast Class::Data::Inheritable/;
+use NEXT;
+use Catalyst::Utils;
+
+
+=head1 NAME
+
+Catalyst::Component - Catalyst Component Base Class
+
+=head1 SYNOPSIS
+
+ # lib/MyApp/Model/Something.pm
+ package MyApp::Model::Something;
+
+ use base 'Catalyst::Component';
+
+ __PACKAGE__->config( foo => 'bar' );
+
+ sub test {
+ my $self = shift;
+ return $self->{foo};
+ }
+
+ sub forward_to_me {
+ my ( $self, $c ) = @_;
+ $c->response->output( $self->{foo} );
+ }
+
+ 1;
+
+ # Methods can be a request step
+ $c->forward(qw/MyApp::Model::Something forward_to_me/);
+
+ # Or just methods
+ print $c->comp('MyApp::Model::Something')->test;
+
+ print $c->comp('MyApp::Model::Something')->{foo};
+
+=head1 DESCRIPTION
+
+This is the universal base class for Catalyst components
+(Model/View/Controller).
+
+It provides you with a generic new() for instantiation through Catalyst's
+component loader with config() support and a process() method placeholder.
+
+=cut
+
+__PACKAGE__->mk_classdata($_) for qw/_config _plugins/;
+
+
+
+sub new {
+ my ( $self, $c ) = @_;
+
+ # 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 ) );
+}
+
+sub COMPONENT {
+ my ( $self, $c ) = @_;
+
+ # 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;
+ }
+ }
+}
+
+sub config {
+ my $self = shift;
+ my $config_sub = $self->can('_config');
+ my $config = $self->$config_sub() || {};
+ if (@_) {
+ my $newconfig = { %{@_ > 1 ? {@_} : $_[0]} };
+ $self->_config(
+ $self->merge_config_hashes( $config, $newconfig )
+ );
+ } 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) {
+
+ $config = $self->merge_config_hashes( $config, {} );
+ $self->$config_sub_now( $config );
+ }
+ }
+ return $config;
+}
+
+sub merge_config_hashes {
+ my ( $self, $lefthash, $righthash ) = @_;
+
+ return Catalyst::Utils::merge_hashes( $lefthash, $righthash );
+}
+
+sub process {
+
+ Catalyst::Exception->throw( message => ( ref $_[0] || $_[0] )
+ . " did not override Catalyst::Component::process" );
+}
+
+1;
+
+__END__
+
+=head1 METHODS
+
+=head2 new($c, $arguments)
+
+Called by COMPONENT to instantiate the component; should return an object
+to be stored in the application's component hash.
+
+=head2 COMPONENT($c, $arguments)
+
+If this method is present (as it is on all Catalyst::Component subclasses,
+it is called by Catalyst during setup_components with the application class
+as $c and any config entry on the application for this component (for example,
+in the case of MyApp::Controller::Foo this would be
+MyApp->config->{'Controller::Foo'}). The arguments are expected to be a
+hashref and are merged with the __PACKAGE__->config hashref before calling
+->new to instantiate the component.
+
+=head2 $c->config
+
+=head2 $c->config($hashref)
+
+=head2 $c->config($key, $value, ...)
+
+Accessor for this component's config hash. Config values can be set as
+key value pair, or you can specify a hashref. In either case the keys
+will be merged with any existing config settings. Each component in
+a Catalyst application has it's own config hash.
+
+=head2 $c->process()
+
+This is the default method called on a Catalyst component in the dispatcher.
+For instance, Views implement this action to render the response body
+when you forward to them. The default is an abstract method.
+
+=head2 $c->merge_config_hashes( $hashref, $hashref )
+
+Merges two hashes together recursively, giving right-hand precedence.
+Alias for the method in L<Catalyst::Utils>.
+
+=head1 OPTIONAL METHODS
+
+=head2 ACCEPT_CONTEXT($c, @args)
+
+Catalyst components are normally initalized 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.
+
+If this method is present, it is called during $c->comp/controller/model/view
+with the current $c and any additional args (e.g. $c->model('Foo', qw/bar baz/)
+would cause your MyApp::Model::Foo instance's ACCEPT_CONTEXT to be called with
+($c, 'bar', 'baz')) and the return value of this method is returned to the
+calling code in the application rather than the component itself.
+
+=head1 SEE ALSO
+
+L<Catalyst>, L<Catalyst::Model>, L<Catalyst::View>, L<Catalyst::Controller>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+Marcus Ramberg, C<mramberg at cpan.org>
+Matt S Trout, C<mst at shadowcatsystems.co.uk>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Controller.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Controller.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Controller.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,372 @@
+package Catalyst::Controller;
+
+use strict;
+use base qw/Catalyst::Component Catalyst::AttrContainer Class::Accessor::Fast/;
+
+use Catalyst::Exception;
+use Catalyst::Utils;
+use Class::Inspector;
+use NEXT;
+
+=head1 NAME
+
+Catalyst::Controller - Catalyst Controller base class
+
+=head1 SYNOPSIS
+
+ package MyApp::Controller::Search
+ use base qw/Catalyst::Controller/;
+
+ sub foo : Local {
+ my ($self,$c, at args) = @_;
+ ...
+ } # Dispatches to /search/foo
+
+=head1 DESCRIPTION
+
+Controllers are where the actions in the Catalyst framework
+reside. Each action is represented by a function with an attribute to
+identify what kind of action it is. See the L<Catalyst::Dispatcher>
+for more info about how Catalyst dispatches to actions.
+
+=cut
+
+__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 ) = @_;
+
+ foreach my $disp ( @{ $self->_dispatch_steps } ) {
+ last unless $c->forward($disp);
+ }
+
+ $c->forward('_END');
+}
+
+sub _BEGIN : Private {
+ my ( $self, $c ) = @_;
+ my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
+ return 1 unless $begin;
+ $begin->dispatch( $c );
+ return !@{ $c->error };
+}
+
+sub _AUTO : Private {
+ my ( $self, $c ) = @_;
+ my @auto = $c->get_actions( 'auto', $c->namespace );
+ foreach my $auto (@auto) {
+ $auto->dispatch( $c );
+ return 0 unless $c->state;
+ }
+ return 1;
+}
+
+sub _ACTION : Private {
+ my ( $self, $c ) = @_;
+ if ( ref $c->action
+ && $c->action->can('execute')
+ && defined $c->req->action )
+ {
+ $c->action->dispatch( $c );
+ }
+ return !@{ $c->error };
+}
+
+sub _END : Private {
+ my ( $self, $c ) = @_;
+ my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
+ return 1 unless $end;
+ $end->dispatch( $c );
+ 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 ( $self, $c ) = @_;
+ unless ( $c ) {
+ $c = ($self->isa('Catalyst') ? $self : $self->_application);
+ }
+ 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 $hash = (ref $self ? $self : $self->config); # hate app-is-class
+ return $hash->{path} if exists $hash->{path};
+ return shift->action_namespace(@_);
+}
+
+
+sub register_actions {
+ my ( $self, $c ) = @_;
+ my $class = ref $self || $self;
+ my $namespace = $self->action_namespace($c);
+ my %methods;
+ $methods{ $self->can($_) } = $_
+ for @{ Class::Inspector->methods($class) || [] };
+
+ # Advanced inheritance support for plugins and the like
+ my @action_cache;
+ {
+ no strict 'refs';
+ for my $isa ( @{"$class\::ISA"}, $class ) {
+ push @action_cache, @{ $isa->_action_cache }
+ if $isa->can('_action_cache');
+ }
+ }
+
+ foreach my $cache (@action_cache) {
+ my $code = $cache->[0];
+ my $method = delete $methods{$code}; # avoid dupe registers
+ next unless $method;
+ my $attrs = $self->_parse_attrs( $c, $method, @{ $cache->[1] } );
+ if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
+ $c->log->debug( 'Bad action definition "'
+ . join( ' ', @{ $cache->[1] } )
+ . qq/" for "$class->$method"/ )
+ if $c->debug;
+ next;
+ }
+ my $reverse = $namespace ? "$namespace/$method" : $method;
+ my $action = $self->create_action(
+ name => $method,
+ code => $code,
+ reverse => $reverse,
+ namespace => $namespace,
+ class => $class,
+ attributes => $attrs,
+ );
+
+ $c->dispatcher->register( $c, $action );
+ }
+}
+
+sub create_action {
+ my $self = shift;
+ my %args = @_;
+
+ my $class = (exists $args{attributes}{ActionClass}
+ ? $args{attributes}{ActionClass}[0]
+ : $self->_action_class);
+
+ unless ( Class::Inspector->loaded($class) ) {
+ require Class::Inspector->filename($class);
+ }
+
+ return $class->new( \%args );
+}
+
+sub _parse_attrs {
+ my ( $self, $c, $name, @attrs ) = @_;
+
+ my %raw_attributes;
+
+ foreach my $attr (@attrs) {
+
+ # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
+
+ if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
+ {
+
+ if ( defined $value ) {
+ ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
+ }
+ push( @{ $raw_attributes{$key} }, $value );
+ }
+ }
+
+ 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}} : ()));
+ }
+
+ my %final_attributes;
+
+ foreach my $key (keys %raw_attributes) {
+
+ my $raw = $raw_attributes{$key};
+
+ 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 );
+ }
+ push( @{ $final_attributes{$key} }, $value );
+ }
+ }
+
+ return \%final_attributes;
+}
+
+sub _parse_Global_attr {
+ my ( $self, $c, $name, $value ) = @_;
+ return $self->_parse_Path_attr( $c, $name, "/$name" );
+}
+
+sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
+
+sub _parse_Local_attr {
+ my ( $self, $c, $name, $value ) = @_;
+ return $self->_parse_Path_attr( $c, $name, $name );
+}
+
+sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
+
+sub _parse_Path_attr {
+ my ( $self, $c, $name, $value ) = @_;
+ $value = '' if !defined $value;
+ if ( $value =~ m!^/! ) {
+ return ( 'Path', $value );
+ }
+ elsif ( length $value ) {
+ return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
+ }
+ else {
+ return ( 'Path', $self->path_prefix($c) );
+ }
+}
+
+sub _parse_Regex_attr {
+ my ( $self, $c, $name, $value ) = @_;
+ return ( 'Regex', $value );
+}
+
+sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
+
+sub _parse_LocalRegex_attr {
+ my ( $self, $c, $name, $value ) = @_;
+ unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
+ return ( 'Regex', '^' . $self->path_prefix($c) . "/${value}" );
+}
+
+sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
+
+sub _parse_ActionClass_attr {
+ my ( $self, $c, $name, $value ) = @_;
+ unless ( $value =~ s/^\+// ) {
+ $value = join('::', $self->_action_class, $value );
+ }
+ return ( 'ActionClass', $value );
+}
+
+sub _parse_MyAction_attr {
+ my ( $self, $c, $name, $value ) = @_;
+
+ my $appclass = Catalyst::Utils::class2appclass($self);
+ $value = "${appclass}::Action::${value}";
+
+ return ( 'ActionClass', $value );
+}
+
+1;
+
+__END__
+
+=head1 CONFIGURATION
+
+Like any other L<Catalyst::Component>, controllers have a config hash,
+accessible through $self->config from the controller actions. Some
+settings are in use by the Catalyst framework:
+
+=head2 namespace
+
+This specifies the internal namespace the controller should be bound
+to. By default the controller is bound to the URI version of the
+controller name. For instance controller 'MyApp::Controller::Foo::Bar'
+will be bound to 'foo/bar'. The default Root controller is an example
+of setting namespace to '' (the null string).
+
+=head2 path
+
+Sets 'path_prefix', as described below.
+
+=head1 METHODS
+
+=head2 $class->new($app, @args)
+
+Proxies through to NEXT::new and stashes the application instance as
+$self->_application.
+
+=head2 $self->action_for('name')
+
+Returns the Catalyst::Action object (if any) for a given method name
+in this component.
+
+=head2 $self->register_actions($c)
+
+Finds all applicable actions for this component, creates
+Catalyst::Action objects (using $self->create_action) for them and
+registers them with $c->dispatcher.
+
+=head2 $self->action_namespace($c)
+
+Returns the private namespace for actions in this component. Defaults
+to a value from the controller name (for
+e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
+overridden from the "namespace" config key.
+
+
+=head2 $self->path_prefix($c)
+
+Returns the default path prefix for :Local, :LocalRegex and relative
+:Path actions in this component. Defaults to the action_namespace or
+can be overridden from the "path" config key.
+
+=head2 $self->create_action(%args)
+
+Called with a hash of data to be use for construction of a new
+Catalyst::Action (or appropriate sub/alternative class) object.
+
+Primarily designed for the use of register_actions.
+
+=head2 $self->_application
+
+=head2 $self->_app
+
+Returns the application instance stored by C<new()>
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at oook.de>
+Marcus Ramberg C<mramberg at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Chained.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Chained.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Chained.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,569 @@
+package Catalyst::DispatchType::Chained;
+
+use strict;
+use base qw/Catalyst::DispatchType/;
+use Text::SimpleTable;
+use Catalyst::ActionChain;
+use URI;
+
+# please don't perltidy this. hairy code within.
+
+=head1 NAME
+
+Catalyst::DispatchType::Chained - Path Part DispatchType
+
+=head1 SYNOPSIS
+
+ # root action - captures one argument after it
+ sub foo_setup : Chained('/') PathPart('foo') CaptureArgs(1) {
+ my ( $self, $c, $foo_arg ) = @_;
+ ...
+ }
+
+ # child action endpoint - takes one argument
+ sub bar : Chained('foo_setup') Args(1) {
+ my ( $self, $c, $bar_arg ) = @_;
+ ...
+ }
+
+=head1 DESCRIPTION
+
+See L</USAGE>.
+
+=head1 METHODS
+
+=head2 $self->list($c)
+
+Debug output for Path Part dispatch points
+
+=cut
+
+sub list {
+ my ( $self, $c ) = @_;
+
+ return unless $self->{endpoints};
+
+ my $paths = Text::SimpleTable->new(
+ [ 35, 'Path Spec' ], [ 36, 'Private' ]
+ );
+
+ ENDPOINT: foreach my $endpoint (
+ sort { $a->reverse cmp $b->reverse }
+ @{ $self->{endpoints} }
+ ) {
+ my $args = $endpoint->attributes->{Args}->[0];
+ my @parts = (defined($args) ? (("*") x $args) : '...');
+ my @parents = ();
+ my $parent = "DUMMY";
+ my $curr = $endpoint;
+ while ($curr) {
+ if (my $cap = $curr->attributes->{CaptureArgs}) {
+ unshift(@parts, (("*") x $cap->[0]));
+ }
+ if (my $pp = $curr->attributes->{PartPath}) {
+ unshift(@parts, $pp->[0])
+ if (defined $pp->[0] && length $pp->[0]);
+ }
+ $parent = $curr->attributes->{Chained}->[0];
+ $curr = $self->{actions}{$parent};
+ unshift(@parents, $curr) if $curr;
+ }
+ next ENDPOINT unless $parent eq '/'; # skip dangling action
+ my @rows;
+ foreach my $p (@parents) {
+ my $name = "/${p}";
+ if (my $cap = $p->attributes->{CaptureArgs}) {
+ $name .= ' ('.$cap->[0].')';
+ }
+ unless ($p eq $parents[0]) {
+ $name = "-> ${name}";
+ }
+ push(@rows, [ '', $name ]);
+ }
+ push(@rows, [ '', (@rows ? "=> " : '')."/${endpoint}" ]);
+ $rows[0][0] = join('/', '', @parts);
+ $paths->row(@$_) for @rows;
+ }
+
+ $c->log->debug( "Loaded Chained actions:\n" . $paths->draw . "\n" );
+}
+
+=head2 $self->match( $c, $path )
+
+Calls C<recurse_match> to see if a chain matches the C<$path>.
+
+=cut
+
+sub match {
+ my ( $self, $c, $path ) = @_;
+
+ return 0 if @{$c->req->args};
+
+ my @parts = split('/', $path);
+
+ my ($chain, $captures, $parts) = $self->recurse_match($c, '/', \@parts);
+ push @{$c->req->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);
+ $c->action($action);
+ $c->namespace( $action->namespace );
+
+ return 1;
+}
+
+=head2 $self->recurse_match( $c, $parent, \@path_parts )
+
+Recursive search for a matching chain.
+
+=cut
+
+sub recurse_match {
+ my ( $self, $c, $parent, $path_parts ) = @_;
+ my $children = $self->{children_of}{$parent};
+ return () unless $children;
+ my $best_action;
+ my @captures;
+ TRY: foreach my $try_part (sort { length($b) <=> length($a) }
+ keys %$children) {
+ # $b then $a to try longest part first
+ my @parts = @$path_parts;
+ if (length $try_part) { # test and strip PathPart
+ next TRY unless
+ ($try_part eq join('/', # assemble equal number of parts
+ splice( # and strip them off @parts as well
+ @parts, 0, scalar(@{[split('/', $try_part)]})
+ ))); # @{[]} to avoid split to @_
+ }
+ my @try_actions = @{$children->{$try_part}};
+ TRY_ACTION: foreach my $action (@try_actions) {
+ if (my $capture_attr = $action->attributes->{CaptureArgs}) {
+
+ # Short-circuit if not enough remaining parts
+ next TRY_ACTION unless @parts >= $capture_attr->[0];
+
+ my @captures;
+ my @parts = @parts; # localise
+
+ # strip CaptureArgs into list
+ push(@captures, splice(@parts, 0, $capture_attr->[0]));
+
+ # try the remaining parts against children of this action
+ my ($actions, $captures, $action_parts) = $self->recurse_match(
+ $c, '/'.$action->reverse, \@parts
+ );
+ if ($actions && (!$best_action || $#$action_parts < $#{$best_action->{parts}})){
+ $best_action = {
+ actions => [ $action, @$actions ],
+ captures=> [ @captures, @$captures ],
+ parts => $action_parts
+ };
+ }
+ }
+ else {
+ {
+ local $c->req->{arguments} = [ @{$c->req->args}, @parts ];
+ next TRY_ACTION unless $action->match($c);
+ }
+ my $args_attr = $action->attributes->{Args}->[0];
+
+ # No best action currently
+ # OR This one matches with fewer parts left than the current best action,
+ # And therefore is a better match
+ # OR No parts and this expects 0
+ # The current best action might also be Args(0),
+ # but we couldn't chose between then anyway so we'll take the last seen
+
+ if (!$best_action ||
+ @parts < @{$best_action->{parts}} ||
+ (!@parts && $args_attr eq 0)){
+ $best_action = {
+ actions => [ $action ],
+ captures=> [],
+ parts => \@parts
+ }
+ }
+ }
+ }
+ }
+ return @$best_action{qw/actions captures parts/} if $best_action;
+ return ();
+}
+
+=head2 $self->register( $c, $action )
+
+Calls register_path for every Path attribute for the given $action.
+
+=cut
+
+sub register {
+ my ( $self, $c, $action ) = @_;
+
+ my @chained_attr = @{ $action->attributes->{Chained} || [] };
+
+ return 0 unless @chained_attr;
+
+ if (@chained_attr > 1) {
+ Catalyst::Exception->throw(
+ "Multiple Chained attributes not supported registering ${action}"
+ );
+ }
+
+ my $parent = $chained_attr[0];
+
+ if (defined($parent) && length($parent)) {
+ if ($parent eq '.') {
+ $parent = '/'.$action->namespace;
+ } elsif ($parent !~ m/^\//) {
+ if ($action->namespace) {
+ $parent = '/'.join('/', $action->namespace, $parent);
+ } else {
+ $parent = '/'.$parent; # special case namespace '' (root)
+ }
+ }
+ } else {
+ $parent = '/'
+ }
+
+ $action->attributes->{Chained} = [ $parent ];
+
+ my $children = ($self->{children_of}{$parent} ||= {});
+
+ my @path_part = @{ $action->attributes->{PathPart} || [] };
+
+ my $part = $action->name;
+
+ if (@path_part == 1 && defined $path_part[0]) {
+ $part = $path_part[0];
+ } elsif (@path_part > 1) {
+ Catalyst::Exception->throw(
+ "Multiple PathPart attributes not supported registering ${action}"
+ );
+ }
+
+ if ($part =~ m(^/)) {
+ Catalyst::Exception->throw(
+ "Absolute parameters to PathPart not allowed registering ${action}"
+ );
+ }
+
+ $action->attributes->{PartPath} = [ $part ];
+
+ unshift(@{ $children->{$part} ||= [] }, $action);
+
+ ($self->{actions} ||= {})->{'/'.$action->reverse} = $action;
+
+ unless ($action->attributes->{CaptureArgs}) {
+ unshift(@{ $self->{endpoints} ||= [] }, $action);
+ }
+
+ return 1;
+}
+
+=head2 $self->uri_for_action($action, $captures)
+
+Get the URI part for the action, using C<$captures> to fill
+the capturing parts.
+
+=cut
+
+sub uri_for_action {
+ my ( $self, $action, $captures ) = @_;
+
+ return undef unless ($action->attributes->{Chained}
+ && !$action->attributes->{CaptureArgs});
+
+ my @parts = ();
+ my @captures = @$captures;
+ my $parent = "DUMMY";
+ my $curr = $action;
+ while ($curr) {
+ if (my $cap = $curr->attributes->{CaptureArgs}) {
+ return undef unless @captures >= $cap->[0]; # not enough captures
+ if ($cap->[0]) {
+ unshift(@parts, splice(@captures, -$cap->[0]));
+ }
+ }
+ if (my $pp = $curr->attributes->{PartPath}) {
+ unshift(@parts, $pp->[0])
+ if (defined($pp->[0]) && length($pp->[0]));
+ }
+ $parent = $curr->attributes->{Chained}->[0];
+ $curr = $self->{actions}{$parent};
+ }
+
+ return undef unless $parent eq '/'; # fail for dangling action
+
+ return undef if @captures; # fail for too many captures
+
+ return join('/', '', @parts);
+
+}
+
+=head1 USAGE
+
+=head2 Introduction
+
+The C<Chained> attribute allows you to chain public path parts together
+by their private names. A chain part's path can be specified with
+C<PathPart> and can be declared to expect an arbitrary number of
+arguments. The endpoint of the chain specifies how many arguments it
+gets through the C<Args> attribute. C<:Args(0)> would be none at all,
+C<:Args> without an integer would be unlimited. The path parts that
+aren't endpoints are using C<CaptureArgs> to specify how many parameters
+they expect to receive. As an example setup:
+
+ package MyApp::Controller::Greeting;
+ use base qw/ Catalyst::Controller /;
+
+ # this is the beginning of our chain
+ sub hello : PathPart('hello') Chained('/') CaptureArgs(1) {
+ my ( $self, $c, $integer ) = @_;
+ $c->stash->{ message } = "Hello ";
+ $c->stash->{ arg_sum } = $integer;
+ }
+
+ # this is our endpoint, because it has no :CaptureArgs
+ sub world : PathPart('world') Chained('hello') Args(1) {
+ my ( $self, $c, $integer ) = @_;
+ $c->stash->{ message } .= "World!";
+ $c->stash->{ arg_sum } += $integer;
+
+ $c->response->body( join "<br/>\n" =>
+ $c->stash->{ message }, $c->stash->{ arg_sum } );
+ }
+
+The debug output provides a separate table for chained actions, showing
+the whole chain as it would match and the actions it contains. Here's an
+example of the startup output with our actions above:
+
+ ...
+ [debug] Loaded Path Part actions:
+ .-----------------------+------------------------------.
+ | Path Spec | Private |
+ +-----------------------+------------------------------+
+ | /hello/*/world/* | /greeting/hello (1) |
+ | | => /greeting/world |
+ '-----------------------+------------------------------'
+ ...
+
+As you can see, Catalyst only deals with chains as whole paths and
+builds one for each endpoint, which are the actions with C<:Chained> but
+without C<:CaptureArgs>.
+
+Let's assume this application gets a request at the path
+C</hello/23/world/12>. What happens then? First, Catalyst will dispatch
+to the C<hello> action and pass the value C<23> as an argument to it
+after the context. It does so because we have previously used
+C<:CaptureArgs(1)> to declare that it has one path part after itself as
+its argument. We told Catalyst that this is the beginning of the chain
+by specifying C<:Chained('/')>. Also note that instead of saying
+C<:PathPart('hello')> we could also just have said C<:PathPart>, as it
+defaults to the name of the action.
+
+After C<hello> has run, Catalyst goes on to dispatch to the C<world>
+action. This is the last action to be called: Catalyst knows this is an
+endpoint because we did not specify a C<:CaptureArgs>
+attribute. Nevertheless we specify that this action expects an argument,
+but at this point we're using C<:Args(1)> to do that. We could also have
+said C<:Args> or left it out altogether, which would mean this action
+would get all arguments that are there. This action's C<:Chained>
+attribute says C<hello> and tells Catalyst that the C<hello> action in
+the current controller is its parent.
+
+With this we have built a chain consisting of two public path parts.
+C<hello> captures one part of the path as its argument, and also
+specifies the path root as its parent. So this part is
+C</hello/$arg>. The next part is the endpoint C<world>, expecting one
+argument. It sums up to the path part C<world/$arg>. This leads to a
+complete chain of C</hello/$arg/world/$arg> which is matched against the
+requested paths.
+
+This example application would, if run and called by e.g.
+C</hello/23/world/12>, set the stash value C<message> to "Hello" and the
+value C<arg_sum> to "23". The C<world> action would then append "World!"
+to C<message> and add C<12> to the stash's C<arg_sum> value. For the
+sake of simplicity no view is shown. Instead we just put the values of
+the stash into our body. So the output would look like:
+
+ Hello World!
+ 35
+
+And our test server would have given us this debugging output for the
+request:
+
+ ...
+ [debug] "GET" request for "hello/23/world/12" from "127.0.0.1"
+ [debug] Path is "/greeting/world"
+ [debug] Arguments are "12"
+ [info] Request took 0.164113s (6.093/s)
+ .------------------------------------------+-----------.
+ | Action | Time |
+ +------------------------------------------+-----------+
+ | /greeting/hello | 0.000029s |
+ | /greeting/world | 0.000024s |
+ '------------------------------------------+-----------'
+ ...
+
+What would be common uses of this dispatch technique? It gives the
+possibility to split up logic that contains steps that each depend on
+each other. An example would be, for example, a wiki path like
+C</wiki/FooBarPage/rev/23/view>. This chain can be easily built with
+these actions:
+
+ sub wiki : PathPart('wiki') Chained('/') CaptureArgs(1) {
+ my ( $self, $c, $page_name ) = @_;
+ # load the page named $page_name and put the object
+ # into the stash
+ }
+
+ sub rev : PathPart('rev') Chained('wiki') CaptureArgs(1) {
+ my ( $self, $c, $revision_id ) = @_;
+ # use the page object in the stash to get at its
+ # revision with number $revision_id
+ }
+
+ sub view : PathPart Chained('rev') Args(0) {
+ my ( $self, $c ) = @_;
+ # display the revision in our stash. Another option
+ # would be to forward a compatible object to the action
+ # that displays the default wiki pages, unless we want
+ # a different interface here, for example restore
+ # functionality.
+ }
+
+It would now be possible to add other endpoints, for example C<restore>
+to restore this specific revision as the current state.
+
+You don't have to put all the chained actions in one controller. The
+specification of the parent through C<:Chained> also takes an absolute
+action path as its argument. Just specify it with a leading C</>.
+
+If you want, for example, to have actions for the public paths
+C</foo/12/edit> and C</foo/12>, just specify two actions with
+C<:PathPart('foo')> and C<:Chained('/')>. The handler for the former
+path needs a C<:CaptureArgs(1)> attribute and a endpoint with
+C<:PathPart('edit')> and C<:Chained('foo')>. For the latter path give
+the action just a C<:Args(1)> to mark it as endpoint. This sums up to
+this debugging output:
+
+ ...
+ [debug] Loaded Path Part actions:
+ .-----------------------+------------------------------.
+ | Path Spec | Private |
+ +-----------------------+------------------------------+
+ | /foo/* | /controller/foo_view |
+ | /foo/*/edit | /controller/foo_load (1) |
+ | | => /controller/edit |
+ '-----------------------+------------------------------'
+ ...
+
+Here's a more detailed specification of the attributes belonging to
+C<:Chained>:
+
+=head2 Attributes
+
+=over 8
+
+=item PathPart
+
+Sets the name of this part of the chain. If it is specified without
+arguments, it takes the name of the action as default. So basically
+C<sub foo :PathPart> and C<sub foo :PathPart('foo')> are identical.
+This can also contain slashes to bind to a deeper level. An action
+with C<sub bar :PathPart('foo/bar') :Chained('/')> would bind to
+C</foo/bar/...>. If you don't specify C<:PathPart> it has the same
+effect as using C<:PathPart>, it would default to the action name.
+
+=item Chained
+
+Has to be specified for every child in the chain. Possible values are
+absolute and relative private action paths, with the relatives pointing
+to the current controller, or a single slash C</> to tell Catalyst that
+this is the root of a chain. The attribute C<:Chained> without arguments
+also defaults to the C</> behavior.
+
+Because you can specify an absolute path to the parent action, it
+doesn't matter to Catalyst where that parent is located. So, if your
+design requests it, you can redispatch a chain through any controller or
+namespace you want.
+
+Another interesting possibility gives C<:Chained('.')>, which chains
+itself to an action with the path of the current controller's namespace.
+For example:
+
+ # in MyApp::Controller::Foo
+ sub bar : Chained CaptureArgs(1) { ... }
+
+ # in MyApp::Controller::Foo::Bar
+ sub baz : Chained('.') Args(1) { ... }
+
+This builds up a chain like C</bar/*/baz/*>. The specification of C<.>
+as the argument to Chained here chains the C<baz> action to an action
+with the path of the current controller namespace, namely
+C</foo/bar>. That action chains directly to C</>, so the C</bar/*/baz/*>
+chain comes out as the end product.
+
+=item CaptureArgs
+
+Must be specified for every part of the chain that is not an
+endpoint. With this attribute Catalyst knows how many of the following
+parts of the path (separated by C</>) this action wants to capture as
+its arguments. If it doesn't expect any, just specify
+C<:CaptureArgs(0)>. The captures get passed to the action's C<@_> right
+after the context, but you can also find them as array references in
+C<$c-E<gt>request-E<gt>captures-E<gt>[$level]>. The C<$level> is the
+level of the action in the chain that captured the parts of the path.
+
+An action that is part of a chain (that is, one that has a C<:Chained>
+attribute) but has no C<:CaptureArgs> attribute is treated by Catalyst
+as a chain end.
+
+=item Args
+
+By default, endpoints receive the rest of the arguments in the path. You
+can tell Catalyst through C<:Args> explicitly how many arguments your
+endpoint expects, just like you can with C<:CaptureArgs>. Note that this
+also affects whether this chain is invoked on a request. A chain with an
+endpoint specifying one argument will only match if exactly one argument
+exists in the path.
+
+You can specify an exact number of arguments like C<:Args(3)>, including
+C<0>. If you just say C<:Args> without any arguments, it is the same as
+leaving it out altogether: The chain is matched regardless of the number
+of path parts after the endpoint.
+
+Just as with C<:CaptureArgs>, the arguments get passed to the action in
+C<@_> after the context object. They can also be reached through
+C<$c-E<gt>request-E<gt>arguments>.
+
+=back
+
+=head2 Auto actions, dispatching and forwarding
+
+Note that the list of C<auto> actions called depends on the private path
+of the endpoint of the chain, not on the chained actions way. The
+C<auto> actions will be run before the chain dispatching begins. In
+every other aspect, C<auto> actions behave as documented.
+
+The C<forward>ing to other actions does just what you would expect. But if
+you C<detach> out of a chain, the rest of the chain will not get called
+after the C<detach>.
+
+=head1 AUTHOR
+
+Matt S Trout <mst at shadowcatsystems.co.uk>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Default.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Default.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Default.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,60 @@
+package Catalyst::DispatchType::Default;
+
+use strict;
+use base qw/Catalyst::DispatchType/;
+
+=head1 NAME
+
+Catalyst::DispatchType::Default - Default DispatchType
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 $self->match( $c, $path )
+
+If path is empty (i.e. all path parts have been converted into args),
+attempts to find a default for the namespace constructed from the args,
+or the last inherited default otherwise and will match that.
+
+If path is not empty, never matches since Default will only match if all
+other possibilities have been exhausted.
+
+=cut
+
+sub match {
+ my ( $self, $c, $path ) = @_;
+ return if $path =~ m!/!; # Not at root yet, wait for it ...
+ my $result = ( $c->get_actions( 'default', $c->req->path ) )[-1];
+
+ # Find default on namespace or super
+ if ($result && $result->match($c)) {
+ $c->action($result);
+ $c->namespace( $result->namespace );
+ $c->req->action('default');
+
+ # default methods receive the controller name as the first argument
+ unshift @{ $c->req->args }, $path if $path;
+ $c->req->match('');
+ return 1;
+ }
+ return 0;
+}
+
+=head1 AUTHOR
+
+Matt S Trout
+Sebastian Riedel, C<sri at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Index.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Index.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Index.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,69 @@
+package Catalyst::DispatchType::Index;
+
+use strict;
+use base qw/Catalyst::DispatchType/;
+
+=head1 NAME
+
+Catalyst::DispatchType::Index - Index DispatchType
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 $self->match( $c, $path )
+
+Check if there's an index action for a given path, and set it up to use it
+if there is; only matches a full URI - if $c->req->args is already set
+this DispatchType is guaranteed not to match.
+
+=cut
+
+sub match {
+ my ( $self, $c, $path ) = @_;
+ return if @{ $c->req->args };
+ my $result = $c->get_action( 'index', $path );
+
+ if ($result && $result->match($c)) {
+ $c->action($result);
+ $c->namespace( $result->namespace );
+ $c->req->action('index');
+ $c->req->match( $c->req->path );
+ return 1;
+ }
+ return 0;
+}
+
+=head2 $self->uri_for_action( $action, $captures )
+
+get a URI part for an action; always returns undef is $captures is set
+since index actions don't have captures
+
+=cut
+
+sub uri_for_action {
+ my ( $self, $action, $captures ) = @_;
+
+ return undef if @$captures;
+
+ return undef unless $action->name eq 'index';
+
+ return "/".$action->namespace;
+}
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Path.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Path.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Path.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,133 @@
+package Catalyst::DispatchType::Path;
+
+use strict;
+use base qw/Catalyst::DispatchType/;
+use Text::SimpleTable;
+use URI;
+
+=head1 NAME
+
+Catalyst::DispatchType::Path - Path DispatchType
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 $self->list($c)
+
+Debug output for Path dispatch points
+
+=cut
+
+sub list {
+ my ( $self, $c ) = @_;
+ my $paths = Text::SimpleTable->new( [ 35, 'Path' ], [ 36, 'Private' ] );
+ foreach my $path ( sort keys %{ $self->{paths} } ) {
+ my $display_path = $path eq '/' ? $path : "/$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} } );
+}
+
+=head2 $self->match( $c, $path )
+
+For each action registered to this exact path, offers the action a chance to
+match the path (in the order in which they were registered). Succeeds on the
+first action that matches, if any; if not, returns 0.
+
+=cut
+
+sub match {
+ my ( $self, $c, $path ) = @_;
+
+ $path = '/' if !defined $path || !length $path;
+
+ foreach my $action ( @{ $self->{paths}->{$path} || [] } ) {
+ next unless $action->match($c);
+ $c->req->action($path);
+ $c->req->match($path);
+ $c->action($action);
+ $c->namespace( $action->namespace );
+ return 1;
+ }
+
+ return 0;
+}
+
+=head2 $self->register( $c, $action )
+
+Calls register_path for every Path attribute for the given $action.
+
+=cut
+
+sub register {
+ my ( $self, $c, $action ) = @_;
+
+ my @register = @{ $action->attributes->{Path} || [] };
+
+ $self->register_path( $c, $_, $action ) for @register;
+
+ return 1 if @register;
+ return 0;
+}
+
+=head2 $self->register_path($c, $path, $action)
+
+Registers an action at a given path.
+
+=cut
+
+sub register_path {
+ my ( $self, $c, $path, $action ) = @_;
+ $path =~ s!^/!!;
+ $path = '/' unless length $path;
+ $path = URI->new($path)->canonical;
+
+ unshift( @{ $self->{paths}{$path} ||= [] }, $action);
+
+ return 1;
+}
+
+=head2 $self->uri_for_action($action, $captures)
+
+get a URI part for an action; always returns undef is $captures is set
+since Path actions don't have captures
+
+=cut
+
+sub uri_for_action {
+ my ( $self, $action, $captures ) = @_;
+
+ return undef if @$captures;
+
+ if (my $paths = $action->attributes->{Path}) {
+ my $path = $paths->[0];
+ $path = '/' unless length($path);
+ $path = "/${path}" unless ($path =~ m/^\//);
+ $path = URI->new($path)->canonical;
+ return $path;
+ } else {
+ return undef;
+ }
+}
+
+=head1 AUTHOR
+
+Matt S Trout
+Sebastian Riedel, C<sri at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Regex.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Regex.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType/Regex.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,154 @@
+package Catalyst::DispatchType::Regex;
+
+use strict;
+use base qw/Catalyst::DispatchType::Path/;
+use Text::SimpleTable;
+use Text::Balanced ();
+
+=head1 NAME
+
+Catalyst::DispatchType::Regex - Regex DispatchType
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 $self->list($c)
+
+Output a table of all regex actions, and their private equivalent.
+
+=cut
+
+sub list {
+ my ( $self, $c ) = @_;
+ my $re = Text::SimpleTable->new( [ 35, 'Regex' ], [ 36, 'Private' ] );
+ 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} } );
+}
+
+=head2 $self->match( $c, $path )
+
+Checks path against every compiled regex, and offers the action for any regex
+which matches a chance to match the request. If it succeeds, sets action,
+match and captures on $c->req and returns 1. If not, returns 0 without
+altering $c.
+
+=cut
+
+sub match {
+ my ( $self, $c, $path ) = @_;
+
+ return if $self->SUPER::match( $c, $path );
+
+ # Check path against plain text first
+
+ foreach my $compiled ( @{ $self->{compiled} || [] } ) {
+ if ( my @captures = ( $path =~ $compiled->{re} ) ) {
+ next unless $compiled->{action}->match($c);
+ $c->req->action( $compiled->{path} );
+ $c->req->match($path);
+ $c->req->captures( \@captures );
+ $c->action( $compiled->{action} );
+ $c->namespace( $compiled->{action}->namespace );
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+=head2 $self->register( $c, $action )
+
+Registers one or more regex actions for an action object.
+Also registers them as literal paths.
+
+Returns 1 if any regexps were registered.
+
+=cut
+
+sub register {
+ my ( $self, $c, $action ) = @_;
+ my $attrs = $action->attributes;
+ my @register = @{ $attrs->{'Regex'} || [] };
+
+ foreach my $r (@register) {
+ $self->register_path( $c, $r, $action );
+ $self->register_regex( $c, $r, $action );
+ }
+
+ return 1 if @register;
+ return 0;
+}
+
+=head2 $self->register_regex($c, $re, $action)
+
+Register an individual regex on the action. Usually called from the
+register method.
+
+=cut
+
+sub register_regex {
+ my ( $self, $c, $re, $action ) = @_;
+ push(
+ @{ $self->{compiled} }, # and compiled regex for us
+ {
+ re => qr#$re#,
+ action => $action,
+ path => $re,
+ }
+ );
+}
+
+=head2 $self->uri_for_action($action, $captures)
+
+returns a URI for this action if it can find a regex attributes that contains
+the correct number of () captures. Note that this may function incorrectly
+in the case of nested captures - if your regex does (...(..))..(..) you'll
+need to pass the first and third captures only.
+
+=cut
+
+sub uri_for_action {
+ my ( $self, $action, $captures ) = @_;
+
+ if (my $regexes = $action->attributes->{Regex}) {
+ REGEX: foreach my $orig (@$regexes) {
+ my $re = "$orig";
+ $re =~ s/^\^//;
+ $re =~ s/\$$//;
+ my $final = '/';
+ my @captures = @$captures;
+ while (my ($front, $rest) = split(/\(/, $re, 2)) {
+ ($rest, $re) =
+ Text::Balanced::extract_bracketed("(${rest}", '(');
+ next REGEX unless @captures;
+ $final .= $front.shift(@captures);
+ }
+ next REGEX if @captures;
+ return $final;
+ }
+ }
+ return undef;
+}
+
+=head1 AUTHOR
+
+Matt S Trout
+Sebastian Riedel, C<sri at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/DispatchType.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,73 @@
+package Catalyst::DispatchType;
+
+use strict;
+use base 'Class::Accessor::Fast';
+
+=head1 NAME
+
+Catalyst::DispatchType - DispatchType Base Class
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This is an abstract base class for Dispatch Types.
+
+=head1 METHODS
+
+=head2 $self->list($c)
+
+abstract method, to be implemented by dispatchtypes. Called to display
+info in debug log.
+
+=cut
+
+sub list { }
+
+=head2 $self->match( $c, $path )
+
+abstract method, to be implemented by dispatchtypes. Returns true if the
+dispatch type matches the given path
+
+=cut
+
+sub match { die "Abstract method!" }
+
+=head2 $self->register( $c, $action )
+
+abstract method, to be implemented by dispatchtypes. Takes a
+context object and a L<Catalyst::Action> object.
+
+Should return true if it registers something, or false otherwise.
+
+=cut
+
+sub register { }
+
+=head2 $self->uri_for_action( $action, \@captures )
+
+abstract method, to be implemented by dispatchtypes. Takes a
+L<Catalyst::Action> object and an arrayref of captures, and should
+return either a URI part which if placed in $c->req->path would cause
+$self->match to match this action and set $c->req->captures to the supplied
+arrayref, or undef if unable to do so.
+
+=cut
+
+sub uri_for_action { }
+
+=head1 AUTHOR
+
+Matt S Trout
+Sebastian Riedel, C<sri at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Dispatcher.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Dispatcher.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Dispatcher.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,542 @@
+package Catalyst::Dispatcher;
+
+use strict;
+use base 'Class::Accessor::Fast';
+use Catalyst::Exception;
+use Catalyst::Utils;
+use Catalyst::Action;
+use Catalyst::ActionContainer;
+use Catalyst::DispatchType::Default;
+use Catalyst::DispatchType::Index;
+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
+ /
+);
+
+# Preload these action types
+our @PRELOAD = qw/Index Path Regex/;
+
+# Postload these action types
+our @POSTLOAD = qw/Default/;
+
+=head1 NAME
+
+Catalyst::Dispatcher - The Catalyst Dispatcher
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This is the class that maps public urls to actions in your Catalyst
+application based on the attributes you set.
+
+=head1 METHODS
+
+=head2 new
+
+Construct a new dispatcher.
+
+=cut
+
+sub new {
+ my $self = shift;
+ my $class = ref($self) || $self;
+
+ my $obj = $class->SUPER::new(@_);
+
+ # 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;
+}
+
+=head2 $self->preload_dispatch_types
+
+An arrayref of pre-loaded dispatchtype classes
+
+Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
+To use a custom class outside the regular C<Catalyst> namespace, prefix
+it with a C<+>, like so:
+
+ +My::Dispatch::Type
+
+=head2 $self->postload_dispatch_types
+
+An arrayref of post-loaded dispatchtype classes
+
+Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
+To use a custom class outside the regular C<Catalyst> namespace, prefix
+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' ) );
+ }
+
+ else {
+ my $path = $c->req->path;
+ my $error = $path
+ ? qq/Unknown resource "$path"/
+ : "No default action defined";
+ $c->log->error($error) if $c->debug;
+ $c->error($error);
+ }
+}
+
+=head2 $self->forward( $c, $command [, \@arguments ] )
+
+Documented in L<Catalyst>
+
+=cut
+
+sub forward {
+ my ( $self, $c, $command, @extra_params ) = @_;
+
+ unless ($command) {
+ $c->log->debug('Nothing to forward to') if $c->debug;
+ return 0;
+ }
+
+ my @args;
+
+ if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
+ @args = @{ pop @extra_params }
+ } else {
+ # this is a copy, it may take some abuse from ->_invoke_as_path if the path had trailing parts
+ @args = @{ $c->request->arguments };
+ }
+
+ my $action;
+
+ # forward to a string path ("/foo/bar/gorch") or action object which stringifies to that
+ $action = $self->_invoke_as_path( $c, "$command", \@args );
+
+ # forward to a component ( "MyApp::*::Foo" or $c->component("...") - a path or an object)
+ unless ($action) {
+ my $method = @extra_params ? $extra_params[0] : "process";
+ $action = $self->_invoke_as_component( $c, $command, $method );
+ }
+
+
+ unless ($action) {
+ my $error =
+ qq/Couldn't forward to command "$command": /
+ . qq/Invalid action or component./;
+ $c->error($error);
+ $c->log->debug($error) if $c->debug;
+ return 0;
+ }
+
+ #push @$args, @_;
+
+ local $c->request->{arguments} = \@args;
+ $action->dispatch( $c );
+
+ return $c->state;
+}
+
+sub _action_rel2abs {
+ my ( $self, $c, $path ) = @_;
+
+ unless ( $path =~ m#^/# ) {
+ my $namespace = $c->stack->[-1]->namespace;
+ $path = "$namespace/$path";
+ }
+
+ $path =~ s#^/##;
+ return $path;
+}
+
+sub _invoke_as_path {
+ my ( $self, $c, $rel_path, $args ) = @_;
+
+ my $path = $self->_action_rel2abs( $c, $rel_path );
+
+ my ( $tail, @extra_args );
+ while ( ( $path, $tail ) = ( $path =~ m#^(?:(.*)/)?(\w+)?$# ) )
+ { # allow $path to be empty
+ if ( my $action = $c->get_action( $tail, $path ) ) {
+ push @$args, @extra_args;
+ return $action;
+ }
+ else {
+ return
+ unless $path
+ ; # if a match on the global namespace failed then the whole lookup failed
+ }
+
+ unshift @extra_args, $tail;
+ }
+}
+
+sub _find_component_class {
+ my ( $self, $c, $component ) = @_;
+
+ return ref($component)
+ || ref( $c->component($component) )
+ || $c->component($component);
+}
+
+sub _invoke_as_component {
+ my ( $self, $c, $component, $method ) = @_;
+
+ my $class = $self->_find_component_class( $c, $component ) || return 0;
+
+ if ( my $code = $class->can($method) ) {
+ return $self->method_action_class->new(
+ {
+ name => $method,
+ code => $code,
+ reverse => "$class->$method",
+ class => $class,
+ namespace => Catalyst::Utils::class2prefix(
+ $class, $c->config->{case_sensitive}
+ ),
+ }
+ );
+ }
+ else {
+ my $error =
+ qq/Couldn't forward to "$class". Does not implement "$method"/;
+ $c->error($error);
+ $c->log->debug($error)
+ if $c->debug;
+ return 0;
+ }
+}
+
+=head2 $self->prepare_action($c)
+
+Find an dispatch type that matches $c->req->path, and set args from it.
+
+=cut
+
+sub prepare_action {
+ my ( $self, $c ) = @_;
+ my $path = $c->req->path;
+ my @path = split /\//, $c->req->path;
+ $c->req->args( \my @args );
+
+ unshift( @path, '' ); # Root action
+
+ DESCEND: while (@path) {
+ $path = join '/', @path;
+ $path =~ s#^/##;
+
+ $path = '' if $path eq '/'; # Root action
+
+ # Check out dispatch types to see if any will handle the path at
+ # this level
+
+ foreach my $type ( @{ $self->dispatch_types } ) {
+ last DESCEND if $type->match( $c, $path );
+ }
+
+ # If not, move the last part path to args
+ my $arg = pop(@path);
+ $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ unshift @args, $arg;
+ }
+
+ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$c->req->captures||[]};
+
+ $c->log->debug( 'Path is "' . $c->req->match . '"' )
+ if ( $c->debug && length $c->req->match );
+
+ $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
+ if ( $c->debug && @args );
+}
+
+=head2 $self->get_action( $action, $namespace )
+
+returns a named action from a given namespace.
+
+=cut
+
+sub get_action {
+ my ( $self, $name, $namespace ) = @_;
+ return unless $name;
+
+ $namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
+
+ return $self->action_hash->{"$namespace/$name"};
+}
+
+=head2 $self->get_action_by_path( $path );
+
+Returns the named action by its full path.
+
+=cut
+
+sub get_action_by_path {
+ my ( $self, $path ) = @_;
+ $path =~ s/^\///;
+ $path = "/$path" unless $path =~ /\//;
+ $self->action_hash->{$path};
+}
+
+=head2 $self->get_actions( $c, $action, $namespace )
+
+=cut
+
+sub get_actions {
+ my ( $self, $c, $action, $namespace ) = @_;
+ return [] unless $action;
+
+ $namespace = join( "/", grep { length } split '/', $namespace || "" );
+
+ my @match = $self->get_containers($namespace);
+
+ return map { $_->get_action($action) } @match;
+}
+
+=head2 $self->get_containers( $namespace )
+
+Return all the action containers for a given namespace, inclusive
+
+=cut
+
+sub get_containers {
+ my ( $self, $namespace ) = @_;
+ $namespace ||= '';
+ $namespace = '' if $namespace eq '/';
+
+ my @containers;
+
+ if ( length $namespace ) {
+ do {
+ push @containers, $self->container_hash->{$namespace};
+ } while ( $namespace =~ s#/[^/]+$## );
+ }
+
+ return reverse grep { defined } @containers, $self->container_hash->{''};
+
+ my @parts = split '/', $namespace;
+}
+
+=head2 $self->uri_for_action($action, \@captures)
+
+Takes a Catalyst::Action object and action parameters and returns a URI
+part such that if $c->req->path were this URI part, this action would be
+dispatched to with $c->req->captures set to the supplied arrayref.
+
+If the action object is not available for external dispatch or the dispatcher
+cannot determine an appropriate URI, this method will return undef.
+
+=cut
+
+sub uri_for_action {
+ my ( $self, $action, $captures) = @_;
+ $captures ||= [];
+ foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
+ my $uri = $dispatch_type->uri_for_action( $action, $captures );
+ return( $uri eq '' ? '/' : $uri )
+ if defined($uri);
+ }
+ return undef;
+}
+
+=head2 $self->register( $c, $action )
+
+Make sure all required dispatch types for this action are loaded, then
+pass the action to our dispatch types so they can register it if required.
+Also, set up the tree with the action containers.
+
+=cut
+
+sub register {
+ my ( $self, $c, $action ) = @_;
+
+ my $registered = $self->registered_dispatch_types;
+
+ my $priv = 0;
+ 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 $@;
+ $registered->{$class} = 1;
+ }
+ }
+
+ # Pass the action to our dispatch types so they can register it if reqd.
+ foreach my $type ( @{ $self->dispatch_types } ) {
+ $type->register( $c, $action );
+ }
+
+ my $namespace = $action->namespace;
+ my $name = $action->name;
+
+ my $container = $self->_find_or_create_action_container($namespace);
+
+ # Set the method value
+ $container->add_action($action);
+
+ $self->action_hash->{"$namespace/$name"} = $action;
+ $self->container_hash->{$namespace} = $container;
+}
+
+sub _find_or_create_action_container {
+ my ( $self, $namespace ) = @_;
+
+ my $tree ||= $self->tree;
+
+ return $tree->getNodeValue unless $namespace;
+
+ my @namespace = split '/', $namespace;
+ return $self->_find_or_create_namespace_node( $tree, @namespace )
+ ->getNodeValue;
+}
+
+sub _find_or_create_namespace_node {
+ my ( $self, $parent, $part, @namespace ) = @_;
+
+ return $parent unless $part;
+
+ my $child =
+ ( grep { $_->getNodeValue->part eq $part } $parent->getAllChildren )[0];
+
+ unless ($child) {
+ my $container = Catalyst::ActionContainer->new($part);
+ $parent->addChild( $child = Tree::Simple->new($container) );
+ }
+
+ $self->_find_or_create_namespace_node( $child, @namespace );
+}
+
+=head2 $self->setup_actions( $class, $context )
+
+
+=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;
+
+ foreach my $comp ( values %{ $c->components } ) {
+ $comp->register_actions($c) if $comp->can('register_actions');
+ }
+
+ $self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
+
+ return unless $c->debug;
+
+ my $privates = Text::SimpleTable->new(
+ [ 20, 'Private' ],
+ [ 36, 'Class' ],
+ [ 12, 'Method' ]
+ );
+
+ my $has_private = 0;
+ my $walker = sub {
+ my ( $walker, $parent, $prefix ) = @_;
+ $prefix .= $parent->getNodeValue || '';
+ $prefix .= '/' unless $prefix =~ /\/$/;
+ my $node = $parent->getNodeValue->actions;
+
+ for my $action ( keys %{$node} ) {
+ my $action_obj = $node->{$action};
+ next
+ if ( ( $action =~ /^_.*/ )
+ && ( !$c->config->{show_internal_actions} ) );
+ $privates->row( "$prefix$action", $action_obj->class, $action );
+ $has_private = 1;
+ }
+
+ $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
+ };
+
+ $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 };
+}
+
+sub _load_dispatch_types {
+ my ( $self, @types ) = @_;
+
+ my @loaded;
+
+ # Preload action types
+ for my $type (@types) {
+ my $class =
+ ( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
+ eval "require $class";
+ Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
+ if $@;
+ push @{ $self->dispatch_types }, $class->new;
+
+ push @loaded, $class;
+ }
+
+ return @loaded;
+}
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+Matt S Trout, C<mst at shadowcatsystems.co.uk>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/CGI.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/CGI.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/CGI.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,259 @@
+package Catalyst::Engine::CGI;
+
+use strict;
+use base 'Catalyst::Engine';
+use NEXT;
+
+__PACKAGE__->mk_accessors('env');
+
+=head1 NAME
+
+Catalyst::Engine::CGI - The CGI Engine
+
+=head1 SYNOPSIS
+
+A script using the Catalyst::Engine::CGI module might look like:
+
+ #!/usr/bin/perl -w
+
+ use strict;
+ use lib '/path/to/MyApp/lib';
+ use MyApp;
+
+ MyApp->run;
+
+The application module (C<MyApp>) would use C<Catalyst>, which loads the
+appropriate engine module.
+
+=head1 DESCRIPTION
+
+This is the Catalyst engine specialized for the CGI environment.
+
+=head1 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst::Engine>.
+
+=head2 $self->finalize_headers($c)
+
+=cut
+
+sub finalize_headers {
+ my ( $self, $c ) = @_;
+
+ $c->response->header( Status => $c->response->status );
+
+ $self->{_header_buf}
+ = $c->response->headers->as_string("\015\012") . "\015\012";
+}
+
+=head2 $self->prepare_connection($c)
+
+=cut
+
+sub prepare_connection {
+ my ( $self, $c ) = @_;
+ local (*ENV) = $self->env || \%ENV;
+
+ $c->request->address( $ENV{REMOTE_ADDR} );
+
+ PROXY_CHECK:
+ {
+ unless ( $c->config->{using_frontend_proxy} ) {
+ last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
+ last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
+ }
+ last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
+
+ # 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);
+ }
+
+ $c->request->hostname( $ENV{REMOTE_HOST} );
+ $c->request->protocol( $ENV{SERVER_PROTOCOL} );
+ $c->request->user( $ENV{REMOTE_USER} );
+ $c->request->method( $ENV{REQUEST_METHOD} );
+
+ if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
+ $c->request->secure(1);
+ }
+
+ if ( $ENV{SERVER_PORT} == 443 ) {
+ $c->request->secure(1);
+ }
+}
+
+=head2 $self->prepare_headers($c)
+
+=cut
+
+sub prepare_headers {
+ my ( $self, $c ) = @_;
+ local (*ENV) = $self->env || \%ENV;
+
+ # 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} );
+ }
+}
+
+=head2 $self->prepare_path($c)
+
+=cut
+
+sub prepare_path {
+ my ( $self, $c ) = @_;
+ local (*ENV) = $self->env || \%ENV;
+
+ my $scheme = $c->request->secure ? 'https' : 'http';
+ my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
+ my $port = $ENV{SERVER_PORT} || 80;
+ my $base_path;
+ if ( exists $ENV{REDIRECT_URL} ) {
+ $base_path = $ENV{REDIRECT_URL};
+ $base_path =~ s/$ENV{PATH_INFO}$//;
+ }
+ else {
+ $base_path = $ENV{SCRIPT_NAME} || '/';
+ }
+
+ # If we are running as a backend proxy, get the true hostname
+ PROXY_CHECK:
+ {
+ unless ( $c->config->{using_frontend_proxy} ) {
+ last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
+ last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
+ }
+ last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
+
+ $host = $ENV{HTTP_X_FORWARDED_HOST};
+
+ # backend could be on any port, so
+ # assume frontend is on the default port
+ $port = $c->request->secure ? 443 : 80;
+ }
+
+ # set the request URI
+ my $path = $base_path . ( $ENV{PATH_INFO} || '' );
+ $path =~ s{^/+}{};
+
+ # Using URI directly is way too slow, so we construct the URLs manually
+ my $uri_class = "URI::$scheme";
+
+ # HTTP_HOST will include the port even if it's 80/443
+ $host =~ s/:(?:80|443)$//;
+
+ if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) {
+ $host .= ":$port";
+ }
+
+ # Escape the path
+ $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
+ $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
+
+ my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : '';
+ my $uri = $scheme . '://' . $host . '/' . $path . $query;
+
+ $c->request->uri( bless \$uri, $uri_class );
+
+ # set the base URI
+ # base must end in a slash
+ $base_path .= '/' unless $base_path =~ m{/$};
+
+ my $base_uri = $scheme . '://' . $host . $base_path;
+
+ $c->request->base( bless \$base_uri, $uri_class );
+}
+
+=head2 $self->prepare_query_parameters($c)
+
+=cut
+
+sub prepare_query_parameters {
+ my ( $self, $c ) = @_;
+ local (*ENV) = $self->env || \%ENV;
+
+ if ( $ENV{QUERY_STRING} ) {
+ $self->SUPER::prepare_query_parameters( $c, $ENV{QUERY_STRING} );
+ }
+}
+
+=head2 $self->prepare_request($c, (env => \%env))
+
+=cut
+
+sub prepare_request {
+ my ( $self, $c, %args ) = @_;
+
+ if ( $args{env} ) {
+ $self->env( $args{env} );
+ }
+}
+
+=head2 $self->prepare_write($c)
+
+Enable autoflush on the output handle for CGI-based engines.
+
+=cut
+
+sub prepare_write {
+ my ( $self, $c ) = @_;
+
+ # Set the output handle to autoflush
+ *STDOUT->autoflush(1);
+
+ $self->NEXT::prepare_write($c);
+}
+
+=head2 $self->write($c, $buffer)
+
+Writes the buffer to the client.
+
+=cut
+
+sub write {
+ my ( $self, $c, $buffer ) = @_;
+
+ # Prepend the headers if they have not yet been sent
+ if ( my $headers = delete $self->{_header_buf} ) {
+ $buffer = $headers . $buffer;
+ }
+
+ return $self->NEXT::write( $c, $buffer );
+}
+
+=head2 $self->read_chunk($c, $buffer, $length)
+
+=cut
+
+sub read_chunk { shift; shift; *STDIN->sysread(@_); }
+
+=head2 $self->run
+
+=cut
+
+sub run { shift; shift->handle_request(@_) }
+
+=head1 SEE ALSO
+
+L<Catalyst> L<Catalyst::Engine>.
+
+=head1 AUTHORS
+
+Sebastian Riedel, <sri at cpan.org>
+
+Christian Hansen, <ch at ngmedia.com>
+
+Andy Grundman, <andy at hybridized.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/FastCGI.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/FastCGI.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/FastCGI.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,417 @@
+package Catalyst::Engine::FastCGI;
+
+use strict;
+use base 'Catalyst::Engine::CGI';
+eval "use FCGI";
+die "Unable to load the FCGI module, you may need to install it:\n$@\n" if $@;
+
+=head1 NAME
+
+Catalyst::Engine::FastCGI - FastCGI Engine
+
+=head1 DESCRIPTION
+
+This is the FastCGI engine.
+
+=head1 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst::Engine::CGI>.
+
+=head2 $self->run($c, $listen, { option => value, ... })
+
+Starts the FastCGI server. If C<$listen> is set, then it specifies a
+location to listen for FastCGI requests;
+
+=over 4
+
+=item /path
+
+listen via Unix sockets on /path
+
+=item :port
+
+listen via TCP on port on all interfaces
+
+=item hostname:port
+
+listen via TCP on port bound to hostname
+
+=back
+
+Options may also be specified;
+
+=over 4
+
+=item leave_umask
+
+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
+
+=item nproc
+
+Specify a number of processes for FCGI::ProcManager
+
+=item pidfile
+
+Specify a filename for the pid file
+
+=item manager
+
+Specify a FCGI::ProcManager sub-class
+
+=item detach
+
+Detach from console
+
+=item keep_stderr
+
+Send STDERR to STDOUT instead of the webserver
+
+=back
+
+=cut
+
+sub run {
+ my ( $self, $class, $listen, $options ) = @_;
+
+ my $sock = 0;
+ if ($listen) {
+ my $old_umask = umask;
+ unless ( $options->{leave_umask} ) {
+ umask(0);
+ }
+ $sock = FCGI::OpenSocket( $listen, 100 )
+ or die "failed to open FastCGI socket; $!";
+ unless ( $options->{leave_umask} ) {
+ umask($old_umask);
+ }
+ }
+ elsif ( $^O ne 'MSWin32' ) {
+ -S STDIN
+ or die "STDIN is not a socket; specify a listen location";
+ }
+
+ $options ||= {};
+
+ my %env;
+ 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 ),
+ );
+
+ my $proc_manager;
+
+ if ($listen) {
+ $options->{manager} ||= "FCGI::ProcManager";
+ $options->{nproc} ||= 1;
+
+ $self->daemon_fork() if $options->{detach};
+
+ if ( $options->{manager} ) {
+ eval "use $options->{manager}; 1" or die $@;
+
+ $proc_manager = $options->{manager}->new(
+ {
+ n_processes => $options->{nproc},
+ pid_fname => $options->{pidfile},
+ }
+ );
+
+ # detach *before* the ProcManager inits
+ $self->daemon_detach() if $options->{detach};
+
+ $proc_manager->pm_manage();
+ }
+ elsif ( $options->{detach} ) {
+ $self->daemon_detach();
+ }
+ }
+
+ while ( $request->Accept >= 0 ) {
+ $proc_manager && $proc_manager->pm_pre_dispatch();
+
+ # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME
+ # http://lists.rawmode.org/pipermail/catalyst/2006-June/008361.html
+ # Thanks to Mark Blythe for this fix
+ if ( $env{SERVER_SOFTWARE} && $env{SERVER_SOFTWARE} =~ /lighttpd/ ) {
+ $env{PATH_INFO} ||= delete $env{SCRIPT_NAME};
+ }
+
+ $class->handle_request( env => \%env );
+
+ $proc_manager && $proc_manager->pm_post_dispatch();
+ }
+}
+
+=head2 $self->write($c, $buffer)
+
+=cut
+
+sub write {
+ my ( $self, $c, $buffer ) = @_;
+
+ unless ( $self->{_prepared_write} ) {
+ $self->prepare_write($c);
+ $self->{_prepared_write} = 1;
+ }
+
+ # XXX: We can't use Engine's write() method because syswrite
+ # appears to return bogus values instead of the number of bytes
+ # 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;
+ }
+
+ # FastCGI does not stream data properly if using 'print $handle',
+ # but a syswrite appears to work properly.
+ *STDOUT->syswrite($buffer);
+}
+
+=head2 $self->daemon_fork()
+
+Performs the first part of daemon initialisation. Specifically,
+forking. STDERR, etc are still connected to a terminal.
+
+=cut
+
+sub daemon_fork {
+ require POSIX;
+ fork && exit;
+}
+
+=head2 $self->daemon_detach( )
+
+Performs the second part of daemon initialisation. Specifically,
+disassociates from the terminal.
+
+However, this does B<not> change the current working directory to "/",
+as normal daemons do. It also does not close all open file
+descriptors (except STDIN, STDOUT and STDERR, which are re-opened from
+F</dev/null>).
+
+=cut
+
+sub daemon_detach {
+ my $self = shift;
+ print "FastCGI daemon started (pid $$)\n";
+ open STDIN, "+</dev/null" or die $!;
+ open STDOUT, ">&STDIN" or die $!;
+ open STDERR, ">&STDIN" or die $!;
+ POSIX::setsid();
+}
+
+1;
+__END__
+
+=head1 WEB SERVER CONFIGURATIONS
+
+=head2 Standalone FastCGI Server
+
+In server mode the application runs as a standalone server and accepts
+connections from a web server. The application can be on the same machine as
+the web server, on a remote machine, or even on multiple remote machines.
+Advantages of this method include running the Catalyst application as a
+different user than the web server, and the ability to set up a scalable
+server farm.
+
+To start your application in server mode, install the FCGI::ProcManager
+module and then use the included fastcgi.pl script.
+
+ $ script/myapp_fastcgi.pl -l /tmp/myapp.socket -n 5
+
+Command line options for fastcgi.pl include:
+
+ -d -daemon Daemonize the server.
+ -p -pidfile Write a pidfile with the pid of the process manager.
+ -l -listen Listen on a socket path, hostname:port, or :port.
+ -n -nproc The number of processes started to handle requests.
+
+See below for the specific web server configurations for using the external
+server.
+
+=head2 Apache 1.x, 2.x
+
+Apache requires the mod_fastcgi module. The same module supports both
+Apache 1 and 2.
+
+There are three ways to run your application under FastCGI on Apache: server,
+static, and dynamic.
+
+=head3 Standalone server mode
+
+ FastCgiExternalServer /tmp/myapp.fcgi -socket /tmp/myapp.socket
+ Alias /myapp/ /tmp/myapp/myapp.fcgi/
+
+ # Or, run at the root
+ Alias / /tmp/myapp.fcgi/
+
+ # Optionally, rewrite the path when accessed without a trailing slash
+ RewriteRule ^/myapp$ myapp/ [R]
+
+
+The FastCgiExternalServer directive tells Apache that when serving
+/tmp/myapp to use the FastCGI application listenting on the socket
+/tmp/mapp.socket. Note that /tmp/myapp.fcgi does not need to exist --
+it's a virtual file name. With some versions of C<mod_fastcgi> or
+C<mod_fcgid>, you can use any name you like, but most require that the
+virtual filename end in C<.fcgi>.
+
+It's likely that Apache is not configured to serve files in /tmp, so the
+Alias directive maps the url path /myapp/ to the (virtual) file that runs the
+FastCGI application. The trailing slashes are important as their use will
+correctly set the PATH_INFO environment variable used by Catalyst to
+determine the request path. If you would like to be able to access your app
+without a trailing slash (http://server/myapp), you can use the above
+RewriteRule directive.
+
+=head3 Static mode
+
+The term 'static' is misleading, but in static mode Apache uses its own
+FastCGI Process Manager to start the application processes. This happens at
+Apache startup time. In this case you do not run your application's
+fastcgi.pl script -- that is done by Apache. Apache then maps URIs to the
+FastCGI script to run your application.
+
+ FastCgiServer /path/to/myapp/script/myapp_fastcgi.pl -processes 3
+ Alias /myapp/ /path/to/myapp/script/myapp_fastcgi.pl/
+
+FastCgiServer tells Apache to start three processes of your application at
+startup. The Alias command maps a path to the FastCGI application. Again,
+the trailing slashes are important.
+
+=head3 Dynamic mode
+
+In FastCGI dynamic mode, Apache will run your application on demand,
+typically by requesting a file with a specific extension (e.g. .fcgi). ISPs
+often use this type of setup to provide FastCGI support to many customers.
+
+In this mode it is often enough to place or link your *_fastcgi.pl script in
+your cgi-bin directory with the extension of .fcgi. In dynamic mode Apache
+must be able to run your application as a CGI script so ExecCGI must be
+enabled for the directory.
+
+ AddHandler fastcgi-script .fcgi
+
+The above tells Apache to run any .fcgi file as a FastCGI application.
+
+Here is a complete example:
+
+ <VirtualHost *:80>
+ ServerName www.myapp.com
+ DocumentRoot /path/to/MyApp
+
+ # Allow CGI script to run
+ <Directory /path/to/MyApp>
+ Options +ExecCGI
+ </Directory>
+
+ # Tell Apache this is a FastCGI application
+ <Files myapp_fastcgi.pl>
+ SetHandler fastcgi-script
+ </Files>
+ </VirtualHost>
+
+Then a request for /script/myapp_fastcgi.pl will run the
+application.
+
+For more information on using FastCGI under Apache, visit
+L<http://www.fastcgi.com/mod_fastcgi/docs/mod_fastcgi.html>
+
+=head3 Authorization header with mod_fastcgi or mod_cgi
+
+By default, mod_fastcgi/mod_cgi do not pass along the Authorization header,
+so modules like C<Catalyst::Plugin::Authentication::Credential::HTTP> will
+not work. To enable pass-through of this header, add the following
+mod_rewrite directives:
+
+ RewriteCond %{HTTP:Authorization} ^(.+)
+ RewriteRule ^(.*)$ $1 [E=HTTP_AUTHORIZATION:%1,PT]
+
+=head2 Lighttpd
+
+These configurations were tested with Lighttpd 1.4.7.
+
+=head3 Standalone server mode
+
+ server.document-root = "/var/www/MyApp/root"
+
+ fastcgi.server = (
+ "" => (
+ "MyApp" => (
+ "socket" => "/tmp/myapp.socket",
+ "check-local" => "disable"
+ )
+ )
+ )
+
+=head3 Static mode
+
+ server.document-root = "/var/www/MyApp/root"
+
+ fastcgi.server = (
+ "" => (
+ "MyApp" => (
+ "socket" => "/tmp/myapp.socket",
+ "check-local" => "disable",
+ "bin-path" => "/var/www/MyApp/script/myapp_fastcgi.pl",
+ "min-procs" => 2,
+ "max-procs" => 5,
+ "idle-timeout" => 20
+ )
+ )
+ )
+
+Note that in newer versions of lighttpd, the min-procs and idle-timeout
+values are disabled. The above example would start 5 processes.
+
+=head3 Non-root configuration
+
+You can also run your application at any non-root location with either of the
+above modes. Note the required mod_rewrite rule.
+
+ url.rewrite = ( "myapp\$" => "myapp/" )
+ fastcgi.server = (
+ "/myapp" => (
+ "MyApp" => (
+ # same as above
+ )
+ )
+ )
+
+For more information on using FastCGI under Lighttpd, visit
+L<http://www.lighttpd.net/documentation/fastcgi.html>
+
+=head2 IIS
+
+It is possible to run Catalyst under IIS with FastCGI, but we do not
+yet have detailed instructions.
+
+=head1 SEE ALSO
+
+L<Catalyst>, L<FCGI>.
+
+=head1 AUTHORS
+
+Sebastian Riedel, <sri at cpan.org>
+
+Christian Hansen, <ch at ngmedia.com>
+
+Andy Grundman, <andy at hybridized.org>
+
+=head1 THANKS
+
+Bill Moseley, for documentation updates and testing.
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,204 @@
+package Catalyst::Engine::HTTP::Restarter::Watcher;
+
+use strict;
+use warnings;
+use base 'Class::Accessor::Fast';
+use File::Find;
+use File::Modified;
+use File::Spec;
+use Time::HiRes qw/sleep/;
+
+__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;
+
+ return $self;
+}
+
+sub _init {
+ my $self = shift;
+
+ my $watch_list = $self->_index_directory;
+ $self->watch_list($watch_list);
+
+ $self->modified(
+ File::Modified->new(
+ method => 'mtime',
+ files => [ keys %{$watch_list} ],
+ )
+ );
+}
+
+sub watch {
+ my $self = shift;
+
+ my @changes;
+ my @changed_files;
+
+ my $delay = ( defined $self->delay ) ? $self->delay : 1;
+
+ sleep $delay if $delay > 0;
+
+ eval { @changes = $self->modified->changed };
+ if ($@) {
+
+ # File::Modified will die if a file is deleted.
+ my ($deleted_file) = $@ =~ /stat '(.+)'/;
+ push @changed_files, $deleted_file || 'unknown file';
+ }
+
+ if (@changes) {
+
+ # update all mtime information
+ $self->modified->update;
+
+ # check if any files were changed
+ @changed_files = grep { -f $_ } @changes;
+
+ # Check if only directories were changed. This means
+ # a new file was created.
+ unless (@changed_files) {
+
+ # re-index to find new files
+ my $new_watch = $self->_index_directory;
+
+ # look through the new list for new files
+ my $old_watch = $self->watch_list;
+ @changed_files = grep { !defined $old_watch->{$_} }
+ keys %{$new_watch};
+
+ return unless @changed_files;
+ }
+
+ # Test modified pm's
+ for my $file (@changed_files) {
+ next unless $file =~ /\.pm$/;
+ if ( my $error = $self->_test($file) ) {
+ print STDERR qq/File "$file" modified, not restarting\n\n/;
+ print STDERR '*' x 80, "\n";
+ print STDERR $error;
+ print STDERR '*' x 80, "\n";
+ return;
+ }
+ }
+ }
+
+ return @changed_files;
+}
+
+sub _index_directory {
+ my $self = shift;
+
+ my $dir = $self->directory;
+ die "No directory specified" if !$dir or ref($dir) && !@{$dir};
+
+ my $regex = $self->regex || '\.pm$';
+ my %list;
+
+ finddepth(
+ {
+ wanted => sub {
+ my $file = File::Spec->rel2abs($File::Find::name);
+ return unless $file =~ /$regex/;
+ return unless -f $file;
+ $file =~ s{/script/..}{};
+ $list{$file} = 1;
+
+ # also watch the directory for changes
+ my $cur_dir = File::Spec->rel2abs($File::Find::dir);
+ $cur_dir =~ s{/script/..}{};
+ $list{$cur_dir} = 1;
+ },
+ follow_fast => $self->follow_symlinks ? 1 : 0,
+ no_chdir => 1
+ },
+ ref $dir eq 'ARRAY' ? @{$dir} : $dir
+ );
+ return \%list;
+}
+
+sub _test {
+ my ( $self, $file ) = @_;
+
+ delete $INC{$file};
+ local $SIG{__WARN__} = sub { };
+
+ open my $olderr, '>&STDERR';
+ open STDERR, '>', File::Spec->devnull;
+ eval "require '$file'";
+ open STDERR, '>&', $olderr;
+
+ return ($@) ? $@ : 0;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Catalyst::Engine::HTTP::Restarter::Watcher - Watch for changed application
+files
+
+=head1 SYNOPSIS
+
+ my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new(
+ directory => '/path/to/MyApp',
+ regex => '\.yml$|\.yaml$|\.conf|\.pm$',
+ delay => 1,
+ );
+
+ while (1) {
+ my @changed_files = $watcher->watch();
+ }
+
+=head1 DESCRIPTION
+
+This class monitors a directory of files for changes made to any file
+matching a regular expression. It correctly handles new files added to the
+application as well as files that are deleted.
+
+=head1 METHODS
+
+=head2 new ( directory => $path [, regex => $regex, delay => $delay ] )
+
+Creates a new Watcher object.
+
+=head2 watch
+
+Returns a list of files that have been added, deleted, or changed since the
+last time watch was called.
+
+=head1 SEE ALSO
+
+L<Catalyst>, L<Catalyst::Engine::HTTP::Restarter>, L<File::Modified>
+
+=head1 AUTHORS
+
+Sebastian Riedel, <sri at cpan.org>
+
+Andy Grundman, <andy at hybridized.org>
+
+=head1 THANKS
+
+Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP/Restarter.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,115 @@
+package Catalyst::Engine::HTTP::Restarter;
+
+use strict;
+use warnings;
+use base 'Catalyst::Engine::HTTP';
+use Catalyst::Engine::HTTP::Restarter::Watcher;
+use NEXT;
+
+sub run {
+ my ( $self, $class, $port, $host, $options ) = @_;
+
+ $options ||= {};
+
+ # Setup restarter
+ unless ( my $restarter = fork ) {
+
+ # Prepare
+ close STDIN;
+ close STDOUT;
+
+ my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new(
+ directory => (
+ $options->{restart_directory} ||
+ File::Spec->catdir( $FindBin::Bin, '..' )
+ ),
+ follow_symlinks => $options->{follow_symlinks},
+ regex => $options->{restart_regex},
+ delay => $options->{restart_delay},
+ );
+
+ $host ||= '127.0.0.1';
+ while (1) {
+
+ # poll for changed files
+ my @changed_files = $watcher->watch();
+
+ # check if our parent process has died
+ exit if $^O ne 'MSWin32' and getppid == 1;
+
+ # Restart if any files have changed
+ if (@changed_files) {
+ my $files = join ', ', @changed_files;
+ print STDERR qq/File(s) "$files" modified, restarting\n\n/;
+
+ require IO::Socket::INET;
+ require HTTP::Headers;
+ require HTTP::Request;
+
+ my $client = IO::Socket::INET->new(
+ PeerAddr => $host,
+ PeerPort => $port
+ )
+ or die "Can't create client socket (is server running?): ",
+ $!;
+
+ # build the Kill request
+ my $req =
+ HTTP::Request->new( 'RESTART', '/',
+ HTTP::Headers->new( 'Connection' => 'close' ) );
+ $req->protocol('HTTP/1.0');
+
+ $client->send( $req->as_string )
+ or die "Can't send restart instruction: ", $!;
+ $client->close();
+ exit;
+ }
+ }
+ }
+
+ return $self->NEXT::run( $class, $port, $host, $options );
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Catalyst::Engine::HTTP::Restarter - Catalyst Auto-Restarting HTTP Engine
+
+=head1 SYNOPSIS
+
+ script/myapp_server.pl -restart
+
+=head1 DESCRIPTION
+
+The Restarter engine will monitor files in your application for changes
+and restart the server when any changes are detected.
+
+=head1 METHODS
+
+=head2 run
+
+=head1 SEE ALSO
+
+L<Catalyst>, L<Catalyst::Engine::HTTP>, L<Catalyst::Engine::CGI>,
+L<Catalyst::Engine>.
+
+=head1 AUTHORS
+
+Sebastian Riedel, <sri at cpan.org>
+
+Dan Kubb, <dan.kubb-cpan at onautopilot.com>
+
+Andy Grundman, <andy at hybridized.org>
+
+=head1 THANKS
+
+Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine/HTTP.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,559 @@
+package Catalyst::Engine::HTTP;
+
+use strict;
+use base '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 ();
+
+# For PAR
+require Catalyst::Engine::HTTP::Restarter;
+require Catalyst::Engine::HTTP::Restarter::Watcher;
+
+use constant CHUNKSIZE => 64 * 1024;
+use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0;
+
+=head1 NAME
+
+Catalyst::Engine::HTTP - Catalyst HTTP Engine
+
+=head1 SYNOPSIS
+
+A script using the Catalyst::Engine::HTTP module might look like:
+
+ #!/usr/bin/perl -w
+
+ BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP' }
+
+ use strict;
+ use lib '/path/to/MyApp/lib';
+ use MyApp;
+
+ MyApp->run;
+
+=head1 DESCRIPTION
+
+This is the Catalyst engine specialized for development and testing.
+
+=head1 METHODS
+
+=head2 $self->finalize_headers($c)
+
+=cut
+
+sub finalize_headers {
+ my ( $self, $c ) = @_;
+ my $protocol = $c->request->protocol;
+ my $status = $c->response->status;
+ my $message = status_message($status);
+
+ my @headers;
+ push @headers, "$protocol $status $message";
+
+ $c->response->headers->header( Date => HTTP::Date::time2str(time) );
+ $c->response->headers->header( Status => $status );
+
+ # Should we keep the connection open?
+ my $connection = $c->request->header('Connection');
+ if ( $self->{options}->{keepalive}
+ && $connection
+ && $connection =~ /^keep-alive$/i
+ ) {
+ $c->response->headers->header( Connection => 'keep-alive' );
+ $self->{_keepalive} = 1;
+ }
+ else {
+ $c->response->headers->header( Connection => 'close' );
+ }
+
+ push @headers, $c->response->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, '');
+}
+
+=head2 $self->finalize_read($c)
+
+=cut
+
+sub finalize_read {
+ my ( $self, $c ) = @_;
+
+ # 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 ) = @_;
+
+ # Set the input handle to non-blocking
+ *STDIN->blocking(0);
+
+ return $self->NEXT::prepare_read($c);
+}
+
+=head2 $self->read_chunk($c, $buffer, $length)
+
+=cut
+
+sub read_chunk {
+ my $self = shift;
+ my $c = shift;
+
+ # If we have any remaining data in the input buffer, send it back first
+ if ( $_[0] = delete $self->{inputbuf} ) {
+ my $read = length( $_[0] );
+ DEBUG && warn "read_chunk: Read $read bytes from previous input buffer\n";
+ return $read;
+ }
+
+ # support for non-blocking IO
+ my $rin = '';
+ vec( $rin, *STDIN->fileno, 1 ) = 1;
+
+ READ:
+ {
+ select( $rin, undef, undef, undef );
+ my $rc = *STDIN->sysread(@_);
+ if ( defined $rc ) {
+ DEBUG && warn "read_chunk: Read $rc bytes from socket\n";
+ return $rc;
+ }
+ else {
+ next READ if $! == EWOULDBLOCK;
+ return;
+ }
+ }
+}
+
+=head2 $self->write($c, $buffer)
+
+Writes the buffer to the client.
+
+=cut
+
+sub write {
+ 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;
+ }
+
+ my $ret = $self->NEXT::write( $c, $buffer );
+
+ if ( !defined $ret ) {
+ $self->{_write_error} = $!;
+ DEBUG && warn "write: Failed to write response ($!)\n";
+ }
+ else {
+ DEBUG && warn "write: Wrote response ($ret bytes)\n";
+ }
+
+ return $ret;
+}
+
+=head2 run
+
+=cut
+
+# A very very simple HTTP server that initializes a CGI environment
+sub run {
+ my ( $self, $class, $port, $host, $options ) = @_;
+
+ $options ||= {};
+
+ $self->{options} = $options;
+
+ if ($options->{background}) {
+ my $child = fork;
+ die "Can't fork: $!" unless defined($child);
+ return $child if $child;
+ }
+
+ my $restart = 0;
+ local $SIG{CHLD} = 'IGNORE';
+
+ my $allowed = $options->{allowed} || { '127.0.0.1' => '255.255.255.255' };
+ my $addr = $host ? inet_aton($host) : INADDR_ANY;
+ if ( $addr eq INADDR_ANY ) {
+ require Sys::Hostname;
+ $host = lc Sys::Hostname::hostname();
+ }
+ else {
+ $host = gethostbyaddr( $addr, AF_INET ) || inet_ntoa($addr);
+ }
+
+ # Handle requests
+
+ # Setup socket
+ my $daemon = IO::Socket::INET->new(
+ Listen => SOMAXCONN,
+ LocalAddr => inet_ntoa($addr),
+ LocalPort => $port,
+ Proto => 'tcp',
+ ReuseAddr => 1,
+ Type => SOCK_STREAM,
+ )
+ or die "Couldn't create daemon: $!";
+
+ my $url = "http://$host";
+ $url .= ":$port" unless $port == 80;
+
+ print "You can connect to your server at $url\n";
+
+ if ($options->{background}) {
+ open STDIN, "+</dev/null" or die $!;
+ open STDOUT, ">&STDIN" or die $!;
+ open STDERR, ">&STDIN" or die $!;
+ if ( $^O !~ /MSWin32/ ) {
+ require POSIX;
+ POSIX::setsid()
+ or die "Can't start a new session: $!";
+ }
+ }
+
+ if (my $pidfile = $options->{pidfile}) {
+ if (! open PIDFILE, "> $pidfile") {
+ warn("Cannot open: $pidfile: $!");
+ }
+ print PIDFILE "$$\n";
+ close PIDFILE;
+ }
+
+ my $pid = undef;
+
+ # Ignore broken pipes as an HTTP server should
+ local $SIG{PIPE} = 'IGNORE';
+
+ # Restart on HUP
+ local $SIG{HUP} = sub {
+ $restart = 1;
+ warn "Restarting server on SIGHUP...\n";
+ };
+
+ LISTEN:
+ while ( !$restart ) {
+ 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;
+ next LISTEN;
+ }
+
+ my ( $method, $uri, $protocol ) = $self->_parse_request_line;
+
+ next unless $method;
+
+ DEBUG && warn "Parsed request: $method $uri $protocol\n";
+
+ unless ( uc($method) eq 'RESTART' ) {
+
+ # Fork
+ if ( $options->{fork} ) {
+ if ( $pid = fork ) {
+ DEBUG && warn "Forked child $pid\n";
+ next;
+ }
+ }
+
+ $self->_handler( $class, $port, $method, $uri, $protocol );
+
+ if ( my $error = delete $self->{_write_error} ) {
+ close Remote;
+
+ if ( !defined $pid ) {
+ next LISTEN;
+ }
+ }
+
+ if ( defined $pid ) {
+ # Child process, close connection and exit
+ DEBUG && warn "Child process exiting\n";
+ $daemon->close;
+ exit;
+ }
+ }
+ else {
+ my $sockdata = $self->_socket_data( \*Remote );
+ my $ipaddr = _inet_addr( $sockdata->{peeraddr} );
+ my $ready = 0;
+ foreach my $ip ( keys %$allowed ) {
+ my $mask = $allowed->{$ip};
+ $ready = ( $ipaddr & _inet_addr($mask) ) == _inet_addr($ip);
+ last if $ready;
+ }
+ if ($ready) {
+ $restart = 1;
+ last;
+ }
+ }
+ }
+ continue {
+ close Remote;
+ }
+ }
+
+ $daemon->close;
+
+ DEBUG && warn "Shutting down\n";
+
+ if ($restart) {
+ $SIG{CHLD} = 'DEFAULT';
+ wait;
+
+ ### if the standalone server was invoked with perl -I .. we will loose
+ ### 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;
+
+ exec $^X, $0, @{ $options->{argv} };
+ }
+
+ exit;
+}
+
+sub _handler {
+ my ( $self, $class, $port, $method, $uri, $protocol ) = @_;
+
+ local *STDIN = \*Remote;
+ local *STDOUT = \*Remote;
+
+ # We better be careful and just use 1.0
+ $protocol = '1.0';
+
+ my $sockdata = $self->_socket_data( \*Remote );
+ my %copy_of_env = %ENV;
+
+ my $sel = IO::Select->new;
+ $sel->add( \*STDIN );
+
+ REQUEST:
+ while (1) {
+ my ( $path, $query_string ) = split /\?/, $uri, 2;
+
+ # Initialize CGI environment
+ local %ENV = (
+ 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,
+ SERVER_PROTOCOL => "HTTP/$protocol",
+ %copy_of_env,
+ );
+
+ # Parse headers
+ if ( $protocol >= 1 ) {
+ $self->_parse_headers;
+ }
+
+ # Pass flow control to Catalyst
+ $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} ) {
+
+ DEBUG && warn "Reusing previous connection for keep-alive request\n";
+
+ if ( $sel->can_read(1) ) {
+ if ( !$self->_read_headers ) {
+ # Error reading, give up
+ last REQUEST;
+ }
+
+ ( $method, $uri, $protocol ) = $self->_parse_request_line;
+
+ DEBUG && warn "Parsed request: $method $uri $protocol\n";
+
+ # Force HTTP/1.0
+ $protocol = '1.0';
+
+ next REQUEST;
+ }
+
+ DEBUG && warn "No keep-alive request within 1 second\n";
+ }
+
+ last REQUEST;
+ }
+
+ DEBUG && warn "Closing connection\n";
+
+ close Remote;
+}
+
+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 ) {
+ 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
+ if ( $self->{inputbuf} !~ s/^(\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);
+ HEADER:
+ while ( $buf =~ s/^([^\012]*)\012// ) {
+ $_ = $1;
+ s/\015$//;
+ if ( /^([\w\-~]+)\s*:\s*(.*)/ ) {
+ $headers->push_header( $key, $val ) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif ( /^\s+(.*)/ ) {
+ $val .= " $1";
+ }
+ else {
+ last HEADER;
+ }
+ }
+ $headers->push_header( $key, $val ) if $key;
+
+ DEBUG && warn "Parsed headers: " . dump($headers) . "\n";
+
+ # Convert headers into ENV vars
+ $headers->scan( sub {
+ my ( $key, $val ) = @_;
+
+ $key = uc $key;
+ $key = 'COOKIE' if $key eq 'COOKIES';
+ $key =~ tr/-/_/;
+ $key = 'HTTP_' . $key
+ unless $key =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
+
+ if ( exists $ENV{$key} ) {
+ $ENV{$key} .= ", $val";
+ }
+ else {
+ $ENV{$key} = $val;
+ }
+ } );
+}
+
+sub _socket_data {
+ my ( $self, $handle ) = @_;
+
+ my $remote_sockaddr = getpeername($handle);
+ my ( undef, $iaddr ) = $remote_sockaddr
+ ? sockaddr_in($remote_sockaddr)
+ : (undef, undef);
+
+ my $local_sockaddr = getsockname($handle);
+ my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
+
+ # 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',
+ localname => gethostbyaddr( $localiaddr, AF_INET ) || 'localhost',
+ localaddr => inet_ntoa($localiaddr) || '127.0.0.1',
+ };
+
+ return $data;
+}
+
+sub _inet_addr { unpack "N*", inet_aton( $_[0] ) }
+
+=head1 SEE ALSO
+
+L<Catalyst>, L<Catalyst::Engine>.
+
+=head1 AUTHORS
+
+Sebastian Riedel, <sri at cpan.org>
+
+Dan Kubb, <dan.kubb-cpan at onautopilot.com>
+
+Sascha Kiefer, <esskar at cpan.org>
+
+Andy Grundman, <andy at hybridized.org>
+
+=head1 THANKS
+
+Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Engine.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,684 @@
+package Catalyst::Engine;
+
+use strict;
+use base 'Class::Accessor::Fast';
+use CGI::Simple::Cookie;
+use Data::Dump qw/dump/;
+use Errno 'EWOULDBLOCK';
+use HTML::Entities;
+use HTTP::Body;
+use HTTP::Headers;
+use URI::QueryParam;
+use Scalar::Util ();
+
+# input position and length
+__PACKAGE__->mk_accessors(qw/read_position read_length/);
+
+# Stringify to class
+use overload '""' => sub { return ref shift }, fallback => 1;
+
+# Amount of data to read from input on each pass
+our $CHUNKSIZE = 64 * 1024;
+
+=head1 NAME
+
+Catalyst::Engine - The Catalyst Engine
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+
+=head2 $self->finalize_body($c)
+
+Finalize body. Prints the response output.
+
+=cut
+
+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' ) {
+ while ( !eof $body ) {
+ read $body, my ($buffer), $CHUNKSIZE;
+ last unless $self->write( $c, $buffer );
+ }
+ close $body;
+ }
+ else {
+ $self->write( $c, $body );
+ }
+}
+
+=head2 $self->finalize_cookies($c)
+
+Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
+response headers.
+
+=cut
+
+sub finalize_cookies {
+ my ( $self, $c ) = @_;
+
+ my @cookies;
+
+ foreach my $name ( keys %{ $c->response->cookies } ) {
+
+ my $val = $c->response->cookies->{$name};
+
+ my $cookie = (
+ Scalar::Util::blessed($val)
+ ? $val
+ : CGI::Simple::Cookie->new(
+ -name => $name,
+ -value => $val->{value},
+ -expires => $val->{expires},
+ -domain => $val->{domain},
+ -path => $val->{path},
+ -secure => $val->{secure} || 0
+ )
+ );
+
+ push @cookies, $cookie->as_string;
+ }
+
+ for my $cookie (@cookies) {
+ $c->res->headers->push_header( 'Set-Cookie' => $cookie );
+ }
+}
+
+=head2 $self->finalize_error($c)
+
+Output an apropriate 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.
+
+=cut
+
+sub finalize_error {
+ my ( $self, $c ) = @_;
+
+ $c->res->content_type('text/html; charset=utf-8');
+ my $name = $c->config->{name} || join(' ', split('::', ref $c));
+
+ my ( $title, $error, $infos );
+ if ( $c->debug ) {
+
+ # For pretty dumps
+ $error = join '', map {
+ '<p><code class="error">'
+ . encode_entities($_)
+ . '</code></p>'
+ } @{ $c->error };
+ $error ||= 'No output';
+ $error = qq{<pre wrap="">$error</pre>};
+ $title = $name = "$name on Catalyst $Catalyst::VERSION";
+ $name = "<h1>$name</h1>";
+
+ # Don't show context in the dump
+ delete $c->req->{_context};
+ delete $c->res->{_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};
+
+ my @infos;
+ my $i = 0;
+ for my $dump ( $c->dump_these ) {
+ my $name = $dump->[0];
+ my $value = encode_entities( dump( $dump->[1] ));
+ push @infos, sprintf <<"EOF", $name, $value;
+<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
+<div id="dump_$i">
+ <pre wrap="">%s</pre>
+</div>
+EOF
+ $i++;
+ }
+ $infos = join "\n", @infos;
+ }
+ else {
+ $title = $name;
+ $error = '';
+ $infos = <<"";
+<pre>
+(en) Please come back later
+(fr) SVP veuillez revenir plus tard
+(de) Bitte versuchen sie es spaeter nocheinmal
+(at) Konnten's bitt'schoen spaeter nochmal reinschauen
+(no) Vennligst prov igjen senere
+(dk) Venligst prov igen senere
+(pl) Prosze sprobowac pozniej
+</pre>
+
+ $name = '';
+ }
+ $c->res->body( <<"" );
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+<head>
+ <meta http-equiv="Content-Language" content="en" />
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+ <title>$title</title>
+ <script type="text/javascript">
+ <!--
+ function toggleDump (dumpElement) {
+ var e = document.getElementById( dumpElement );
+ if (e.style.display == "none") {
+ e.style.display = "";
+ }
+ else {
+ e.style.display = "none";
+ }
+ }
+ -->
+ </script>
+ <style type="text/css">
+ body {
+ font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
+ Tahoma, Arial, helvetica, sans-serif;
+ color: #333;
+ background-color: #eee;
+ margin: 0px;
+ padding: 0px;
+ }
+ :link, :link:hover, :visited, :visited:hover {
+ color: #000;
+ }
+ div.box {
+ position: relative;
+ background-color: #ccc;
+ border: 1px solid #aaa;
+ padding: 4px;
+ margin: 10px;
+ }
+ div.error {
+ background-color: #cce;
+ border: 1px solid #755;
+ padding: 8px;
+ margin: 4px;
+ margin-bottom: 10px;
+ }
+ div.infos {
+ background-color: #eee;
+ border: 1px solid #575;
+ padding: 8px;
+ margin: 4px;
+ margin-bottom: 10px;
+ }
+ div.name {
+ background-color: #cce;
+ border: 1px solid #557;
+ padding: 8px;
+ margin: 4px;
+ }
+ code.error {
+ display: block;
+ margin: 1em 0;
+ overflow: auto;
+ }
+ div.name h1, div.error p {
+ margin: 0;
+ }
+ h2 {
+ margin-top: 0;
+ margin-bottom: 10px;
+ font-size: medium;
+ font-weight: bold;
+ text-decoration: underline;
+ }
+ h1 {
+ font-size: medium;
+ font-weight: normal;
+ }
+ /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
+ /* Browser specific (not valid) styles to make preformatted text wrap */
+ pre {
+ white-space: pre-wrap; /* css-3 */
+ white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
+ white-space: -pre-wrap; /* Opera 4-6 */
+ white-space: -o-pre-wrap; /* Opera 7 */
+ word-wrap: break-word; /* Internet Explorer 5.5+ */
+ }
+ </style>
+</head>
+<body>
+ <div class="box">
+ <div class="error">$error</div>
+ <div class="infos">$infos</div>
+ <div class="name">$name</div>
+ </div>
+</body>
+</html>
+
+
+ # Trick IE
+ $c->res->{body} .= ( ' ' x 512 );
+
+ # Return 500
+ $c->res->status(500);
+}
+
+=head2 $self->finalize_headers($c)
+
+Abstract method, allows engines to write headers to response
+
+=cut
+
+sub finalize_headers { }
+
+=head2 $self->finalize_read($c)
+
+=cut
+
+sub finalize_read { }
+
+=head2 $self->finalize_uploads($c)
+
+Clean up after uploads, deleting temp files.
+
+=cut
+
+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);
+ }
+ }
+}
+
+=head2 $self->prepare_body($c)
+
+sets up the L<Catalyst::Request> object body using L<HTTP::Body>
+
+=cut
+
+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}
+ if exists $c->config->{uploadtmp};
+ }
+
+ while ( my $buffer = $self->read($c) ) {
+ $c->prepare_body_chunk($buffer);
+ }
+
+ # paranoia against wrong Content-Length header
+ my $remaining = $length - $self->read_position;
+ if ( $remaining > 0 ) {
+ $self->finalize_read($c);
+ Catalyst::Exception->throw(
+ "Wrong Content-Length value: $length" );
+ }
+ }
+ else {
+ # Defined but will cause all body code to be skipped
+ $c->request->{_body} = 0;
+ }
+}
+
+=head2 $self->prepare_body_chunk($c)
+
+Add a chunk to the request body.
+
+=cut
+
+sub prepare_body_chunk {
+ my ( $self, $c, $chunk ) = @_;
+
+ $c->request->{_body}->add($chunk);
+}
+
+=head2 $self->prepare_body_parameters($c)
+
+Sets up parameters from body.
+
+=cut
+
+sub prepare_body_parameters {
+ my ( $self, $c ) = @_;
+
+ return unless $c->request->{_body};
+
+ $c->request->body_parameters( $c->request->{_body}->param );
+}
+
+=head2 $self->prepare_connection($c)
+
+Abstract method implemented in engines.
+
+=cut
+
+sub prepare_connection { }
+
+=head2 $self->prepare_cookies($c)
+
+Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
+
+=cut
+
+sub prepare_cookies {
+ my ( $self, $c ) = @_;
+
+ if ( my $header = $c->request->header('Cookie') ) {
+ $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
+ }
+}
+
+=head2 $self->prepare_headers($c)
+
+=cut
+
+sub prepare_headers { }
+
+=head2 $self->prepare_parameters($c)
+
+sets up parameters from query and post parameters.
+
+=cut
+
+sub prepare_parameters {
+ my ( $self, $c ) = @_;
+
+ # 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;
+ }
+
+ # 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 ] }
+ }
+ else { $c->request->parameters->{$name} = $param }
+ }
+}
+
+=head2 $self->prepare_path($c)
+
+abstract method, implemented by engines.
+
+=cut
+
+sub prepare_path { }
+
+=head2 $self->prepare_request($c)
+
+=head2 $self->prepare_query_parameters($c)
+
+process the query string and extract query parameters.
+
+=cut
+
+sub prepare_query_parameters {
+ my ( $self, $c, $query_string ) = @_;
+
+ # Check for keywords (no = signs)
+ # (yes, index() is faster than a regex :))
+ if ( index( $query_string, '=' ) < 0 ) {
+ $c->request->query_keywords( $self->unescape_uri($query_string) );
+ return;
+ }
+
+ my %query;
+
+ # replace semi-colons
+ $query_string =~ s/;/&/g;
+
+ my @params = split /&/, $query_string;
+
+ for my $item ( @params ) {
+
+ my ($param, $value)
+ = map { $self->unescape_uri($_) }
+ split( /=/, $item, 2 );
+
+ $param = $self->unescape_uri($item) unless defined $param;
+
+ if ( exists $query{$param} ) {
+ if ( ref $query{$param} ) {
+ push @{ $query{$param} }, $value;
+ }
+ else {
+ $query{$param} = [ $query{$param}, $value ];
+ }
+ }
+ else {
+ $query{$param} = $value;
+ }
+ }
+
+ $c->request->query_parameters( \%query );
+}
+
+=head2 $self->prepare_read($c)
+
+prepare to read from the engine.
+
+=cut
+
+sub prepare_read {
+ my ( $self, $c ) = @_;
+
+ # Initialize the read position
+ $self->read_position(0);
+
+ # Initialize the amount of data we think we need to read
+ $self->read_length( $c->request->header('Content-Length') || 0 );
+}
+
+=head2 $self->prepare_request(@arguments)
+
+Populate the context object from the request object.
+
+=cut
+
+sub prepare_request { }
+
+=head2 $self->prepare_uploads($c)
+
+=cut
+
+sub prepare_uploads {
+ my ( $self, $c ) = @_;
+
+ return unless $c->request->{_body};
+
+ my $uploads = $c->request->{_body}->upload;
+ for 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} );
+ push @uploads, $u;
+ }
+ $c->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;
+ }
+ else {
+ $c->request->parameters->{$name} =
+ [ $c->request->parameters->{$name}, @filenames ];
+ }
+ }
+ else {
+ $c->request->parameters->{$name} =
+ @filenames > 1 ? \@filenames : $filenames[0];
+ }
+ }
+}
+
+=head2 $self->prepare_write($c)
+
+Abstract method. Implemented by the engines.
+
+=cut
+
+sub prepare_write { }
+
+=head2 $self->read($c, [$maxlength])
+
+=cut
+
+sub read {
+ my ( $self, $c, $maxlength ) = @_;
+
+ my $remaining = $self->read_length - $self->read_position;
+ $maxlength ||= $CHUNKSIZE;
+
+ # Are we done reading?
+ if ( $remaining <= 0 ) {
+ $self->finalize_read($c);
+ return;
+ }
+
+ my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
+ my $rc = $self->read_chunk( $c, my $buffer, $readlen );
+ if ( defined $rc ) {
+ $self->read_position( $self->read_position + $rc );
+ return $buffer;
+ }
+ else {
+ Catalyst::Exception->throw(
+ message => "Unknown error reading input: $!" );
+ }
+}
+
+=head2 $self->read_chunk($c, $buffer, $length)
+
+Each engine inplements read_chunk as its preferred way of reading a chunk
+of data.
+
+=cut
+
+sub read_chunk { }
+
+=head2 $self->read_length
+
+The length of input data to be read. This is obtained from the Content-Length
+header.
+
+=head2 $self->read_position
+
+The amount of input data that has already been read.
+
+=head2 $self->run($c)
+
+Start the engine. Implemented by the various engine classes.
+
+=cut
+
+sub run { }
+
+=head2 $self->write($c, $buffer)
+
+Writes the buffer to the client.
+
+=cut
+
+sub write {
+ my ( $self, $c, $buffer ) = @_;
+
+ unless ( $self->{_prepared_write} ) {
+ $self->prepare_write($c);
+ $self->{_prepared_write} = 1;
+ }
+
+ my $len = length($buffer);
+ my $wrote = syswrite STDOUT, $buffer;
+
+ if ( !defined $wrote && $! == EWOULDBLOCK ) {
+ # Unable to write on the first try, will retry in the loop below
+ $wrote = 0;
+ }
+
+ if ( defined $wrote && $wrote < $len ) {
+ # We didn't write the whole buffer
+ while (1) {
+ my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
+ if ( defined $ret ) {
+ $wrote += $ret;
+ }
+ else {
+ next if $! == EWOULDBLOCK;
+ return;
+ }
+
+ last if $wrote >= $len;
+ }
+ }
+
+ return $wrote;
+}
+
+=head2 $self->unescape_uri($uri)
+
+Unescapes a given URI using the most efficient method available. Engines such
+as Apache may implement this using Apache's C-based modules, for example.
+
+=cut
+
+sub unescape_uri {
+ my ( $self, $str ) = @_;
+
+ $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
+
+ return $str;
+}
+
+=head2 $self->finalize_output
+
+<obsolete>, see finalize_body
+
+=head1 AUTHORS
+
+Sebastian Riedel, <sri at cpan.org>
+
+Andy Grundman, <andy at hybridized.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Exception.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Exception.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Exception.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,64 @@
+package Catalyst::Exception;
+
+use strict;
+use vars qw[@ISA $CATALYST_EXCEPTION_CLASS];
+
+BEGIN {
+ push( @ISA, $CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base' );
+}
+
+package Catalyst::Exception::Base;
+
+use strict;
+use Carp ();
+
+=head1 NAME
+
+Catalyst::Exception - Catalyst Exception Class
+
+=head1 SYNOPSIS
+
+ Catalyst::Exception->throw( qq/Fatal exception/ );
+
+See also L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This is the Catalyst Exception class.
+
+=head1 METHODS
+
+=head2 throw( $message )
+
+=head2 throw( message => $message )
+
+=head2 throw( error => $error )
+
+Throws a fatal exception.
+
+=cut
+
+sub throw {
+ my $class = shift;
+ my %params = @_ == 1 ? ( error => $_[0] ) : @_;
+
+ my $message = $params{message} || $params{error} || $! || '';
+
+ local $Carp::CarpLevel = 1;
+
+ Carp::croak($message);
+}
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+Christian Hansen, C<ch at ngmedia.com>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Log.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Log.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Log.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,237 @@
+package Catalyst::Log;
+
+use strict;
+use base 'Class::Accessor::Fast';
+use Data::Dump;
+
+our %LEVELS = ();
+
+__PACKAGE__->mk_accessors('level');
+__PACKAGE__->mk_accessors('body');
+__PACKAGE__->mk_accessors('abort');
+
+{
+ my @levels = qw[ debug info warn error fatal ];
+
+ for ( my $i = 0 ; $i < @levels ; $i++ ) {
+
+ my $name = $levels[$i];
+ my $level = 1 << $i;
+
+ $LEVELS{$name} = $level;
+
+ no strict 'refs';
+
+ *{$name} = sub {
+ my $self = shift;
+
+ if ( $self->{level} & $level ) {
+ $self->_log( $name, @_ );
+ }
+ };
+
+ *{"is_$name"} = sub {
+ my $self = shift;
+ return $self->{level} & $level;
+ };
+ }
+}
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+ $self->levels( scalar(@_) ? @_ : keys %LEVELS );
+ return $self;
+}
+
+sub levels {
+ my ( $self, @levels ) = @_;
+ $self->level(0);
+ $self->enable(@levels);
+}
+
+sub enable {
+ my ( $self, @levels ) = @_;
+ $self->{level} |= $_ for map { $LEVELS{$_} } @levels;
+}
+
+sub disable {
+ my ( $self, @levels ) = @_;
+ $self->{level} &= ~$_ for map { $LEVELS{$_} } @levels;
+}
+
+sub _dump {
+ my $self = shift;
+ $self->info( Data::Dump::dump(@_) );
+}
+
+sub _log {
+ my $self = shift;
+ my $level = shift;
+ my $message = join( "\n", @_ );
+ $message .= "\n" unless $message =~ /\n$/;
+ $self->{body} .= sprintf( "[%s] %s", $level, $message );
+}
+
+sub _flush {
+ my $self = shift;
+ if ( $self->abort || !$self->body ) {
+ $self->abort(undef);
+ }
+ else {
+ $self->_send_to_log( $self->body );
+ }
+ $self->body(undef);
+}
+
+sub _send_to_log {
+ my $self = shift;
+ print STDERR @_;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catalyst::Log - Catalyst Log Class
+
+=head1 SYNOPSIS
+
+ $log = $c->log;
+ $log->debug($message);
+ $log->info($message);
+ $log->warn($message);
+ $log->error($message);
+ $log->fatal($message);
+
+ if ( $log->is_debug ) {
+ # expensive debugging
+ }
+
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This module provides the default, simple logging functionality for Catalyst.
+If you want something different set C<< $c->log >> in your application module,
+e.g.:
+
+ $c->log( MyLogger->new );
+
+Your logging object is expected to provide the interface described here.
+Good alternatives to consider are Log::Log4Perl and Log::Dispatch.
+
+If you want to be able to log arbitrary warnings, you can do something along
+the lines of
+
+ $SIG{__WARN__} = sub { MyApp->log->warn(@_); };
+
+however this is (a) global, (b) hairy and (c) may have unexpected side effects.
+Don't say we didn't warn you.
+
+=head1 LOG LEVELS
+
+=head2 debug
+
+ $log->is_debug;
+ $log->debug($message);
+
+=head2 info
+
+ $log->is_info;
+ $log->info($message);
+
+=head2 warn
+
+ $log->is_warn;
+ $log->warn($message);
+
+=head2 error
+
+ $log->is_error;
+ $log->error($message);
+
+=head2 fatal
+
+ $log->is_fatal;
+ $log->fatal($message);
+
+=head1 METHODS
+
+=head2 new
+
+Constructor. Defaults to enable all levels unless levels are provided in
+arguments.
+
+ $log = Catalyst::Log->new;
+ $log = Catalyst::Log->new( 'warn', 'error' );
+
+=head2 levels
+
+Set log levels
+
+ $log->levels( 'warn', 'error', 'fatal' );
+
+=head2 enable
+
+Enable log levels
+
+ $log->enable( 'warn', 'error' );
+
+=head2 disable
+
+Disable log levels
+
+ $log->disable( 'warn', 'error' );
+
+=head2 is_debug
+
+=head2 is_error
+
+=head2 is_fatal
+
+=head2 is_info
+
+=head2 is_warn
+
+Is the log level active?
+
+=head2 abort
+
+Should Catalyst emit logs for this request? Will be reset at the end of
+each request.
+
+*NOTE* This method is not compatible with other log apis, so if you plan
+to use Log4Perl or another logger, you should call it like this:
+
+ $c->log->abort(1) if $c->log->can('abort');
+
+=head2 _send_to_log
+
+ $log->_send_to_log( @messages );
+
+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.
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+Marcus Ramberg, C<mramberg at cpan.org>
+Christian Hansen, C<ch at ngmedia.com>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation/CentOS4.pod
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation/CentOS4.pod (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation/CentOS4.pod 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,377 @@
+=head1 NAME
+
+Catalyst::Manual::Installation::CentOS4 - Catalyst Installation on CentOS 4
+
+
+
+=head1 DESCRIPTION
+
+This document provides directions on how to install CentOS 4 (a rebuild
+of RedHat Enterprise 4) and then install Catalyst.
+
+If you already have a functioning install of CentOS, RHEL, or a
+comparable Linux OS, you should be able to skip this first section and
+go straight to the C<INSTALL CATALYST> section.
+
+B<NOTE:> You might want to consult the latest version of this document. It
+is available at:
+L<http://dev.catalyst.perl.org/repos/Catalyst/trunk/Catalyst-Runtime/lib/Catalyst/Manual/Installation/CentOS4.pod>
+
+
+
+=head1 INSTALL CENTOS
+
+These directions are written for CentOS 4.4 on an i386 machine; however,
+you can substitute other versions as they become available.
+
+
+=over 4
+
+=item *
+
+Go to L<http://isoredirect.centos.org/centos/4/isos/i386/> and click the
+nearest mirror.
+
+=item *
+
+Download C<CentOS-4.4-i386-bin1of4.iso> (you only need the first disk).
+
+=item *
+
+Burn the .iso to CD.
+
+=item *
+
+Insert the CD into your machine and power it up.
+
+=item *
+
+Hit C<Enter> at the C<boot:> prompt.
+
+=item *
+
+CD media test: you can either select C<OK> or C<Skip> depending on
+whether or not you trust your burn.
+
+=item *
+
+The installation GUI should start. Click next at the "Welcome to
+CentOS-4" screen.
+
+=item *
+
+Select a language and click C<Next>.
+
+=item *
+
+Select a keyboard configuration and click C<Next>.
+
+=item *
+
+Select C<Custom> for the installation type and click C<Next>.
+
+=item *
+
+Leave C<Automatically partition> selected on the C<Disk Partitioning
+Setup> and click C<Next>.
+
+=item *
+
+Uncheck C<Review (and modify if needed) the partitions created>, but
+leave the rest of the default settings on the C<Automatic Partitioning>
+screen. Then click C<Next>.
+
+=item *
+
+Click C<Yes> at the C<Are you sure you want to do this?> warning.
+
+=item *
+
+Click C<Next> on the C<Boot Loader Configuration> screen.
+
+=item *
+
+Update the C<Network Configuration> screen as necessary and click C<Next>.
+
+=item *
+
+Check C<Remote Login (SSH)> and click C<Next> on the C<Firewall
+Configuration> screen.
+
+=item *
+
+Select additional languages as necessary. Click C<Next>.
+
+=item *
+
+Select the appropriate time zone and click C<Next>.
+
+=item *
+
+Enter a root password and click C<Next>.
+
+=item *
+
+Scroll to the bottom of the C<Package Group Selection> screen and check
+C<Minimal> (the last option). Click C<Next>.
+
+=item *
+
+Click C<Next> at the C<About to Install> screen.
+
+=item *
+
+The installation will prepare the hard drive and then install the
+required rpm packages.
+
+=item *
+
+Once the installation completes, remove the CD and click C<Reboot>.
+
+=item *
+
+Type C<vi /etc/sysconfig/iptables> and add the following line as the
+third to last line of the file (I<above> the C<-A RH-Firewall-1-INPUT -j
+REJECT --reject-with icmp-host-prohibited> line):
+
+ -A RH-Firewall-1-INPUT -m state --state NEW -m tcp -p tcp --dport 3000 -j ACCEPT
+
+This will allow Catalyst to make use of port 3000 (the default for the
+development server).
+
+Type C<service iptables restart> to restart the iptables firewall using
+the updated configuration.
+
+=item *
+
+Type C<yum -y update> to retrieve the latest patches.
+
+=back
+
+
+=head1 INSTALL CATALYST
+
+=over 4
+
+=item *
+
+Type C<yum -y install gcc expat-devel sqlite3> to install several
+packages used by Catalyst.
+
+=item *
+
+Type the following:
+
+ $ perl -MCPAN -e shell
+
+ ...
+
+ Are you ready for manual configuration? [yes] yes
+ The following questions are intended to help you with the
+
+ ...
+
+ cpan shell -- CPAN exploration and modules installation (v1.7601)
+ ReadLine support available (try 'install Bundle::CPAN')
+
+ cpan> force install Module::Build
+
+ ...
+
+ cpan> quit
+
+=item *
+
+B<Note:> You need to have CPAN manually configured prior to running
+cat-install. As shown above, you should automatically receive
+a prompt for this when you first run C<perl -MCPAN -e shell>. You
+can re-run the configuration script by typing C<o conf init> at the
+C<cpanE<gt>> prompt.
+
+B<Optional:> The remaining steps of the installation could run
+significantly faster if you configure a fast mirror that uses HTTP vs.
+FTP (both transfer data at the same rate once the transfer is in
+progress, but HTTP connects much more quickly... and a Catalyst
+installation involves many connections). If you want to change the
+selection(s) you made during the "manual configuration" process above,
+you can manually add a single URL. To prepend a new URL to the B<front>
+of the list, use the C<unshift> option to C<o conf>:
+
+ cpan> o conf urllist unshift http://www.perl.com/CPAN/
+
+Where C<http://www.perl.com/CPAN/> is replaced by a nearby, HTTP-based
+mirror. You can get a list of all mirrors (including where they are
+located, their bandwidth, and their update frequency) at
+L<http://www.perl.com/CPAN/MIRRORED.BY>.
+
+Then, be sure to save your changes (or they will be lost the next
+time you restart the CPAN shell):
+
+ cpan> o conf commit
+
+You can view the current settings with C<o conf urllist> (or just
+C<o conf> to view all settings):
+
+ cpan> o conf urllist
+ urllist
+ http://www.perl.com/CPAN/
+ Type 'o conf' to view configuration edit options
+
+Note that multiple values can be entered for the C<urllist> option (the
+first entry will be used as long as it responds).
+
+=item *
+
+Review the C<cat-install> documentation from the
+L<http://www.shadowcatsystems.co.uk> web site:
+
+ If you want to get started quickly with Catalyst, Shadowcat provides an
+ installer script that will automate most of the process of installing it
+ for you. Please bear in mind that this script is currently considered
+ beta quality; we don't think it will eat your system but we make no
+ guarantee of that.
+
+ First, you'll need -
+
+ * Perl, 5.8.1+ (if you're on windows, get it from Active State)
+ * make of some sort. On unix/linux you should already have one. On
+ windows get nmake from Microsoft.
+ * A compiler. On unix/linux you should already have one. On windows,
+ get the latest Dev-C++ beta.
+ * All three of the above in your PATH for whatever shell you're using
+ * A configured CPAN.pm. perl -MCPAN -e shell should get CPAN to walk
+ you through the configuration process
+ * Module::Build. Active State kindly include this for you.
+
+ Ok, now that your environment is set up, download the installer from
+ this link, open a command prompt in the directory you downloaded it to
+ and run perl cat-install. By the time it exits, you should have a full
+ Catalyst install.
+
+ If anything goes wrong, please send the full build log and the output of
+ perl -V to cat-install (at) shadowcatsystems.co.uk so we can try and
+ resolve your issue.
+
+
+=item *
+
+Type C<wget http://www.shadowcatsystems.co.uk/static/cat-install> to
+retrieve a copy of the C<cat-install> script.
+
+=item *
+
+Type C<vi cat-install> to open the installer script, then insert the
+following lines at the bottom of the file (after the
+C<install('Catalyst');> line):
+
+ install('ExtUtils::ParseXS');
+ install('Digest::SHA1');
+ install('Digest::SHA');
+ install('DBIx::Class');
+ install('DBIx::Class::HTMLWidget');
+ install('Module::ScanDeps');
+ install('Module::CoreList');
+ install('PAR::Dist');
+ install('Archive::Tar');
+ install('Module::Install');
+ install('Catalyst::Devel');
+ install('Catalyst::Plugin::ConfigLoader');
+ install('Catalyst::Plugin::Session');
+ install('Catalyst::Plugin::Session::State::Cookie');
+ install('Catalyst::Plugin::Session::Store::FastMmap');
+ install('Catalyst::Plugin::Authorization::ACL');
+ install('Catalyst::Plugin::Authentication');
+ install('Catalyst::Plugin::Authorization::Roles');
+ install('Catalyst::Plugin::Authentication::Store::DBIC');
+ install('Catalyst::Plugin::DefaultEnd');
+ install('Catalyst::Plugin::StackTrace');
+ install('Catalyst::Plugin::Dumper');
+ install('Catalyst::Plugin::HTML::Widget');
+ install('Catalyst::Model::DBIC::Schema');
+ install('Catalyst::View::TT');
+ install('Test::WWW::Mechanize');
+ install('Test::WWW::Mechanize::Catalyst');
+ install('Test::Pod');
+ install('Test::Pod::Coverage');
+
+=item *
+
+Type C<perl cat-install>. It will take a while to complete.
+
+Tip: You may want to enable logging of the output that C<cat-install>
+generates as it runs -- it can be useful if you need to troubleshoot
+a failure. The log will generate almost 1 MB of output.
+
+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>
+was not able to automatically handle. You can address these by manually
+installing the dependency and then re-running C<perl cat-install>.
+
+In some cases you may wish to install an earlier version of a module. For
+example, say that the latest version of Module::Install is 0.64 and you
+want to install 0.63. The following command under C<perl -MCPAN -e shell>:
+
+ cpan> install A/AD/ADAMK/Module-Install-0.63.tar.gz
+
+=back
+
+You should now have a functioning Catalyst installation with the modules
+and plugins required to run the Catalyst tutorial.
+
+
+=head1 TESTING THE INSTALLATION
+
+=over 4
+
+=item *
+
+Download the tarball of the final tutorial application:
+
+ $ wget http://dev.catalyst.perl.org/repos/Catalyst/trunk/examples/Tutorial/Final_Tarball/MyApp.tgz
+
+=item *
+
+Untar it:
+
+ $ tar zxvf MyApp.tgz
+ $ cd MyApp
+
+=item *
+
+Run the tests:
+
+ $ CATALYST_DEBUG=0 prove --lib lib t
+ t/02pod...............skipped
+ all skipped: set TEST_POD to enable this test
+ t/03podcoverage.......skipped
+ all skipped: set TEST_POD to enable this test
+ t/01app...............ok
+ t/controller_Login....ok
+ t/live_app01..........ok 1/0[debug] ***Root::auto User not found, forwarding to /login
+ t/live_app01..........ok 2/0[debug] ***Root::auto User not found, forwarding to /login
+ t/live_app01..........ok 15/0[debug] ***Root::auto User not found, forwarding to /login
+ t/live_app01..........ok 16/0[debug] ***Root::auto User not found, forwarding to /login
+ t/live_app01..........ok
+ t/model_MyAppDB.......ok
+ All tests successful, 2 tests skipped.
+ Files=6, Tests=55, 11 wallclock secs ( 4.68 cusr + 4.84 csys = 9.52 CPU)
+
+You should see C<All tests successful>.
+
+=back
+
+
+
+=head1 AUTHOR
+
+Kennedy Clark, C<hkclark at gmail.com>
+
+Please report any errors, issues or suggestions to the author. The
+most recent version of the Catalyst Tutorial can be found at
+L<http://dev.catalyst.perl.org/repos/Catalyst/trunk/Catalyst-Runtime/lib/Catalyst/Manual/Tutorial/>.
+
+Copyright 2006, Kennedy Clark, under Creative Commons License
+(L<http://creativecommons.org/licenses/by-nc-sa/2.5/>).
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation.pod
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation.pod (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual/Installation.pod 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,152 @@
+=head1 NAME
+
+Catalyst::Manual::Installation - Catalyst Installation
+
+=head1 DESCRIPTION
+
+How to install Catalyst.
+
+=head1 INSTALLATION
+
+One of the frequent problems reported by new users of Catalyst is that
+it can be extremely time-consuming and difficult to install.
+
+One of the great strengths of Perl as a programming language is its use
+of CPAN, the Comprehensive Perl Archive Network, an enormous global
+repository containing over 10,000 free modules. For almost any basic
+task--and a very large number of non-basic ones--there is a module on
+CPAN that will help you. Catalyst has taken advantage of this, and uses
+a very large number of CPAN modules, rather than reinventing the wheel
+over and over again. On the one hand, Catalyst gains power and
+flexibility through this re-use of existing code. On the other hand,
+Catalyst's reliance on CPAN can complicate initial installations,
+especially in shared-hosting environments where you, the user, do not
+have easy control over what versions of other modules are installed.
+
+It is worth stressing that the difficulties found in installing Catalyst
+are caused not by anything intrinsic to Catalyst itself, but rather by
+the interrelated dependencies of a large number of required modules.
+
+Fortunately, there are a growing number of methods that can dramatically
+ease this undertaking. Note that for many of these, you will probably
+need to install additional Catalyst-related modules (especially plugins)
+to do the things you want. As of version 5.70, Catalyst has split into
+two packages, L<Catalyst::Runtime>, which includes the core elements
+necessary to deploy a Catalyst application, and L<Catalyst::Devel>,
+which includes the Helpers and other things necessary or useful for
+developing Catalyst applications. In a purely deployment environment
+you can omit L<Catalyst::Devel>.
+
+=over 4
+
+=item *
+
+Matt Trout's C<cat-install> script
+
+Available at L<http://www.shadowcatsystems.co.uk/static/cat-install>,
+C<cat-install> can be a quick and painless way to get Catalyst up and
+running on your system. Just download the script from the link above
+and type C<perl cat-install>. This script automates the process of
+installing Catalyst itself and its dependencies, with bits of overriding
+so that the process does not require user interaction. C<cat-install>
+installs Catalyst and its dependencies using the L<CPAN> module, so that
+modules are installed the same way you would probably install them
+normally--it just makes it easier. This is a recommended solution for
+installation.
+
+=item *
+
+Chris Laco's CatInABox
+
+CatInABox is a complete version of Catalyst that is installed locally on
+your system, so that you don't need to go through the effort of doing a
+full install. Simply download the tarball from
+L<http://handelframework.com/downloads/CatInABox.tar.gz> and unpack it
+on your machine. Depending on your OS platform, either run C<start.bat>
+or C<start.sh> to set your bin/PERLLIB paths. This tarball contains
+everything needed to try out Catalyst including Catalyst itself,
+Template Toolkit, several Authentication modules, StackTrace, and a few
+other plugins.
+
+A special Win32 version is available upon request that contains many
+more plugins and pre-compiled modules, including DBIx::Class, DBI,
+SQLite, and Session support. If you are interested in this version,
+please send e-mail to C<claco at chrislaco.com>.
+
+=item *
+
+Pre-Built VMWare Images
+
+Under the VMWare community program, work is ongoing to develop a number
+of VMWare images where an entire Catalyst development environment has
+already been installed, complete with database engines and a full
+complement of Catalyst plugins.
+
+=back
+
+=head2 OTHER METHODS
+
+In addition to the "all-in-one" approaches mentioned above, there are a
+variety of other installation techniques:
+
+=over 4
+
+=item *
+
+CPAN
+
+The traditional way to install Catalyst is directly from CPAN using the
+C<Task::Catalyst> bundle and C<Catalyst::Devel>:
+
+ $ perl -MCPAN -e 'install Task::Catalyst'
+ $ perl -MCPAN -e 'install Catalyst::Devel'
+
+Unless you have a particularly complete set of Perl modules already
+installed, be prepared for a large number of nested dependencies.
+
+=item *
+
+Gentoo Linux
+
+For users of Gentoo, see
+C<http://gentoo-wiki.com/HOWTO_Catalyst_Framework> for automated
+installations. In short, simply mount the portage overlay and type
+C<emerge catalystframework>.
+
+=item *
+
+FreeBSD
+
+FreeBSD users can get up and running quickly by typing C<cd
+/usr/ports/www/p5-Catalyst-Devel && make install>, or C<portinstall
+p5-Catalyst-Devel> if C<portinstall> is installed on your system.
+
+=item *
+
+Windows ActivePerl
+
+Windows users can take advantage of the PPM tool that comes with
+ActivePerl to jumpstart their Catalyst environment. Directions are
+available at L<http://catalyst.infogami.com/install/windows>.
+
+=item *
+
+Subversion Repository
+
+Catalyst uses Subversion for version control. To checkout the latest:
+
+ $ svn co http://dev.catalyst.perl.org/repos/Catalyst/trunk/Catalyst-Runtime/
+
+=back
+
+B<NOTE:> Although all of the above methods can be used to install a base
+Catalyst system, only the VMWare image is likely to have all of the
+plugins and modules you need to use Catalyst properly. When you start
+the C<script/myapp_server.pl> development server, it will tell you about
+any modules that are missing. To add them, type something along the
+lines of the following (C<Catalyst::Model::DBIC::Schema> is used here as
+a representative example):
+
+ # perl -MCPAN -e 'install Catalyst::Model::DBIC::Schema'
+ ...
+
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Manual.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,102 @@
+=head1 NAME
+
+Catalyst::Manual - User guide and reference for Catalyst
+
+=head1 DESCRIPTION
+
+This is the (table of contents page of the) comprehensive user guide and
+reference for Catalyst.
+
+=head1 IMPORTANT NOTE
+
+If you need to read the Catalyst Manual make sure that you have
+Catalyst::Manual installed from cpan. To check that it is installed
+run the following command from a unix (bash) prompt:
+
+ $ perldoc -t Catalyst::Manual::Tutorial::CatalystBasics 2>&1 >/dev/null && echo OK || echo MISSING
+
+If you see "OK" as the output, it's there, if you see "MISSING" you
+need to install the
+L<Catalyst::Manual|http://search.cpan.org/search?query=Catalyst%3A%3AManual&mode=dist>
+distribution.
+
+=over 4
+
+=item *
+
+L<Catalyst::Manual::About>
+
+Explanation (without code) of what Catalyst is and why to use it.
+
+=item *
+
+L<Catalyst::Manual::Intro>
+
+Introduction to Catalyst. This is a detailed, if unsystematic, look at
+the basic concepts of Catalyst and what the best practices are for
+writing applications with it.
+
+=item *
+
+L<Catalyst::Manual::Tutorial>
+
+A detailed step-by-step tutorial going through a single application
+thoroughly.
+
+=item *
+
+L<Catalyst::Manual::Plugins>
+
+Catalyst Plugins and Components. A brief look at some of the very many
+modules for extending Catalyst.
+
+=item *
+
+L<Catalyst::Manual::Cookbook>
+
+Cooking with Catalyst. Recipes and solutions that you might want to use
+in your code.
+
+=item *
+
+L<Catalyst::Manual::Installation>
+
+How to install Catalyst, in a variety of different ways. A closer look
+at one of the more difficult issues of using the framework--getting it.
+
+=item *
+
+L<Catalyst::Manual::WritingPlugins>
+
+Writing plugins for Catalyst; the use of L<NEXT>.
+
+=item *
+
+L<Catalyst::Manual::Internals>
+
+Here be dragons! A very brief explanation of the Catalyst request cycle,
+the major components of Catalyst, and how you can use this knowledge
+when writing applications under Catalyst.
+
+=back
+
+=head1 SUPPORT
+
+IRC:
+
+ Join #catalyst on irc.perl.org.
+
+Mailing-Lists:
+
+ http://lists.rawmode.org/mailman/listinfo/catalyst
+ http://lists.rawmode.org/mailman/listinfo/catalyst-dev
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at oook.de>
+Jesse Sheidlower, C<jester at panix.com>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it
+under the same terms as Perl itself.
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Model.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Model.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Model.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,34 @@
+package Catalyst::Model;
+
+use strict;
+use base qw/Catalyst::Component/;
+
+=head1 NAME
+
+Catalyst::Model - Catalyst Model base class
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+Catalyst Model base class.
+
+=head1 METHODS
+
+Implements the same methods as other Catalyst components, see
+L<Catalyst::Component>
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at oook.de>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request/Upload.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request/Upload.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request/Upload.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,179 @@
+package Catalyst::Request::Upload;
+
+use strict;
+use base '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/);
+
+sub new { shift->SUPER::new( ref( $_[0] ) ? $_[0] : {@_} ) }
+
+=head1 NAME
+
+Catalyst::Request::Upload - handles file upload requests
+
+=head1 SYNOPSIS
+
+ $upload->basename;
+ $upload->copy_to;
+ $upload->fh;
+ $upload->filename;
+ $upload->headers;
+ $upload->link_to;
+ $upload->size;
+ $upload->slurp;
+ $upload->tempname;
+ $upload->type;
+
+To specify where Catalyst should put the temporary files, set the 'uploadtmp'
+option in the Catalyst config. If unset, Catalyst will use the system temp dir.
+
+ __PACKAGE__->config( uploadtmp => '/path/to/tmpdir' );
+
+It is provided a way to have configurable temporary directory.
+If there is no config uploadtmp, system temprary directory will used.
+
+ __PACKAGE__->config( uploadtmp => '/path/to/tmpdir' );
+
+See also L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This class provides accessors and methods to handle client upload requests.
+
+=head1 METHODS
+
+=head2 $upload->new
+
+Simple constructor.
+
+=head2 $upload->copy_to
+
+Copies the temporary file using L<File::Copy>. Returns true for success,
+false for failure.
+
+ $upload->copy_to('/path/to/target');
+
+=cut
+
+sub copy_to {
+ my $self = shift;
+ return File::Copy::copy( $self->tempname, @_ );
+}
+
+=head2 $upload->fh
+
+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.
+
+=head2 $upload->headers
+
+Returns an L<HTTP::Headers> object for the request.
+
+=head2 $upload->link_to
+
+Creates a hard link to the temporary file. Returns true for success,
+false for failure.
+
+ $upload->link_to('/path/to/target');
+
+=cut
+
+sub link_to {
+ my ( $self, $target ) = @_;
+ return CORE::link( $self->tempname, $target );
+}
+
+=head2 $upload->size
+
+Returns the size of the uploaded file in bytes.
+
+=head2 $upload->slurp
+
+Returns a scalar containing the contents of the temporary file.
+
+=cut
+
+sub slurp {
+ my ( $self, $layer ) = @_;
+
+ unless ($layer) {
+ $layer = ':raw';
+ }
+
+ my $content = undef;
+ my $handle = $self->fh;
+
+ binmode( $handle, $layer );
+
+ while ( $handle->sysread( my $buffer, 8192 ) ) {
+ $content .= $buffer;
+ }
+
+ 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>.
+
+=head2 $upload->tempname
+
+Returns the path to the temporary file.
+
+=head2 $upload->type
+
+Returns the client-supplied Content-Type.
+
+=head1 AUTHORS
+
+Sebastian Riedel, C<sri at cpan.org>
+
+Christian Hansen, C<ch at ngmedia.com>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Request.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,578 @@
+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;
+
+__PACKAGE__->mk_accessors(
+ qw/action address arguments cookies headers query_keywords match method
+ protocol query_parameters secure captures uri user/
+);
+
+*args = \&arguments;
+*body_params = \&body_parameters;
+*input = \&body;
+*params = \¶meters;
+*query_params = \&query_parameters;
+*path_info = \&path;
+*snippets = \&captures;
+
+sub content_encoding { shift->headers->content_encoding(@_) }
+sub content_length { shift->headers->content_length(@_) }
+sub content_type { shift->headers->content_type(@_) }
+sub header { shift->headers->header(@_) }
+sub referer { shift->headers->referer(@_) }
+sub user_agent { shift->headers->user_agent(@_) }
+
+=head1 NAME
+
+Catalyst::Request - provides information about the current client request
+
+=head1 SYNOPSIS
+
+ $req = $c->request;
+ $req->action;
+ $req->address;
+ $req->arguments;
+ $req->args;
+ $req->base;
+ $req->body;
+ $req->body_parameters;
+ $req->content_encoding;
+ $req->content_length;
+ $req->content_type;
+ $req->cookie;
+ $req->cookies;
+ $req->header;
+ $req->headers;
+ $req->hostname;
+ $req->input;
+ $req->query_keywords;
+ $req->match;
+ $req->method;
+ $req->param;
+ $req->parameters;
+ $req->params;
+ $req->path;
+ $req->protocol;
+ $req->query_parameters;
+ $req->read;
+ $req->referer;
+ $req->secure;
+ $req->captures; # previously knows as snippets
+ $req->upload;
+ $req->uploads;
+ $req->uri;
+ $req->user;
+ $req->user_agent;
+
+See also L<Catalyst>, L<Catalyst::Request::Upload>.
+
+=head1 DESCRIPTION
+
+This is the Catalyst Request class, which provides an interface to data for the
+current client request. The request object is prepared by L<Catalyst::Engine>,
+thus hiding the details of the particular engine implementation.
+
+=head1 METHODS
+
+=head2 $req->action
+
+[DEPRECATED] Returns the name of the requested action.
+
+
+Use C<< $c->action >> instead (which returns a
+L<Catalyst::Action|Catalyst::Action> object).
+
+=head2 $req->address
+
+Returns the IP address of the client.
+
+=head2 $req->arguments
+
+Returns a reference to an array containing the arguments.
+
+ print $c->request->arguments->[0];
+
+For example, if your action was
+
+ package MyApp::C::Foo;
+
+ sub moose : Local {
+ ...
+ }
+
+and the URI for the request was C<http://.../foo/moose/bah>, the string C<bah>
+would be the first and only argument.
+
+=head2 $req->args
+
+Shortcut for arguments.
+
+=head2 $req->base
+
+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
+be either a scalar or an arrayref containing scalars.
+
+ print $c->request->body_parameters->{field};
+ 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.
+
+=head2 $req->content_length
+
+Shortcut for $req->headers->content_length.
+
+=head2 $req->content_type
+
+Shortcut for $req->headers->content_type.
+
+=head2 $req->cookie
+
+A convenient method to access $req->cookies.
+
+ $cookie = $c->request->cookie('name');
+ @cookies = $c->request->cookie;
+
+=cut
+
+sub cookie {
+ my $self = shift;
+
+ if ( @_ == 0 ) {
+ return keys %{ $self->cookies };
+ }
+
+ if ( @_ == 1 ) {
+
+ my $name = shift;
+
+ unless ( exists $self->cookies->{$name} ) {
+ return undef;
+ }
+
+ return $self->cookies->{$name};
+ }
+}
+
+=head2 $req->cookies
+
+Returns a reference to a hash containing the cookies.
+
+ print $c->request->cookies->{mycookie}->value;
+
+The cookies in the hash are indexed by name, and the values are L<CGI::Cookie>
+objects.
+
+=head2 $req->header
+
+Shortcut for $req->headers->header.
+
+=head2 $req->headers
+
+Returns an L<HTTP::Headers> object containing the headers for the current request.
+
+ print $c->request->headers->header('X-Catalyst');
+
+=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
+
+Alias for $req->body.
+
+=head2 $req->query_keywords
+
+Contains the keywords portion of a query string, when no '=' signs are
+present.
+
+ http://localhost/path?some+keywords
+
+ $c->request->query_keywords will contain 'some keywords'
+
+=head2 $req->match
+
+This contains the matching part of a Regex action. Otherwise
+it returns the same as 'action', except for default actions,
+which return an empty string.
+
+=head2 $req->method
+
+Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
+
+=head2 $req->param
+
+Returns GET and POST parameters with a CGI.pm-compatible param method. This
+is an alternative method for accessing parameters in $c->req->parameters.
+
+ $value = $c->request->param( 'foo' );
+ @values = $c->request->param( 'foo' );
+ @params = $c->request->param;
+
+Like L<CGI>, and B<unlike> earlier versions of Catalyst, passing multiple
+arguments to this method, like this:
+
+ $c->request->param( 'foo', 'bar', 'gorch', 'quxx' );
+
+will set the parameter C<foo> to the multiple values C<bar>, C<gorch> and
+C<quxx>. Previously this would have added C<bar> as another value to C<foo>
+(creating it if it didn't exist before), and C<quxx> as another value for
+C<gorch>.
+
+=cut
+
+sub param {
+ my $self = shift;
+
+ if ( @_ == 0 ) {
+ return keys %{ $self->parameters };
+ }
+
+ if ( @_ == 1 ) {
+
+ my $param = shift;
+
+ unless ( exists $self->parameters->{$param} ) {
+ return wantarray ? () : undef;
+ }
+
+ if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
+ return (wantarray)
+ ? @{ $self->parameters->{$param} }
+ : $self->parameters->{$param}->[0];
+ }
+ else {
+ return (wantarray)
+ ? ( $self->parameters->{$param} )
+ : $self->parameters->{$param};
+ }
+ }
+ elsif ( @_ > 1 ) {
+ my $field = shift;
+ $self->parameters->{$field} = [@_];
+ }
+}
+
+=head2 $req->parameters
+
+Returns a reference to a hash containing GET and POST parameters. Values can
+be either a scalar or an arrayref containing scalars.
+
+ print $c->request->parameters->{field};
+ print $c->request->parameters->{field}->[0];
+
+This is the combination of C<query_parameters> and C<body_parameters>.
+
+=head2 $req->params
+
+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>.
+
+=cut
+
+sub path {
+ my ( $self, @params ) = @_;
+
+ if (@params) {
+ $self->uri->path(@params);
+ undef $self->{path};
+ }
+ elsif ( defined( my $path = $self->{path} ) ) {
+ return $path;
+ }
+ else {
+ my $path = $self->uri->path;
+ my $location = $self->base->path;
+ $path =~ s/^(\Q$location\E)?//;
+ $path =~ s/^\///;
+ $self->{path} = $path;
+
+ return $path;
+ }
+}
+
+=head2 $req->protocol
+
+Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
+
+=head2 $req->query_parameters
+
+=head2 $req->query_params
+
+Returns a reference to a hash containing query string (GET) parameters. Values can
+be either a scalar or an arrayref containing scalars.
+
+ print $c->request->query_parameters->{field};
+ print $c->request->query_parameters->{field}->[0];
+
+=head2 $req->read( [$maxlength] )
+
+Reads a chunk of data from the request body. This method is intended to be
+used in a while loop, reading $maxlength bytes on every call. $maxlength
+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.
+
+=head2 $req->secure
+
+Returns true or false, indicating whether the connection is secure (https).
+
+=head2 $req->captures
+
+Returns a reference to an array containing regex captures.
+
+ my @captures = @{ $c->request->captures };
+
+=head2 $req->snippets
+
+C<captures> used to be called snippets. This is still available for backwoards
+compatibility, but is considered deprecated.
+
+=head2 $req->upload
+
+A convenient method to access $req->uploads.
+
+ $upload = $c->request->upload('field');
+ @uploads = $c->request->upload('field');
+ @fields = $c->request->upload;
+
+ for my $upload ( $c->request->upload('field') ) {
+ print $upload->filename;
+ }
+
+=cut
+
+sub upload {
+ my $self = shift;
+
+ if ( @_ == 0 ) {
+ return keys %{ $self->uploads };
+ }
+
+ if ( @_ == 1 ) {
+
+ my $upload = shift;
+
+ unless ( exists $self->uploads->{$upload} ) {
+ return wantarray ? () : undef;
+ }
+
+ if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
+ return (wantarray)
+ ? @{ $self->uploads->{$upload} }
+ : $self->uploads->{$upload}->[0];
+ }
+ else {
+ return (wantarray)
+ ? ( $self->uploads->{$upload} )
+ : $self->uploads->{$upload};
+ }
+ }
+
+ if ( @_ > 1 ) {
+
+ while ( my ( $field, $upload ) = splice( @_, 0, 2 ) ) {
+
+ if ( exists $self->uploads->{$field} ) {
+ for ( $self->uploads->{$field} ) {
+ $_ = [$_] unless ref($_) eq "ARRAY";
+ push( @$_, $upload );
+ }
+ }
+ else {
+ $self->uploads->{$field} = $upload;
+ }
+ }
+ }
+}
+
+=head2 $req->uploads
+
+Returns a reference to a hash containing uploads. Values can be either a
+L<Catalyst::Request::Upload> object, or an arrayref of
+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.
+
+=head2 $req->uri_with( { key => 'value' } );
+
+Returns a rewritten URI object for the current request. Key/value pairs
+passed in will override existing parameters. Unmodified pairs will be
+preserved.
+
+=cut
+
+sub uri_with {
+ my( $self, $args ) = @_;
+
+ carp( 'No arguments passed to uri_with()' ) unless $args;
+
+ for my $value ( values %$args ) {
+ next unless defined $value;
+ for ( ref $value eq 'ARRAY' ? @$value : $value ) {
+ $_ = "$_";
+ utf8::encode( $_ ) if utf8::is_utf8($_);
+ }
+ };
+
+ my $uri = $self->uri->clone;
+
+ $uri->query_form( {
+ %{ $uri->query_form_hash },
+ %$args
+ } );
+ return $uri;
+}
+
+=head2 $req->user
+
+Returns the currently logged in user. Deprecated. The method recommended for
+newer plugins is $c->user.
+
+=head2 $req->user_agent
+
+Shortcut to $req->headers->user_agent. Returns the user agent (browser)
+version string.
+
+=head1 AUTHORS
+
+Sebastian Riedel, C<sri at cpan.org>
+
+Marcus Ramberg, C<mramberg at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Response.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Response.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Response.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,157 @@
+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(@_) }
+
+=head1 NAME
+
+Catalyst::Response - stores output responding to the current client request
+
+=head1 SYNOPSIS
+
+ $res = $c->response;
+ $res->body;
+ $res->content_encoding;
+ $res->content_length;
+ $res->content_type;
+ $res->cookies;
+ $res->header;
+ $res->headers;
+ $res->output;
+ $res->redirect;
+ $res->status;
+ $res->write;
+
+=head1 DESCRIPTION
+
+This is the Catalyst Response class, which provides methods for responding to
+the current client request. The appropriate L<Catalyst::Engine> for your environment
+will turn the Catalyst::Response into a HTTP Response and return it to the client.
+
+=head1 METHODS
+
+=head2 $res->body(<$text|$fh|$iohandle_object)
+
+ $c->response->body('Catalyst rocks!');
+
+Sets or returns the output (text or binary data). If you are returning a large body,
+you might want to use a L<IO::Handle> type of object (Something that implements the read method
+in the same fashion), or a filehandle GLOB. Catalyst
+will write it piece by piece into the response.
+
+=head2 $res->content_encoding
+
+Shortcut for $res->headers->content_encoding.
+
+=head2 $res->content_length
+
+Shortcut for $res->headers->content_length.
+
+=head2 $res->content_type
+
+Shortcut for $res->headers->content_type.
+
+This value is typically set by your view or plugin. For example,
+L<Catalyst::Plugin::Static::Simple> will guess the mime type based on the file
+it found, while L<Catalyst::View::TT> defaults to C<text/html>.
+
+=head2 $res->cookies
+
+Returns a reference to a hash containing cookies to be set. The keys of the
+hash are the cookies' names, and their corresponding values are hash
+references used to construct a L<CGI::Cookie> object.
+
+ $c->response->cookies->{foo} = { value => '123' };
+
+The keys of the hash reference on the right correspond to the L<CGI::Cookie>
+parameters of the same name, except they are used without a leading dash.
+Possible parameters are:
+
+=over
+
+=item value
+
+=item expires
+
+=item domain
+
+=item path
+
+=item secure
+
+=back
+
+=head2 $res->header
+
+Shortcut for $res->headers->header.
+
+=head2 $res->headers
+
+Returns an L<HTTP::Headers> object, which can be used to set headers.
+
+ $c->response->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
+
+=head2 $res->output
+
+Alias for $res->body.
+
+=head2 $res->redirect( $url, $status )
+
+Causes the response to redirect to the specified URL.
+
+ $c->response->redirect( 'http://slashdot.org' );
+ $c->response->redirect( 'http://slashdot.org', 307 );
+
+=cut
+
+sub redirect {
+ my $self = shift;
+
+ if (@_) {
+ my $location = shift;
+ my $status = shift || 302;
+
+ $self->location($location);
+ $self->status($status);
+ }
+
+ return $self->location;
+}
+
+=head2 $res->status
+
+Sets or returns the HTTP status.
+
+ $c->response->status(404);
+
+=head2 $res->write( $data )
+
+Writes $data to the output stream.
+
+=cut
+
+sub write { shift->{_context}->write(@_); }
+
+=head1 AUTHORS
+
+Sebastian Riedel, C<sri at cpan.org>
+
+Marcus Ramberg, C<mramberg at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Runtime.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Runtime.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Runtime.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,35 @@
+package Catalyst::Runtime;
+
+use strict;
+use warnings;
+
+BEGIN { require 5.008001; }
+
+# Remember to update this in Catalyst as well!
+
+our $VERSION='5.7014';
+
+=head1 NAME
+
+Catalyst::Runtime - Catalyst Runtime version
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This is the primary class for the Catalyst-Runtime distribution, version 5.70.
+
+=head1 AUTHOR
+
+The Catalyst Core Team - see http://catalyst.perl.org/
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Stats.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Stats.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Stats.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,370 @@
+package Catalyst::Stats;
+
+use strict;
+use warnings;
+use Time::HiRes qw/gettimeofday tv_interval/;
+use Text::SimpleTable ();
+use Tree::Simple qw/use_weak_refs/;
+use Tree::Simple::Visitor::FindByUID;
+
+sub new {
+ my $class = shift;
+
+ 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;
+}
+
+sub profile {
+ my $self = shift;
+
+ return unless $self->{enabled};
+
+ my %params;
+ if (@_ <= 1) {
+ $params{comment} = shift || "";
+ }
+ elsif (@_ % 2 != 0) {
+ die "profile() requires a single comment parameter or a list of name-value pairs; found "
+ . (scalar @_) . " values: " . join(", ", @_);
+ }
+ else {
+ (%params) = @_;
+ $params{comment} ||= "";
+ }
+
+ my $parent;
+ my $prev;
+ my $t = [ gettimeofday ];
+
+ 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;
+ }
+ }
+ # 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});
+ }
+ 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;
+ }
+
+ my $node = Tree::Simple->new({
+ 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};
+
+ return $node->getUID;
+}
+
+sub elapsed {
+ return tv_interval(shift->{tree}->getNodeValue->{t});
+}
+
+sub report {
+ my $self = shift;
+
+# close any remaining open nodes
+ for (my $i = $#{$self->{stack}}; $i > 0; $i--) {
+ $self->profile(end => $self->{stack}->[$i]->getNodeValue->{action});
+ }
+
+ my $t = Text::SimpleTable->new( [ 62, 'Action' ], [ 9, 'Time' ] );
+ my @results;
+ $self->{tree}->traverse(
+ sub {
+ my $action = shift;
+ my $stat = $action->getNodeValue;
+ my @r = ( $action->getDepth,
+ ($stat->{action} || "") .
+ ($stat->{action} && $stat->{comment} ? " " : "") . ($stat->{comment} ? '- ' . $stat->{comment} : ""),
+ $stat->{elapsed},
+ $stat->{action} ? 1 : 0,
+ );
+ $t->row( ( q{ } x $r[0] ) . $r[1],
+ defined $r[2] ? sprintf("%fs", $r[2]) : '??');
+ push(@results, \@r);
+ }
+ );
+ return wantarray ? @results : $t->draw;
+}
+
+sub _get_uid {
+ my ($self, $uid) = @_;
+
+ my $visitor = Tree::Simple::Visitor::FindByUID->new;
+ $visitor->searchForUID($uid);
+ $self->{tree}->accept($visitor);
+ return $visitor->getResult;
+}
+
+
+sub accept {
+ my $self = shift;
+ $self->{tree}->accept( @_ );
+}
+
+sub addChild {
+ my $self = shift;
+ my $node = $_[ 0 ];
+
+ my $stat = $node->getNodeValue;
+
+ # do we need to fake $stat->{ t } ?
+ if( $stat->{ elapsed } ) {
+ # remove the "s" from elapsed time
+ $stat->{ elapsed } =~ s{s$}{};
+ }
+
+ $self->{tree}->addChild( @_ );
+}
+
+sub setNodeValue {
+ my $self = shift;
+ my $stat = $_[ 0 ];
+
+ # do we need to fake $stat->{ t } ?
+ if( $stat->{ elapsed } ) {
+ # remove the "s" from elapsed time
+ $stat->{ elapsed } =~ s{s$}{};
+ }
+
+ $self->{tree}->setNodeValue( @_ );
+}
+
+sub getNodeValue {
+ my $self = shift;
+ $self->{tree}->getNodeValue( @_ )->{ t };
+}
+
+sub traverse {
+ my $self = shift;
+ $self->{tree}->traverse( @_ );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catalyst::Stats - Catalyst Timing Statistics Class
+
+=head1 SYNOPSIS
+
+ $stats = $c->stats;
+ $stats->enable(1);
+ $stats->profile($comment);
+ $stats->profile(begin => $block_name, comment =>$comment);
+ $stats->profile(end => $block_name);
+ $elapsed = $stats->elapsed;
+ $report = $stats->report;
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This module provides the default, simple timing stats collection functionality for Catalyst.
+If you want something different set C<< MyApp->stats_class >> in your application module,
+e.g.:
+
+ __PACKAGE__->stats_class( "My::Stats" );
+
+If you write your own, your stats object is expected to provide the interface described here.
+
+Catalyst uses this class to report timings of component actions. You can add
+profiling points into your own code to get deeper insight. Typical usage might
+be like this:
+
+ sub mysub {
+ my ($c, ...) = @_;
+ $c->stats->profile(begin => "mysub");
+ # code goes here
+ ...
+ $c->stats->profile("starting critical bit");
+ # code here too
+ ...
+ $c->stats->profile("completed first part of critical bit");
+ # more code
+ ...
+ $c->stats->profile("completed second part of critical bit");
+ # more code
+ ...
+ $c->stats->profile(end => "mysub");
+ }
+
+Supposing mysub was called from the action "process" inside a Catalyst
+Controller called "service", then the reported timings for the above example
+might look something like this:
+
+ .----------------------------------------------------------------+-----------.
+ | Action | Time |
+ +----------------------------------------------------------------+-----------+
+ | /service/process | 1.327702s |
+ | mysub | 0.555555s |
+ | - starting critical bit | 0.111111s |
+ | - completed first part of critical bit | 0.333333s |
+ | - completed second part of critical bit | 0.111000s |
+ | /end | 0.000160s |
+ '----------------------------------------------------------------+-----------'
+
+which means mysub took 0.555555s overall, it took 0.111111s to reach the
+critical bit, the first part of the critical bit took 0.333333s, and the second
+part 0.111s.
+
+
+=head1 METHODS
+
+=head2 new
+
+Constructor.
+
+ $stats = Catalyst::Stats->new;
+
+=head2 enable
+
+ $stats->enable(0);
+ $stats->enable(1);
+
+Enable or disable stats collection. By default, stats are enabled after object creation.
+
+=head2 profile
+
+ $stats->profile($comment);
+ $stats->profile(begin => $block_name, comment =>$comment);
+ $stats->profile(end => $block_name);
+
+Marks a profiling point. These can appear in pairs, to time the block of code
+between the begin/end pairs, or by themselves, in which case the time of
+execution to the previous profiling point will be reported.
+
+The argument may be either a single comment string or a list of name-value
+pairs. Thus the following are equivalent:
+
+ $stats->profile($comment);
+ $stats->profile(comment => $comment);
+
+The following key names/values may be used:
+
+=over 4
+
+=item * begin => ACTION
+
+Marks the beginning of a block. The value is used in the description in the
+timing report.
+
+=item * end => ACTION
+
+Marks the end of the block. The name given must match a previous 'begin'.
+Correct nesting is recommended, although this module is tolerant of blocks that
+are not correctly nested, and the reported timings should accurately reflect the
+time taken to execute the block whether properly nested or not.
+
+=item * comment => COMMENT
+
+Comment string; use this to describe the profiling point. It is combined with
+the block action (if any) in the timing report description field.
+
+=item * uid => UID
+
+Assign a predefined unique ID. This is useful if, for whatever reason, you wish
+to relate a profiling point to a different parent than in the natural execution
+sequence.
+
+=item * parent => UID
+
+Explicitly relate the profiling point back to the parent with the specified UID.
+The profiling point will be ignored if the UID has not been previously defined.
+
+=back
+
+Returns the UID of the current point in the profile tree. The UID is
+automatically assigned if not explicitly given.
+
+=head2 elapsed
+
+ $elapsed = $stats->elapsed
+
+Get the total elapsed time (in seconds) since the object was created.
+
+=head2 report
+
+ print $stats->report ."\n";
+ $report = $stats->report;
+ @report = $stats->report;
+
+In scalar context, generates a textual report. In array context, returns the
+array of results where each row comprises:
+
+ [ depth, description, time, rollup ]
+
+The depth is the calling stack level of the profiling point.
+
+The description is a combination of the block name and comment.
+
+The time reported for each block is the total execution time for the block, and
+the time associated with each intermediate profiling point is the elapsed time
+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
+
+Some components might expect the stats object to be a regular Tree::Simple object.
+We've added some compatability methods to handle this scenario:
+
+=head2 accept
+
+=head2 addChild
+
+=head2 setNodeValue
+
+=head2 getNodeValue
+
+=head2 traverse
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=head1 AUTHOR
+
+Jon Schutz
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Test.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Test.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Test.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,199 @@
+package Catalyst::Test;
+
+use strict;
+use warnings;
+
+use Catalyst::Exception;
+use Catalyst::Utils;
+use Class::Inspector;
+
+=head1 NAME
+
+Catalyst::Test - Test Catalyst Applications
+
+=head1 SYNOPSIS
+
+ # Helper
+ script/test.pl
+
+ # Tests
+ use Catalyst::Test 'TestApp';
+ request('index.html');
+ get('index.html');
+
+ # Run tests against a remote server
+ CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/
+
+ # Tests with inline apps need to use Catalyst::Engine::Test
+ package TestApp;
+
+ use Catalyst;
+
+ sub foo : Global {
+ my ( $self, $c ) = @_;
+ $c->res->output('bar');
+ }
+
+ __PACKAGE__->setup();
+
+ package main;
+
+ use Test::More tests => 1;
+ use Catalyst::Test 'TestApp';
+
+ ok( get('/foo') =~ /bar/ );
+
+=head1 DESCRIPTION
+
+Test Catalyst Applications.
+
+=head2 METHODS
+
+=head2 get
+
+Returns the content.
+
+ my $content = get('foo/bar?test=1');
+
+Note that this method doesn't follow redirects, so to test for a
+correctly redirecting page you'll need to use a combination of this
+method and the L<request> method below:
+
+ my $res = request('/'); # redirects to /y
+ warn $res->header('location');
+ use URI;
+ my $uri = URI->new($res->header('location'));
+ is ( $uri->path , '/y');
+ my $content = get($uri->path);
+
+=head2 request
+
+Returns a C<HTTP::Response> object.
+
+ 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;
+}
+
+=head2 local_request
+
+=cut
+
+sub local_request {
+ my $class = shift;
+
+ require HTTP::Request::AsCGI;
+
+ my $request = Catalyst::Utils::request( shift(@_) );
+ my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
+
+ $class->handle_request;
+
+ return $cgi->restore->response;
+}
+
+my $agent;
+
+=head2 remote_request
+
+Do an actual remote request using LWP.
+
+=cut
+
+sub remote_request {
+
+ require LWP::UserAgent;
+
+ my $request = Catalyst::Utils::request( shift(@_) );
+ my $server = URI->new( $ENV{CATALYST_SERVER} );
+
+ if ( $server->path =~ m|^(.+)?/$| ) {
+ my $path = $1;
+ $server->path("$path") if $path; # need to be quoted
+ }
+
+ # the request path needs to be sanitised if $server is using a
+ # non-root path due to potential overlap between request path and
+ # response path.
+ if ($server->path) {
+ # If request path is '/', we have to add a trailing slash to the
+ # final request URI
+ my $add_trailing = $request->uri->path eq '/';
+
+ my @sp = split '/', $server->path;
+ my @rp = split '/', $request->uri->path;
+ shift @sp;shift @rp; # leading /
+ if (@rp) {
+ foreach my $sp (@sp) {
+ $sp eq $rp[0] ? shift @rp : last
+ }
+ }
+ $request->uri->path(join '/', @rp);
+
+ if ( $add_trailing ) {
+ $request->uri->path( $request->uri->path . '/' );
+ }
+ }
+
+ $request->uri->scheme( $server->scheme );
+ $request->uri->host( $server->host );
+ $request->uri->port( $server->port );
+ $request->uri->path( $server->path . $request->uri->path );
+
+ unless ($agent) {
+
+ $agent = LWP::UserAgent->new(
+ keep_alive => 1,
+ max_redirect => 0,
+ timeout => 60,
+ );
+
+ $agent->env_proxy;
+ }
+
+ return $agent->request($request);
+}
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Utils.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Utils.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/Utils.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,344 @@
+package Catalyst::Utils;
+
+use strict;
+use Catalyst::Exception;
+use File::Spec;
+use HTTP::Request;
+use Path::Class;
+use URI;
+use Class::Inspector;
+use Carp qw/croak/;
+
+=head1 NAME
+
+Catalyst::Utils - The Catalyst Utils
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 appprefix($class)
+
+ MyApp::Foo becomes myapp_foo
+
+=cut
+
+sub appprefix {
+ my $class = shift;
+ $class =~ s/::/_/g;
+ $class = lc($class);
+ return $class;
+}
+
+=head2 class2appclass($class);
+
+ MyApp::Controller::Foo::Bar becomes MyApp
+ My::App::Controller::Foo::Bar becomes My::App
+
+=cut
+
+sub class2appclass {
+ my $class = shift || '';
+ my $appname = '';
+ if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
+ $appname = $1;
+ }
+ return $appname;
+}
+
+=head2 class2classprefix($class);
+
+ MyApp::Controller::Foo::Bar becomes MyApp::Controller
+ My::App::Controller::Foo::Bar becomes My::App::Controller
+
+=cut
+
+sub class2classprefix {
+ my $class = shift || '';
+ my $prefix;
+ if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
+ $prefix = $1;
+ }
+ return $prefix;
+}
+
+=head2 class2classsuffix($class);
+
+ MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
+
+=cut
+
+sub class2classsuffix {
+ my $class = shift || '';
+ my $prefix = class2appclass($class) || '';
+ $class =~ s/$prefix\:://;
+ return $class;
+}
+
+=head2 class2env($class);
+
+Returns the environment name for class.
+
+ MyApp becomes MYAPP
+ My::App becomes MY_APP
+
+=cut
+
+sub class2env {
+ my $class = shift || '';
+ $class =~ s/::/_/g;
+ return uc($class);
+}
+
+=head2 class2prefix( $class, $case );
+
+Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
+
+ My::App::Controller::Foo::Bar becomes foo/bar
+
+=cut
+
+sub class2prefix {
+ my $class = shift || '';
+ my $case = shift || 0;
+ my $prefix;
+ if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
+ $prefix = $case ? $2 : lc $2;
+ $prefix =~ s{::}{/}g;
+ }
+ return $prefix;
+}
+
+=head2 class2tempdir( $class [, $create ] );
+
+Returns a tempdir for a class. If create is true it will try to create the path.
+
+ My::App becomes /tmp/my/app
+ My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
+
+=cut
+
+sub class2tempdir {
+ my $class = shift || '';
+ my $create = shift || 0;
+ my @parts = split '::', lc $class;
+
+ my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
+
+ if ( $create && !-e $tmpdir ) {
+
+ eval { $tmpdir->mkpath };
+
+ if ($@) {
+ Catalyst::Exception->throw(
+ message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
+ }
+ }
+
+ return $tmpdir->stringify;
+}
+
+=head2 home($class)
+
+Returns home directory for given class.
+
+=cut
+
+sub home {
+ my $class = shift;
+
+ # make an $INC{ $key } style string from the class name
+ (my $file = "$class.pm") =~ s{::}{/}g;
+
+ if ( my $inc_entry = $INC{$file} ) {
+ {
+ # look for an uninstalled Catalyst app
+
+ # find the @INC entry in which $file was found
+ (my $path = $inc_entry) =~ s/$file$//;
+ my $home = dir($path)->absolute->cleanup;
+
+ # pop off /lib and /blib if they're there
+ $home = $home->parent while $home =~ /b?lib$/;
+
+ # only return the dir if it has a Makefile.PL or Build.PL
+ if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
+
+ # clean up relative path:
+ # MyApp/script/.. -> MyApp
+
+ my $dir;
+ my @dir_list = $home->dir_list();
+ while (($dir = pop(@dir_list)) && $dir eq '..') {
+ $home = dir($home)->parent->parent;
+ }
+
+ return $home->stringify;
+ }
+ }
+
+ {
+ # look for an installed Catalyst app
+
+ # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
+ ( my $path = $inc_entry) =~ s/\.pm$//;
+ my $home = dir($path)->absolute->cleanup;
+
+ # return if if it's a valid directory
+ return $home->stringify if -d $home;
+ }
+ }
+
+ # we found nothing
+ return 0;
+}
+
+=head2 prefix($class, $name);
+
+Returns a prefixed action.
+
+ MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
+
+=cut
+
+sub prefix {
+ my ( $class, $name ) = @_;
+ my $prefix = &class2prefix($class);
+ $name = "$prefix/$name" if $prefix;
+ return $name;
+}
+
+=head2 request($uri)
+
+Returns an L<HTTP::Request> object for a uri.
+
+=cut
+
+sub request {
+ my $request = shift;
+ unless ( ref $request ) {
+ if ( $request =~ m/^http/i ) {
+ $request = URI->new($request);
+ }
+ else {
+ $request = URI->new( 'http://localhost' . $request );
+ }
+ }
+ unless ( ref $request eq 'HTTP::Request' ) {
+ $request = HTTP::Request->new( 'GET', $request );
+ }
+ return $request;
+}
+
+=head2 ensure_class_loaded($class_name, \%opts)
+
+Loads the class unless it already has been loaded.
+
+If $opts{ignore_loaded} is true always tries the require whether the package
+already exists or not. Only pass this if you're either (a) sure you know the
+file exists on disk or (b) have code to catch the file not found exception
+that will result if it doesn't.
+
+=cut
+
+sub ensure_class_loaded {
+ my $class = shift;
+ my $opts = shift;
+
+ croak "Malformed class Name $class"
+ if $class =~ m/(?:\b\:\b|\:{3,})/;
+
+ croak "Malformed class Name $class"
+ if $class =~ m/[^\w:]/;
+
+ croak "ensure_class_loaded should be given a classname, not a filename ($class)"
+ if $class =~ m/\.pm$/;
+
+ return if !$opts->{ ignore_loaded }
+ && Class::Inspector->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;
+ {
+ local $@;
+ my $file = $class . '.pm';
+ $file =~ s{::}{/}g;
+ eval { CORE::require($file) };
+ $error = $@;
+ }
+
+ die $error if $error;
+ die "require $class was successful but the package is not defined"
+ unless Class::Inspector->loaded($class);
+
+ return 1;
+}
+
+=head2 merge_hashes($hashref, $hashref)
+
+Base code to recursively merge two hashes together with right-hand precedence.
+
+=cut
+
+sub merge_hashes {
+ my ( $lefthash, $righthash ) = @_;
+
+ return $lefthash unless defined $righthash;
+
+ my %merged = %$lefthash;
+ for my $key ( keys %$righthash ) {
+ my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
+ my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
+ if( $right_ref and $left_ref ) {
+ $merged{ $key } = merge_hashes(
+ $lefthash->{ $key }, $righthash->{ $key }
+ );
+ }
+ else {
+ $merged{ $key } = $righthash->{ $key };
+ }
+ }
+
+ return \%merged;
+}
+
+=head2 env_value($class, $key)
+
+Checks for and returns an environment value. For instance, if $key is
+'home', then this method will check for and return the first value it finds,
+looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
+
+=cut
+
+sub env_value {
+ my ( $class, $key ) = @_;
+
+ $key = uc($key);
+ my @prefixes = ( class2env($class), 'CATALYST' );
+
+ for my $prefix (@prefixes) {
+ if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
+ return $value;
+ }
+ }
+
+ return;
+}
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at cpan.org>
+Yuval Kogman, C<nothingmuch at woobling.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/View.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/View.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst/View.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,67 @@
+package Catalyst::View;
+
+use strict;
+use base qw/Catalyst::Component/;
+
+=head1 NAME
+
+Catalyst::View - Catalyst View base class
+
+=head1 SYNOPSIS
+
+ package Catalyst::View::Homebrew;
+
+ use base qw/Catalyst::View/;
+
+ sub process {
+ # template processing goes here.
+ }
+
+=head1 DESCRIPTION
+
+This is the Catalyst View base class. It's meant to be used as
+a base class by Catalyst views.
+
+As a convention, views are expected to read template names from
+$c->stash->{template}, and put the output into $c->res->body.
+Some views default to render a template named after the dispatched
+action's private name. (See L<Catalyst::Action>.)
+
+=head1 METHODS
+
+Implements the same methods as other Catalyst components, see
+L<Catalyst::Component>
+
+=head2 process
+
+gives an error message about direct use.
+
+=cut
+
+sub process {
+
+ Catalyst::Exception->throw( message => ( ref $_[0] || $_[0] ).
+ " directly inherits from Catalyst::View. You need to\n".
+ " inherit from a subclass like Catalyst::View::TT instead.\n" );
+
+}
+
+=head2 $c->merge_hash_config( $hashref, $hashref )
+
+Merges two hashes together recursively, giving right-hand precedence.
+
+=cut
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at oook.de>
+Marcus Ramberg, C<mramberg at cpan.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/lib/Catalyst.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,2439 @@
+package Catalyst;
+
+use strict;
+use base 'Catalyst::Component';
+use bytes;
+use Catalyst::Exception;
+use Catalyst::Log;
+use Catalyst::Request;
+use Catalyst::Request::Upload;
+use Catalyst::Response;
+use Catalyst::Utils;
+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 attributes;
+use utf8;
+use Carp qw/croak carp/;
+
+BEGIN { require 5.008001; }
+
+__PACKAGE__->mk_accessors(
+ qw/counter request response state action stack namespace stats/
+);
+
+sub depth { scalar @{ shift->stack || [] }; }
+
+# Laziness++
+*comp = \&component;
+*req = \&request;
+*res = \&response;
+
+# For backwards compatibility
+*finalize_output = \&finalize_body;
+
+# For statistics
+our $COUNT = 1;
+our $START = time;
+our $RECURSION = 1000;
+our $DETACH = "catalyst_detach\n";
+
+__PACKAGE__->mk_classdata($_)
+ for qw/components arguments dispatcher engine log dispatcher_class
+ engine_class context_class request_class response_class stats_class
+ setup_finished/;
+
+__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
+__PACKAGE__->engine_class('Catalyst::Engine::CGI');
+__PACKAGE__->request_class('Catalyst::Request');
+__PACKAGE__->response_class('Catalyst::Response');
+__PACKAGE__->stats_class('Catalyst::Stats');
+
+# Remember to update this in Catalyst::Runtime as well!
+
+our $VERSION = '5.7014';
+
+sub import {
+ my ( $class, @arguments ) = @_;
+
+ # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
+ # callers @ISA.
+ return unless $class eq 'Catalyst';
+
+ my $caller = caller(0);
+
+ unless ( $caller->isa('Catalyst') ) {
+ no strict 'refs';
+ push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
+ }
+
+ $caller->arguments( [@arguments] );
+ $caller->setup_home;
+}
+
+=head1 NAME
+
+Catalyst - The Elegant MVC Web Application Framework
+
+=head1 SYNOPSIS
+
+See the L<Catalyst::Manual> distribution for comprehensive
+documentation and tutorials.
+
+ # Install Catalyst::Devel for helpers and other development tools
+ # use the helper to create a new application
+ catalyst.pl MyApp
+
+ # add models, views, controllers
+ script/myapp_create.pl model MyDatabase DBIC::Schema create=dynamic dbi:SQLite:/path/to/db
+ script/myapp_create.pl view MyTemplate TT
+ script/myapp_create.pl controller Search
+
+ # built in testserver -- use -r to restart automatically on changes
+ # --help to see all available options
+ script/myapp_server.pl
+
+ # command line testing interface
+ script/myapp_test.pl /yada
+
+ ### in lib/MyApp.pm
+ use Catalyst qw/-Debug/; # include plugins here as well
+
+ ### In lib/MyApp/Controller/Root.pm (autocreated)
+ sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
+ my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
+ $c->stash->{template} = 'foo.tt'; # set the template
+ # lookup something from db -- stash vars are passed to TT
+ $c->stash->{data} =
+ $c->model('Database::Foo')->search( { country => $args[0] } );
+ if ( $c->req->params->{bar} ) { # access GET or POST parameters
+ $c->forward( 'bar' ); # process another action
+ # do something else after forward returns
+ }
+ }
+
+ # The foo.tt TT template can use the stash data from the database
+ [% WHILE (item = data.next) %]
+ [% item.foo %]
+ [% END %]
+
+ # called for /bar/of/soap, /bar/of/soap/10, etc.
+ sub bar : Path('/bar/of/soap') { ... }
+
+ # called for all actions, from the top-most controller downwards
+ sub auto : Private {
+ my ( $self, $c ) = @_;
+ if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
+ $c->res->redirect( '/login' ); # require login
+ return 0; # abort request and go immediately to end()
+ }
+ return 1; # success; carry on to next action
+ }
+
+ # called after all actions are finished
+ sub end : Private {
+ my ( $self, $c ) = @_;
+ if ( scalar @{ $c->error } ) { ... } # handle errors
+ return if $c->res->body; # already have a response
+ $c->forward( 'MyApp::View::TT' ); # render template
+ }
+
+ ### in MyApp/Controller/Foo.pm
+ # called for /foo/bar
+ sub bar : Local { ... }
+
+ # called for /blargle
+ sub blargle : Global { ... }
+
+ # an index action matches /foo, but not /foo/1, etc.
+ sub index : Private { ... }
+
+ ### in MyApp/Controller/Foo/Bar.pm
+ # called for /foo/bar/baz
+ sub baz : Local { ... }
+
+ # first Root auto is called, then Foo auto, then this
+ sub auto : Private { ... }
+
+ # powerful regular expression paths are also possible
+ sub details : Regex('^product/(\w+)/details$') {
+ my ( $self, $c ) = @_;
+ # extract the (\w+) from the URI
+ my $product = $c->req->captures->[0];
+ }
+
+See L<Catalyst::Manual::Intro> for additional information.
+
+=head1 DESCRIPTION
+
+Catalyst is a modern framework for making web applications without the
+pain usually associated with this process. This document is a reference
+to the main Catalyst application. If you are a new user, we suggest you
+start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
+
+See L<Catalyst::Manual> for more documentation.
+
+Catalyst plugins can be loaded by naming them as arguments to the "use
+Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
+plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
+C<My::Module>.
+
+ use Catalyst qw/My::Module/;
+
+If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
+fully qualify the name by using a unary plus:
+
+ use Catalyst qw/
+ My::Module
+ +Fully::Qualified::Plugin::Name
+ /;
+
+Special flags like C<-Debug> and C<-Engine> can also be specified as
+arguments when Catalyst is loaded:
+
+ use Catalyst qw/-Debug My::Module/;
+
+The position of plugins and flags in the chain is important, because
+they are loaded in the order in which they appear.
+
+The following flags are supported:
+
+=head2 -Debug
+
+Enables debug output. You can also force this setting from the system
+environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
+settings override the application, with <MYAPP>_DEBUG having the highest
+priority.
+
+=head2 -Engine
+
+Forces Catalyst to use a specific engine. Omit the
+C<Catalyst::Engine::> prefix of the engine name, i.e.:
+
+ use Catalyst qw/-Engine=CGI/;
+
+=head2 -Home
+
+Forces Catalyst to use a specific home directory, e.g.:
+
+ use Catalyst qw[-Home=/usr/mst];
+
+This can also be done in the shell environment by setting either the
+C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
+is replaced with the uppercased name of your application, any "::" in
+the name will be replaced with underscores, e.g. MyApp::Web should use
+MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
+
+=head2 -Log
+
+Specifies log level.
+
+=head2 -Stats
+
+Enables statistics collection and reporting. You can also force this setting
+from the system environment with CATALYST_STATS or <MYAPP>_STATS. The
+environment settings override the application, with <MYAPP>_STATS having the
+highest priority.
+
+e.g.
+
+ use Catalyst qw/-Stats=1/
+
+=head1 METHODS
+
+=head2 INFORMATION ABOUT THE CURRENT REQUEST
+
+=head2 $c->action
+
+Returns a L<Catalyst::Action> object for the current action, which
+stringifies to the action name. See L<Catalyst::Action>.
+
+=head2 $c->namespace
+
+Returns the namespace of the current action, i.e., the URI prefix
+corresponding to the controller of the current action. For example:
+
+ # in Controller::Foo::Bar
+ $c->namespace; # returns 'foo/bar';
+
+=head2 $c->request
+
+=head2 $c->req
+
+Returns the current L<Catalyst::Request> object, giving access to
+information about the current client request (including parameters,
+cookies, HTTP headers, etc.). See L<Catalyst::Request>.
+
+=head2 REQUEST FLOW HANDLING
+
+=head2 $c->forward( $action [, \@arguments ] )
+
+=head2 $c->forward( $class, $method, [, \@arguments ] )
+
+Forwards processing to another action, by its private name. If you give a
+class name but no method, C<process()> is called. You may also optionally
+pass arguments in an arrayref. The action will receive the arguments in
+C<@_> and C<< $c->req->args >>. Upon returning from the function,
+C<< $c->req->args >> will be restored to the previous values.
+
+Any data C<return>ed from the action forwarded to, will be returned by the
+call to forward.
+
+ my $foodata = $c->forward('/foo');
+ $c->forward('index');
+ $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
+ $c->forward('MyApp::View::TT');
+
+Note that forward implies an C<<eval { }>> around the call (actually
+C<execute> does), thus de-fatalizing all 'dies' within the called
+action. If you want C<die> to propagate you need to do something like:
+
+ $c->forward('foo');
+ die $c->error if $c->error;
+
+Or make sure to always return true values from your actions and write
+your code like this:
+
+ $c->forward('foo') || return;
+
+=cut
+
+sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
+
+=head2 $c->detach( $action [, \@arguments ] )
+
+=head2 $c->detach( $class, $method, [, \@arguments ] )
+
+=head2 $c->detach()
+
+The same as C<forward>, but doesn't return to the previous action when
+processing is finished.
+
+When called with no arguments it escapes the processing chain entirely.
+
+=cut
+
+sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
+
+=head2 $c->response
+
+=head2 $c->res
+
+Returns the current L<Catalyst::Response> object, see there for details.
+
+=head2 $c->stash
+
+Returns a hashref to the stash, which may be used to store data and pass
+it between components during a request. You can also set hash keys by
+passing arguments. The stash is automatically sent to the view. The
+stash is cleared at the end of a request; it cannot be used for
+persistent storage (for this you must use a session; see
+L<Catalyst::Plugin::Session> for a complete system integrated with
+Catalyst).
+
+ $c->stash->{foo} = $bar;
+ $c->stash( { moose => 'majestic', qux => 0 } );
+ $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
+
+ # stash is automatically passed to the view for use in a template
+ $c->forward( 'MyApp::View::TT' );
+
+=cut
+
+sub stash {
+ my $c = shift;
+ 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};
+ }
+ }
+ return $c->{stash};
+}
+
+=head2 $c->error
+
+=head2 $c->error($error, ...)
+
+=head2 $c->error($arrayref)
+
+Returns an arrayref containing error messages. If Catalyst encounters an
+error while processing a request, it stores the error in $c->error. This
+method should only be used to store fatal error messages.
+
+ my @error = @{ $c->error };
+
+Add a new error.
+
+ $c->error('Something bad happened');
+
+=cut
+
+sub error {
+ my $c = shift;
+ if ( $_[0] ) {
+ my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
+ croak @$error unless ref $c;
+ push @{ $c->{error} }, @$error;
+ }
+ elsif ( defined $_[0] ) { $c->{error} = undef }
+ return $c->{error} || [];
+}
+
+
+=head2 $c->state
+
+Contains the return value of the last executed action.
+
+=head2 $c->clear_errors
+
+Clear errors. You probably don't want to clear the errors unless you are
+implementing a custom error screen.
+
+This is equivalent to running
+
+ $c->error(0);
+
+=cut
+
+sub clear_errors {
+ my $c = shift;
+ $c->error(0);
+}
+
+
+# search via regex
+sub _comp_search {
+ my ( $c, @names ) = @_;
+
+ foreach my $name (@names) {
+ foreach my $component ( keys %{ $c->components } ) {
+ return $c->components->{$component} if $component =~ /$name/i;
+ }
+ }
+
+ return undef;
+}
+
+# try explicit component names
+sub _comp_explicit {
+ my ( $c, @names ) = @_;
+
+ foreach my $try (@names) {
+ return $c->components->{$try} if ( exists $c->components->{$try} );
+ }
+
+ return undef;
+}
+
+# like component, but try just these prefixes before regex searching,
+# and do not try to return "sort keys %{ $c->components }"
+sub _comp_prefixes {
+ my ( $c, $name, @prefixes ) = @_;
+
+ my $appclass = ref $c || $c;
+
+ my @names = map { "${appclass}::${_}::${name}" } @prefixes;
+
+ my $comp = $c->_comp_explicit(@names);
+ return $comp if defined($comp);
+ $comp = $c->_comp_search($name);
+ return $comp;
+}
+
+# Find possible names for a prefix
+
+sub _comp_names {
+ my ( $c, @prefixes ) = @_;
+
+ my $appclass = ref $c || $c;
+
+ my @pre = map { "${appclass}::${_}::" } @prefixes;
+
+ my @names;
+
+ COMPONENT: foreach my $comp ($c->component) {
+ foreach my $p (@pre) {
+ if ($comp =~ s/^$p//) {
+ push(@names, $comp);
+ next COMPONENT;
+ }
+ }
+ }
+
+ return @names;
+}
+
+# Return a component if only one matches.
+sub _comp_singular {
+ my ( $c, @prefixes ) = @_;
+
+ my $appclass = ref $c || $c;
+
+ my ( $comp, $rest ) =
+ map { $c->_comp_search("^${appclass}::${_}::") } @prefixes;
+ return $comp unless $rest;
+}
+
+# Filter a component before returning by calling ACCEPT_CONTEXT if available
+sub _filter_component {
+ my ( $c, $comp, @args ) = @_;
+ if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
+ return $comp->ACCEPT_CONTEXT( $c, @args );
+ }
+ else { return $comp }
+}
+
+=head2 COMPONENT ACCESSORS
+
+=head2 $c->controller($name)
+
+Gets a L<Catalyst::Controller> instance by name.
+
+ $c->controller('Foo')->do_stuff;
+
+If the name is omitted, will return the controller for the dispatched
+action.
+
+=cut
+
+sub controller {
+ my ( $c, $name, @args ) = @_;
+ return $c->_filter_component( $c->_comp_prefixes( $name, qw/Controller C/ ),
+ @args )
+ if ($name);
+ return $c->component( $c->action->class );
+}
+
+=head2 $c->model($name)
+
+Gets a L<Catalyst::Model> instance by name.
+
+ $c->model('Foo')->do_stuff;
+
+Any extra arguments are directly passed to ACCEPT_CONTEXT.
+
+If the name is omitted, it will look for
+ - a model object in $c->stash{current_model_instance}, then
+ - a model name in $c->stash->{current_model}, then
+ - a config setting 'default_model', or
+ - check if there is only one model, and return it if that's the case.
+
+=cut
+
+sub model {
+ my ( $c, $name, @args ) = @_;
+ return $c->_filter_component( $c->_comp_prefixes( $name, qw/Model M/ ),
+ @args )
+ if $name;
+ if (ref $c) {
+ return $c->stash->{current_model_instance}
+ if $c->stash->{current_model_instance};
+ return $c->model( $c->stash->{current_model} )
+ if $c->stash->{current_model};
+ }
+ return $c->model( $c->config->{default_model} )
+ if $c->config->{default_model};
+ return $c->_filter_component( $c->_comp_singular(qw/Model M/) );
+
+}
+
+=head2 $c->controllers
+
+Returns the available names which can be passed to $c->controller
+
+=cut
+
+sub controllers {
+ my ( $c ) = @_;
+ return $c->_comp_names(qw/Controller C/);
+}
+
+
+=head2 $c->view($name)
+
+Gets a L<Catalyst::View> instance by name.
+
+ $c->view('Foo')->do_stuff;
+
+Any extra arguments are directly passed to ACCEPT_CONTEXT.
+
+If the name is omitted, it will look for
+ - a view object in $c->stash{current_view_instance}, then
+ - a view name in $c->stash->{current_view}, then
+ - a config setting 'default_view', or
+ - check if there is only one view, and return it if that's the case.
+
+=cut
+
+sub view {
+ my ( $c, $name, @args ) = @_;
+ return $c->_filter_component( $c->_comp_prefixes( $name, qw/View V/ ),
+ @args )
+ if $name;
+ if (ref $c) {
+ return $c->stash->{current_view_instance}
+ if $c->stash->{current_view_instance};
+ return $c->view( $c->stash->{current_view} )
+ if $c->stash->{current_view};
+ }
+ return $c->view( $c->config->{default_view} )
+ if $c->config->{default_view};
+ return $c->_filter_component( $c->_comp_singular(qw/View V/) );
+}
+
+=head2 $c->models
+
+Returns the available names which can be passed to $c->model
+
+=cut
+
+sub models {
+ my ( $c ) = @_;
+ return $c->_comp_names(qw/Model M/);
+}
+
+
+=head2 $c->views
+
+Returns the available names which can be passed to $c->view
+
+=cut
+
+sub views {
+ my ( $c ) = @_;
+ return $c->_comp_names(qw/View V/);
+}
+
+=head2 $c->comp($name)
+
+=head2 $c->component($name)
+
+Gets a component object by name. This method is not recommended,
+unless you want to get a specific component by full
+class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
+should be used instead.
+
+=cut
+
+sub component {
+ my $c = shift;
+
+ if (@_) {
+
+ my $name = shift;
+
+ my $appclass = ref $c || $c;
+
+ my @names = (
+ $name, "${appclass}::${name}",
+ map { "${appclass}::${_}::${name}" }
+ qw/Model M Controller C View V/
+ );
+
+ my $comp = $c->_comp_explicit(@names);
+ return $c->_filter_component( $comp, @_ ) if defined($comp);
+
+ $comp = $c->_comp_search($name);
+ return $c->_filter_component( $comp, @_ ) if defined($comp);
+ }
+
+ return sort keys %{ $c->components };
+}
+
+
+
+=head2 CLASS DATA AND HELPER CLASSES
+
+=head2 $c->config
+
+Returns or takes a hashref containing the application's configuration.
+
+ __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
+
+You can also use a C<YAML>, C<XML> or C<Config::General> config file
+like myapp.yml in your applications home directory. See
+L<Catalyst::Plugin::ConfigLoader>.
+
+ ---
+ db: dsn:SQLite:foo.db
+
+
+=cut
+
+sub config {
+ my $c = shift;
+
+ $c->log->warn("Setting config after setup has been run is not a good idea.")
+ if ( @_ and $c->setup_finished );
+
+ $c->NEXT::config(@_);
+}
+
+=head2 $c->log
+
+Returns the logging object instance. Unless it is already set, Catalyst
+sets this up with a L<Catalyst::Log> object. To use your own log class,
+set the logger with the C<< __PACKAGE__->log >> method prior to calling
+C<< __PACKAGE__->setup >>.
+
+ __PACKAGE__->log( MyLogger->new );
+ __PACKAGE__->setup;
+
+And later:
+
+ $c->log->info( 'Now logging with my own logger!' );
+
+Your log class should implement the methods described in
+L<Catalyst::Log>.
+
+
+=head2 $c->debug
+
+Overload to enable debug messages (same as -Debug option).
+
+Note that this is a static method, not an accessor and should be overloaded
+by declaring "sub debug { 1 }" in your MyApp.pm, not by calling $c->debug(1).
+
+=cut
+
+sub debug { 0 }
+
+=head2 $c->dispatcher
+
+Returns the dispatcher instance. Stringifies to class name. See
+L<Catalyst::Dispatcher>.
+
+=head2 $c->engine
+
+Returns the engine instance. Stringifies to the class name. See
+L<Catalyst::Engine>.
+
+
+=head2 UTILITY METHODS
+
+=head2 $c->path_to(@path)
+
+Merges C<@path> with C<< $c->config->{home} >> and returns a
+L<Path::Class::Dir> object.
+
+For example:
+
+ $c->path_to( 'db', 'sqlite.db' );
+
+=cut
+
+sub path_to {
+ my ( $c, @path ) = @_;
+ my $path = Path::Class::Dir->new( $c->config->{home}, @path );
+ if ( -d $path ) { return $path }
+ else { return Path::Class::File->new( $c->config->{home}, @path ) }
+}
+
+=head2 $c->plugin( $name, $class, @args )
+
+Helper method for plugins. It creates a classdata accessor/mutator and
+loads and instantiates the given class.
+
+ MyApp->plugin( 'prototype', 'HTML::Prototype' );
+
+ $c->prototype->define_javascript_functions;
+
+=cut
+
+sub plugin {
+ my ( $class, $name, $plugin, @args ) = @_;
+ $class->_register_plugin( $plugin, 1 );
+
+ eval { $plugin->import };
+ $class->mk_classdata($name);
+ my $obj;
+ eval { $obj = $plugin->new(@args) };
+
+ if ($@) {
+ Catalyst::Exception->throw( message =>
+ qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
+ }
+
+ $class->$name($obj);
+ $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
+ if $class->debug;
+}
+
+=head2 MyApp->setup
+
+Initializes the dispatcher and engine, loads any plugins, and loads the
+model, view, and controller components. You may also specify an array
+of plugins to load here, if you choose to not load them in the C<use
+Catalyst> line.
+
+ MyApp->setup;
+ MyApp->setup( qw/-Debug/ );
+
+=cut
+
+sub setup {
+ my ( $class, @arguments ) = @_;
+
+ $class->log->warn("Running setup twice is not a good idea.")
+ if ( $class->setup_finished );
+
+ unless ( $class->isa('Catalyst') ) {
+
+ Catalyst::Exception->throw(
+ message => qq/'$class' does not inherit from Catalyst/ );
+ }
+
+ if ( $class->arguments ) {
+ @arguments = ( @arguments, @{ $class->arguments } );
+ }
+
+ # Process options
+ my $flags = {};
+
+ foreach (@arguments) {
+
+ if (/^-Debug$/) {
+ $flags->{log} =
+ ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
+ }
+ elsif (/^-(\w+)=?(.*)$/) {
+ $flags->{ lc $1 } = $2;
+ }
+ else {
+ push @{ $flags->{plugins} }, $_;
+ }
+ }
+
+ $class->setup_home( delete $flags->{home} );
+
+ $class->setup_log( delete $flags->{log} );
+ $class->setup_plugins( delete $flags->{plugins} );
+ $class->setup_dispatcher( delete $flags->{dispatcher} );
+ $class->setup_engine( delete $flags->{engine} );
+ $class->setup_stats( delete $flags->{stats} );
+
+ for my $flag ( sort keys %{$flags} ) {
+
+ if ( my $code = $class->can( 'setup_' . $flag ) ) {
+ &$code( $class, delete $flags->{$flag} );
+ }
+ else {
+ $class->log->warn(qq/Unknown flag "$flag"/);
+ }
+ }
+
+ eval { require Catalyst::Devel; };
+ if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
+ $class->log->warn(<<"EOF");
+You are running an old script!
+
+ Please update by running (this will overwrite existing files):
+ catalyst.pl -force -scripts $class
+
+ or (this will not overwrite existing files):
+ catalyst.pl -scripts $class
+
+EOF
+ }
+
+ if ( $class->debug ) {
+ my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
+
+ if (@plugins) {
+ my $t = Text::SimpleTable->new(74);
+ $t->row($_) for @plugins;
+ $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
+ }
+
+ my $dispatcher = $class->dispatcher;
+ my $engine = $class->engine;
+ my $home = $class->config->{home};
+
+ $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
+ $class->log->debug(qq/Loaded engine "$engine"/);
+
+ $home
+ ? ( -d $home )
+ ? $class->log->debug(qq/Found home "$home"/)
+ : $class->log->debug(qq/Home "$home" doesn't exist/)
+ : $class->log->debug(q/Couldn't find home/);
+ }
+
+ # Call plugins setup
+ {
+ no warnings qw/redefine/;
+ local *setup = sub { };
+ $class->setup;
+ }
+
+ # Initialize our data structure
+ $class->components( {} );
+
+ $class->setup_components;
+
+ if ( $class->debug ) {
+ my $t = Text::SimpleTable->new( [ 63, 'Class' ], [ 8, 'Type' ] );
+ for my $comp ( sort keys %{ $class->components } ) {
+ my $type = ref $class->components->{$comp} ? 'instance' : 'class';
+ $t->row( $comp, $type );
+ }
+ $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
+ if ( keys %{ $class->components } );
+ }
+
+ # Add our self to components, since we are also a component
+ $class->components->{$class} = $class;
+
+ $class->setup_actions;
+
+ if ( $class->debug ) {
+ my $name = $class->config->{name} || 'Application';
+ $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
+ }
+ $class->log->_flush() if $class->log->can('_flush');
+
+ $class->setup_finished(1);
+}
+
+=head2 $c->uri_for( $path, @args?, \%query_values? )
+
+Merges path with C<< $c->request->base >> for absolute URIs and with
+C<< $c->namespace >> for relative URIs, then returns a normalized L<URI>
+object. If any args are passed, they are added at the end of the path.
+If the last argument to C<uri_for> is a hash reference, it is assumed to
+contain GET parameter key/value pairs, which will be appended to the URI
+in standard fashion.
+
+Note that uri_for is destructive to the passed hashref. Subsequent calls
+with the same hashref may have unintended results.
+
+Instead of C<$path>, you can also optionally pass a C<$action> object
+which will be resolved to a path using
+C<< $c->dispatcher->uri_for_action >>; if the first element of
+C<@args> is an arrayref it is treated as a list of captures to be passed
+to C<uri_for_action>.
+
+=cut
+
+sub uri_for {
+ my ( $c, $path, @args ) = @_;
+
+ if ( Scalar::Util::blessed($path) ) { # action object
+ my $captures = ( scalar @args && ref $args[0] eq 'ARRAY'
+ ? shift(@args)
+ : [] );
+ $path = $c->dispatcher->uri_for_action($path, $captures);
+ return undef unless defined($path);
+ $path = '/' if $path eq '';
+ }
+
+ undef($path) if (defined $path && $path eq '');
+
+ my $params =
+ ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
+
+ carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
+ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args;
+
+ unshift(@args, $path);
+
+ unless (defined $path && $path =~ s!^/!!) { # in-place strip
+ my $namespace = $c->namespace;
+ if (defined $path) { # cheesy hack to handle path '../foo'
+ $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
+ }
+ unshift(@args, $namespace || '');
+ }
+
+ # join args with '/', or a blank string
+ my $args = join('/', grep { defined($_) } @args);
+ $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
+ $args =~ s!^/!!;
+ my $base = $c->req->base;
+ my $class = ref($base);
+ $base =~ s{(?<!/)$}{/};
+
+ my $query = '';
+
+ if (my @keys = keys %$params) {
+ # somewhat lifted from URI::_query's query_form
+ $query = '?'.join('&', map {
+ my $val = $params->{$_};
+ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
+ s/ /+/g;
+ my $key = $_;
+ $val = '' unless defined $val;
+ (map {
+ $_ = "$_";
+ utf8::encode( $_ ) if utf8::is_utf8($_);
+ # using the URI::Escape pattern here so utf8 chars survive
+ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
+ s/ /+/g;
+ "${key}=$_"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
+ } @keys);
+ }
+
+ my $res = bless(\"${base}${args}${query}", $class);
+ $res;
+}
+
+=head2 $c->welcome_message
+
+Returns the Catalyst welcome HTML page.
+
+=cut
+
+sub welcome_message {
+ my $c = shift;
+ my $name = $c->config->{name};
+ my $logo = $c->uri_for('/static/images/catalyst_logo.png');
+ my $prefix = Catalyst::Utils::appprefix( ref $c );
+ $c->response->content_type('text/html; charset=utf-8');
+ return <<"EOF";
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+ <head>
+ <meta http-equiv="Content-Language" content="en" />
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+ <title>$name on Catalyst $VERSION</title>
+ <style type="text/css">
+ body {
+ color: #000;
+ background-color: #eee;
+ }
+ div#content {
+ width: 640px;
+ margin-left: auto;
+ margin-right: auto;
+ margin-top: 10px;
+ margin-bottom: 10px;
+ text-align: left;
+ background-color: #ccc;
+ border: 1px solid #aaa;
+ }
+ p, h1, h2 {
+ margin-left: 20px;
+ margin-right: 20px;
+ font-family: verdana, tahoma, sans-serif;
+ }
+ a {
+ font-family: verdana, tahoma, sans-serif;
+ }
+ :link, :visited {
+ text-decoration: none;
+ color: #b00;
+ border-bottom: 1px dotted #bbb;
+ }
+ :link:hover, :visited:hover {
+ color: #555;
+ }
+ div#topbar {
+ margin: 0px;
+ }
+ pre {
+ margin: 10px;
+ padding: 8px;
+ }
+ div#answers {
+ padding: 8px;
+ margin: 10px;
+ background-color: #fff;
+ border: 1px solid #aaa;
+ }
+ h1 {
+ font-size: 0.9em;
+ font-weight: normal;
+ text-align: center;
+ }
+ h2 {
+ font-size: 1.0em;
+ }
+ p {
+ font-size: 0.9em;
+ }
+ p img {
+ float: right;
+ margin-left: 10px;
+ }
+ span#appname {
+ font-weight: bold;
+ font-size: 1.6em;
+ }
+ </style>
+ </head>
+ <body>
+ <div id="content">
+ <div id="topbar">
+ <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
+ $VERSION</h1>
+ </div>
+ <div id="answers">
+ <p>
+ <img src="$logo" alt="Catalyst Logo" />
+ </p>
+ <p>Welcome to the world of Catalyst.
+ This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
+ framework will make web development something you had
+ never expected it to be: Fun, rewarding, and quick.</p>
+ <h2>What to do now?</h2>
+ <p>That really depends on what <b>you</b> want to do.
+ We do, however, provide you with a few starting points.</p>
+ <p>If you want to jump right into web development with Catalyst
+ you might want to start with a tutorial.</p>
+<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
+</pre>
+<p>Afterwards you can go on to check out a more complete look at our features.</p>
+<pre>
+<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
+<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
+</code></pre>
+ <h2>What to do next?</h2>
+ <p>Next it's time to write an actual application. Use the
+ helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&mode=all">controllers</a>,
+ <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a>, and
+ <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>;
+ they can save you a lot of work.</p>
+ <pre><code>script/${prefix}_create.pl -help</code></pre>
+ <p>Also, be sure to check out the vast and growing
+ collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&mode=all">plugins for Catalyst on CPAN</a>;
+ you are likely to find what you need there.
+ </p>
+
+ <h2>Need help?</h2>
+ <p>Catalyst has a very active community. Here are the main places to
+ get in touch with us.</p>
+ <ul>
+ <li>
+ <a href="http://dev.catalyst.perl.org">Wiki</a>
+ </li>
+ <li>
+ <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
+ </li>
+ <li>
+ <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
+ </li>
+ </ul>
+ <h2>In conclusion</h2>
+ <p>The Catalyst team hopes you will enjoy using Catalyst as much
+ as we enjoyed making it. Please contact us if you have ideas
+ for improvement or other feedback.</p>
+ </div>
+ </div>
+ </body>
+</html>
+EOF
+}
+
+=head1 INTERNAL METHODS
+
+These methods are not meant to be used by end users.
+
+=head2 $c->components
+
+Returns a hash of components.
+
+=head2 $c->context_class
+
+Returns or sets the context class.
+
+=head2 $c->counter
+
+Returns a hashref containing coderefs and execution counts (needed for
+deep recursion detection).
+
+=head2 $c->depth
+
+Returns the number of actions on the current internal execution stack.
+
+=head2 $c->dispatch
+
+Dispatches a request to actions.
+
+=cut
+
+sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
+
+=head2 $c->dispatcher_class
+
+Returns or sets the dispatcher class.
+
+=head2 $c->dump_these
+
+Returns a list of 2-element array references (name, structure) pairs
+that will be dumped on the error page in debug mode.
+
+=cut
+
+sub dump_these {
+ my $c = shift;
+ [ Request => $c->req ],
+ [ Response => $c->res ],
+ [ Stash => $c->stash ],
+ [ Config => $c->config ];
+}
+
+=head2 $c->engine_class
+
+Returns or sets the engine class.
+
+=head2 $c->execute( $class, $coderef )
+
+Execute a coderef in given class and catch exceptions. Errors are available
+via $c->error.
+
+=cut
+
+sub execute {
+ my ( $c, $class, $code ) = @_;
+ $class = $c->component($class) || $class;
+ $c->state(0);
+
+ if ( $c->depth >= $RECURSION ) {
+ my $action = "$code";
+ $action = "/$action" unless $action =~ /->/;
+ my $error = qq/Deep recursion detected calling "$action"/;
+ $c->log->error($error);
+ $c->error($error);
+ $c->state(0);
+ return $c->state;
+ }
+
+ my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
+
+ push( @{ $c->stack }, $code );
+
+ eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
+
+ $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
+
+ my $last = pop( @{ $c->stack } );
+
+ if ( my $error = $@ ) {
+ if ( !ref($error) and $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
+ else {
+ unless ( ref $error ) {
+ no warnings 'uninitialized';
+ chomp $error;
+ my $class = $last->class;
+ my $name = $last->name;
+ $error = qq/Caught exception in $class->$name "$error"/;
+ }
+ $c->error($error);
+ $c->state(0);
+ }
+ }
+ return $c->state;
+}
+
+sub _stats_start_execute {
+ my ( $c, $code ) = @_;
+
+ return if ( ( $code->name =~ /^_.*/ )
+ && ( !$c->config->{show_internal_actions} ) );
+
+ $c->counter->{"$code"}++;
+
+ my $action = "$code";
+ $action = "/$action" unless $action =~ /->/;
+
+ # determine if the call was the result of a forward
+ # this is done by walking up the call stack and looking for a calling
+ # sub of Catalyst::forward before the eval
+ my $callsub = q{};
+ for my $index ( 2 .. 11 ) {
+ last
+ if ( ( caller($index) )[0] eq 'Catalyst'
+ && ( caller($index) )[3] eq '(eval)' );
+
+ if ( ( caller($index) )[3] =~ /forward$/ ) {
+ $callsub = ( caller($index) )[3];
+ $action = "-> $action";
+ last;
+ }
+ }
+
+ my $uid = "$code" . $c->counter->{"$code"};
+
+ # is this a root-level call or a forwarded call?
+ if ( $callsub =~ /forward$/ ) {
+
+ # forward, locate the caller
+ if ( my $parent = $c->stack->[-1] ) {
+ $c->stats->profile(
+ begin => $action,
+ parent => "$parent" . $c->counter->{"$parent"},
+ uid => $uid,
+ );
+ }
+ else {
+
+ # forward with no caller may come from a plugin
+ $c->stats->profile(
+ begin => $action,
+ uid => $uid,
+ );
+ }
+ }
+ else {
+
+ # root-level call
+ $c->stats->profile(
+ begin => $action,
+ uid => $uid,
+ );
+ }
+ return $action;
+
+}
+
+sub _stats_finish_execute {
+ my ( $c, $info ) = @_;
+ $c->stats->profile( end => $info );
+}
+
+=head2 $c->_localize_fields( sub { }, \%keys );
+
+=cut
+
+sub _localize_fields {
+ my ( $c, $localized, $code ) = ( @_ );
+
+ my $request = delete $localized->{request} || {};
+ my $response = delete $localized->{response} || {};
+
+ local @{ $c }{ keys %$localized } = values %$localized;
+ local @{ $c->request }{ keys %$request } = values %$request;
+ local @{ $c->response }{ keys %$response } = values %$response;
+
+ $code->();
+}
+
+=head2 $c->finalize
+
+Finalizes the request.
+
+=cut
+
+sub finalize {
+ my $c = shift;
+
+ for my $error ( @{ $c->error } ) {
+ $c->log->error($error);
+ }
+
+ # Allow engine to handle finalize flow (for POE)
+ if ( $c->engine->can('finalize') ) {
+ $c->engine->finalize($c);
+ }
+ else {
+
+ $c->finalize_uploads;
+
+ # Error
+ if ( $#{ $c->error } >= 0 ) {
+ $c->finalize_error;
+ }
+
+ $c->finalize_headers;
+
+ # HEAD request
+ if ( $c->request->method eq 'HEAD' ) {
+ $c->response->body('');
+ }
+
+ $c->finalize_body;
+ }
+
+ if ($c->use_stats) {
+ my $elapsed = sprintf '%f', $c->stats->elapsed;
+ my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
+ $c->log->info(
+ "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
+ }
+
+ return $c->response->status;
+}
+
+=head2 $c->finalize_body
+
+Finalizes body.
+
+=cut
+
+sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
+
+=head2 $c->finalize_cookies
+
+Finalizes cookies.
+
+=cut
+
+sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
+
+=head2 $c->finalize_error
+
+Finalizes error.
+
+=cut
+
+sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
+
+=head2 $c->finalize_headers
+
+Finalizes headers.
+
+=cut
+
+sub finalize_headers {
+ my $c = shift;
+
+ # Check if we already finalized headers
+ return if $c->response->{_finalized_headers};
+
+ # Handle redirects
+ if ( my $location = $c->response->redirect ) {
+ $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
+ $c->response->header( Location => $location );
+
+ if ( !$c->response->body ) {
+ # Add a default body if none is already present
+ $c->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 ) {
+
+ # get the length from a filehandle
+ if ( blessed( $c->response->body ) && $c->response->body->can('read') )
+ {
+ my $stat = stat $c->response->body;
+ if ( $stat && $stat->size > 0 ) {
+ $c->response->content_length( $stat->size );
+ }
+ else {
+ $c->log->warn('Serving filehandle without a content-length');
+ }
+ }
+ else {
+ # everything should be bytes at this point, but just in case
+ $c->response->content_length( bytes::length( $c->response->body ) );
+ }
+ }
+
+ # Errors
+ if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
+ $c->response->headers->remove_header("Content-Length");
+ $c->response->body('');
+ }
+
+ $c->finalize_cookies;
+
+ $c->engine->finalize_headers( $c, @_ );
+
+ # Done
+ $c->response->{_finalized_headers} = 1;
+}
+
+=head2 $c->finalize_output
+
+An alias for finalize_body.
+
+=head2 $c->finalize_read
+
+Finalizes the input after reading is complete.
+
+=cut
+
+sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
+
+=head2 $c->finalize_uploads
+
+Finalizes uploads. Cleans up any temporary files.
+
+=cut
+
+sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
+
+=head2 $c->get_action( $action, $namespace )
+
+Gets an action in a given namespace.
+
+=cut
+
+sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
+
+=head2 $c->get_actions( $action, $namespace )
+
+Gets all actions of a given name in a namespace and all parent
+namespaces.
+
+=cut
+
+sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
+
+=head2 $c->handle_request( $class, @arguments )
+
+Called to handle each HTTP request.
+
+=cut
+
+sub handle_request {
+ my ( $class, @arguments ) = @_;
+
+ # Always expect worst case!
+ my $status = -1;
+ eval {
+ if ($class->debug) {
+ my $secs = time - $START || 1;
+ my $av = sprintf '%.3f', $COUNT / $secs;
+ my $time = localtime time;
+ $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
+ }
+
+ my $c = $class->prepare(@arguments);
+ $c->dispatch;
+ $status = $c->finalize;
+ };
+
+ if ( my $error = $@ ) {
+ chomp $error;
+ $class->log->error(qq/Caught exception in engine "$error"/);
+ }
+
+ $COUNT++;
+ $class->log->_flush() if $class->log->can('_flush');
+ return $status;
+}
+
+=head2 $c->prepare( @arguments )
+
+Creates a Catalyst context from an engine-specific request (Apache, CGI,
+etc.).
+
+=cut
+
+sub prepare {
+ my ( $class, @arguments ) = @_;
+
+ $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
+ }
+ );
+
+ $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} );
+
+ # Allow engine to direct the prepare flow (for POE)
+ if ( $c->engine->can('prepare') ) {
+ $c->engine->prepare( $c, @arguments );
+ }
+ else {
+ $c->prepare_request(@arguments);
+ $c->prepare_connection;
+ $c->prepare_query_parameters;
+ $c->prepare_headers;
+ $c->prepare_cookies;
+ $c->prepare_path;
+
+ # Prepare the body for reading, either by prepare_body
+ # or the user, if they are using $c->read
+ $c->prepare_read;
+
+ # Parse the body unless the user wants it on-demand
+ unless ( $c->config->{parse_on_demand} ) {
+ $c->prepare_body;
+ }
+ }
+
+ my $method = $c->req->method || '';
+ my $path = $c->req->path;
+ $path = '/' unless length $path;
+ my $address = $c->req->address || '';
+
+ $c->log->debug(qq/"$method" request for "$path" from "$address"/)
+ if $c->debug;
+
+ $c->prepare_action;
+
+ return $c;
+}
+
+=head2 $c->prepare_action
+
+Prepares action. See L<Catalyst::Dispatcher>.
+
+=cut
+
+sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
+
+=head2 $c->prepare_body
+
+Prepares message body.
+
+=cut
+
+sub prepare_body {
+ my $c = shift;
+
+ # Do we run for the first time?
+ return if defined $c->request->{_body};
+
+ # Initialize on-demand data
+ $c->engine->prepare_body( $c, @_ );
+ $c->prepare_parameters;
+ $c->prepare_uploads;
+
+ if ( $c->debug && keys %{ $c->req->body_parameters } ) {
+ my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
+ for my $key ( sort keys %{ $c->req->body_parameters } ) {
+ my $param = $c->req->body_parameters->{$key};
+ my $value = defined($param) ? $param : '';
+ $t->row( $key,
+ ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
+ }
+ $c->log->debug( "Body Parameters are:\n" . $t->draw );
+ }
+}
+
+=head2 $c->prepare_body_chunk( $chunk )
+
+Prepares a chunk of data before sending it to L<HTTP::Body>.
+
+See L<Catalyst::Engine>.
+
+=cut
+
+sub prepare_body_chunk {
+ my $c = shift;
+ $c->engine->prepare_body_chunk( $c, @_ );
+}
+
+=head2 $c->prepare_body_parameters
+
+Prepares body parameters.
+
+=cut
+
+sub prepare_body_parameters {
+ my $c = shift;
+ $c->engine->prepare_body_parameters( $c, @_ );
+}
+
+=head2 $c->prepare_connection
+
+Prepares connection.
+
+=cut
+
+sub prepare_connection {
+ my $c = shift;
+ $c->engine->prepare_connection( $c, @_ );
+}
+
+=head2 $c->prepare_cookies
+
+Prepares cookies.
+
+=cut
+
+sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
+
+=head2 $c->prepare_headers
+
+Prepares headers.
+
+=cut
+
+sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
+
+=head2 $c->prepare_parameters
+
+Prepares parameters.
+
+=cut
+
+sub prepare_parameters {
+ my $c = shift;
+ $c->prepare_body_parameters;
+ $c->engine->prepare_parameters( $c, @_ );
+}
+
+=head2 $c->prepare_path
+
+Prepares path and base.
+
+=cut
+
+sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
+
+=head2 $c->prepare_query_parameters
+
+Prepares query parameters.
+
+=cut
+
+sub prepare_query_parameters {
+ my $c = shift;
+
+ $c->engine->prepare_query_parameters( $c, @_ );
+
+ if ( $c->debug && keys %{ $c->request->query_parameters } ) {
+ my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
+ for my $key ( sort keys %{ $c->req->query_parameters } ) {
+ my $param = $c->req->query_parameters->{$key};
+ my $value = defined($param) ? $param : '';
+ $t->row( $key,
+ ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
+ }
+ $c->log->debug( "Query Parameters are:\n" . $t->draw );
+ }
+}
+
+=head2 $c->prepare_read
+
+Prepares the input for reading.
+
+=cut
+
+sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
+
+=head2 $c->prepare_request
+
+Prepares the engine request.
+
+=cut
+
+sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
+
+=head2 $c->prepare_uploads
+
+Prepares uploads.
+
+=cut
+
+sub prepare_uploads {
+ my $c = shift;
+
+ $c->engine->prepare_uploads( $c, @_ );
+
+ if ( $c->debug && keys %{ $c->request->uploads } ) {
+ my $t = Text::SimpleTable->new(
+ [ 12, 'Parameter' ],
+ [ 26, 'Filename' ],
+ [ 18, 'Type' ],
+ [ 9, 'Size' ]
+ );
+ for my $key ( sort keys %{ $c->request->uploads } ) {
+ my $upload = $c->request->uploads->{$key};
+ for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
+ $t->row( $key, $u->filename, $u->type, $u->size );
+ }
+ }
+ $c->log->debug( "File Uploads are:\n" . $t->draw );
+ }
+}
+
+=head2 $c->prepare_write
+
+Prepares the output for writing.
+
+=cut
+
+sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
+
+=head2 $c->request_class
+
+Returns or sets the request class.
+
+=head2 $c->response_class
+
+Returns or sets the response class.
+
+=head2 $c->read( [$maxlength] )
+
+Reads a chunk of data from the request body. This method is designed to
+be used in a while loop, reading C<$maxlength> bytes on every call.
+C<$maxlength> defaults to the size of the request if not specified.
+
+You have to set C<< MyApp->config->{parse_on_demand} >> to use this
+directly.
+
+Warning: If you use read(), Catalyst will not process the body,
+so you will not be able to access POST parameters or file uploads via
+$c->request. You must handle all body parsing yourself.
+
+=cut
+
+sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
+
+=head2 $c->run
+
+Starts the engine.
+
+=cut
+
+sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
+
+=head2 $c->set_action( $action, $code, $namespace, $attrs )
+
+Sets an action in a given namespace.
+
+=cut
+
+sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
+
+=head2 $c->setup_actions($component)
+
+Sets up actions for a component.
+
+=cut
+
+sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
+
+=head2 $c->setup_components
+
+Sets up components. Specify a C<setup_components> config option to pass
+additional options directly to L<Module::Pluggable>. To add additional
+search paths, specify a key named C<search_extra> as an array
+reference. Items in the array beginning with C<::> will have the
+application class name prepended to them.
+
+=cut
+
+sub setup_components {
+ my $class = shift;
+
+ my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
+ my $config = $class->config->{ setup_components };
+ my $extra = delete $config->{ search_extra } || [];
+
+ push @paths, @$extra;
+
+ my $locator = Module::Pluggable::Object->new(
+ search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
+ %$config
+ );
+
+ my @comps = sort { length $a <=> length $b } $locator->plugins;
+ my %comps = map { $_ => 1 } @comps;
+
+ for my $component ( @comps ) {
+
+ # We pass ignore_loaded here so that overlay files for (e.g.)
+ # Model::DBI::Schema sub-classes are loaded - if it's in @comps
+ # we know M::P::O found a file on disk so this is safe
+
+ Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
+
+ my $module = $class->setup_component( $component );
+ my %modules = (
+ $component => $module,
+ map {
+ $_ => $class->setup_component( $_ )
+ } grep {
+ not exists $comps{$_}
+ } Devel::InnerPackage::list_packages( $component )
+ );
+
+ for my $key ( keys %modules ) {
+ $class->components->{ $key } = $modules{ $key };
+ }
+ }
+}
+
+=head2 $c->setup_component
+
+=cut
+
+sub setup_component {
+ my( $class, $component ) = @_;
+
+ unless ( $component->can( 'COMPONENT' ) ) {
+ return $component;
+ }
+
+ my $suffix = Catalyst::Utils::class2classsuffix( $component );
+ my $config = $class->config->{ $suffix } || {};
+
+ my $instance = eval { $component->COMPONENT( $class, $config ); };
+
+ if ( my $error = $@ ) {
+ chomp $error;
+ Catalyst::Exception->throw(
+ message => qq/Couldn't instantiate component "$component", "$error"/
+ );
+ }
+
+ Catalyst::Exception->throw(
+ message =>
+ qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/
+ ) unless eval { $instance->can( 'can' ) };
+
+ return $instance;
+}
+
+=head2 $c->setup_dispatcher
+
+Sets up dispatcher.
+
+=cut
+
+sub setup_dispatcher {
+ my ( $class, $dispatcher ) = @_;
+
+ if ($dispatcher) {
+ $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
+ }
+
+ if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
+ $dispatcher = 'Catalyst::Dispatcher::' . $env;
+ }
+
+ unless ($dispatcher) {
+ $dispatcher = $class->dispatcher_class;
+ }
+
+ unless (Class::Inspector->loaded($dispatcher)) {
+ require Class::Inspector->filename($dispatcher);
+ }
+
+ # dispatcher instance
+ $class->dispatcher( $dispatcher->new );
+}
+
+=head2 $c->setup_engine
+
+Sets up engine.
+
+=cut
+
+sub setup_engine {
+ my ( $class, $engine ) = @_;
+
+ if ($engine) {
+ $engine = 'Catalyst::Engine::' . $engine;
+ }
+
+ if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
+ $engine = 'Catalyst::Engine::' . $env;
+ }
+
+ if ( $ENV{MOD_PERL} ) {
+
+ # create the apache method
+ {
+ no strict 'refs';
+ *{"$class\::apache"} = sub { shift->engine->apache };
+ }
+
+ my ( $software, $version ) =
+ $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
+
+ $version =~ s/_//g;
+ $version =~ s/(\.[^.]+)\./$1/g;
+
+ if ( $software eq 'mod_perl' ) {
+
+ if ( !$engine ) {
+
+ if ( $version >= 1.99922 ) {
+ $engine = 'Catalyst::Engine::Apache2::MP20';
+ }
+
+ elsif ( $version >= 1.9901 ) {
+ $engine = 'Catalyst::Engine::Apache2::MP19';
+ }
+
+ elsif ( $version >= 1.24 ) {
+ $engine = 'Catalyst::Engine::Apache::MP13';
+ }
+
+ else {
+ Catalyst::Exception->throw( message =>
+ qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
+ }
+
+ }
+
+ # install the correct mod_perl handler
+ if ( $version >= 1.9901 ) {
+ *handler = sub : method {
+ shift->handle_request(@_);
+ };
+ }
+ else {
+ *handler = sub ($$) { shift->handle_request(@_) };
+ }
+
+ }
+
+ elsif ( $software eq 'Zeus-Perl' ) {
+ $engine = 'Catalyst::Engine::Zeus';
+ }
+
+ else {
+ Catalyst::Exception->throw(
+ message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
+ }
+ }
+
+ unless ($engine) {
+ $engine = $class->engine_class;
+ }
+
+ unless (Class::Inspector->loaded($engine)) {
+ require Class::Inspector->filename($engine);
+ }
+
+ # check for old engines that are no longer compatible
+ my $old_engine;
+ if ( $engine->isa('Catalyst::Engine::Apache')
+ && !Catalyst::Engine::Apache->VERSION )
+ {
+ $old_engine = 1;
+ }
+
+ elsif ( $engine->isa('Catalyst::Engine::Server::Base')
+ && Catalyst::Engine::Server->VERSION le '0.02' )
+ {
+ $old_engine = 1;
+ }
+
+ elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
+ && $engine->VERSION eq '0.01' )
+ {
+ $old_engine = 1;
+ }
+
+ elsif ($engine->isa('Catalyst::Engine::Zeus')
+ && $engine->VERSION eq '0.01' )
+ {
+ $old_engine = 1;
+ }
+
+ if ($old_engine) {
+ Catalyst::Exception->throw( message =>
+ qq/Engine "$engine" is not supported by this version of Catalyst/
+ );
+ }
+
+ # engine instance
+ $class->engine( $engine->new );
+}
+
+=head2 $c->setup_home
+
+Sets up the home directory.
+
+=cut
+
+sub setup_home {
+ my ( $class, $home ) = @_;
+
+ if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
+ $home = $env;
+ }
+
+ unless ($home) {
+ $home = Catalyst::Utils::home($class);
+ }
+
+ if ($home) {
+ $class->config->{home} ||= $home;
+ $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
+ }
+}
+
+=head2 $c->setup_log
+
+Sets up log.
+
+=cut
+
+sub setup_log {
+ my ( $class, $debug ) = @_;
+
+ unless ( $class->log ) {
+ $class->log( Catalyst::Log->new );
+ }
+
+ my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
+ if ( defined($env_debug) ? $env_debug : $debug ) {
+ no strict 'refs';
+ *{"$class\::debug"} = sub { 1 };
+ $class->log->debug('Debug messages enabled');
+ }
+}
+
+=head2 $c->setup_plugins
+
+Sets up plugins.
+
+=cut
+
+=head2 $c->setup_stats
+
+Sets up timing statistics class.
+
+=cut
+
+sub setup_stats {
+ my ( $class, $stats ) = @_;
+
+ Catalyst::Utils::ensure_class_loaded($class->stats_class);
+
+ my $env = Catalyst::Utils::env_value( $class, 'STATS' );
+ if ( defined($env) ? $env : ($stats || $class->debug ) ) {
+ no strict 'refs';
+ *{"$class\::use_stats"} = sub { 1 };
+ $class->log->debug('Statistics enabled');
+ }
+}
+
+
+=head2 $c->registered_plugins
+
+Returns a sorted list of the plugins which have either been stated in the
+import list or which have been added via C<< MyApp->plugin(@args); >>.
+
+If passed a given plugin name, it will report a boolean value indicating
+whether or not that plugin is loaded. A fully qualified name is required if
+the plugin name does not begin with C<Catalyst::Plugin::>.
+
+ if ($c->registered_plugins('Some::Plugin')) {
+ ...
+ }
+
+=cut
+
+{
+
+ sub registered_plugins {
+ my $proto = shift;
+ return sort keys %{ $proto->_plugins } unless @_;
+ my $plugin = shift;
+ return 1 if exists $proto->_plugins->{$plugin};
+ return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
+ }
+
+ sub _register_plugin {
+ my ( $proto, $plugin, $instant ) = @_;
+ my $class = ref $proto || $proto;
+
+ # 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 );
+
+ $proto->_plugins->{$plugin} = 1;
+ unless ($instant) {
+ no strict 'refs';
+ unshift @{"$class\::ISA"}, $plugin;
+ }
+ return $class;
+ }
+
+ sub setup_plugins {
+ my ( $class, $plugins ) = @_;
+
+ $class->_plugins( {} ) unless $class->_plugins;
+ $plugins ||= [];
+ for my $plugin ( reverse @$plugins ) {
+
+ unless ( $plugin =~ s/\A\+// ) {
+ $plugin = "Catalyst::Plugin::$plugin";
+ }
+
+ $class->_register_plugin($plugin);
+ }
+ }
+}
+
+=head2 $c->stack
+
+Returns an arrayref of the internal execution stack (actions that are
+currently executing).
+
+=head2 $c->stats_class
+
+Returns or sets the stats (timing statistics) class.
+
+=head2 $c->use_stats
+
+Returns 1 when stats collection is enabled. Stats collection is enabled
+when the -Stats options is set, debug is on or when the <MYAPP>_STATS
+environment variable is set.
+
+Note that this is a static method, not an accessor and should be overloaded
+by declaring "sub use_stats { 1 }" in your MyApp.pm, not by calling $c->use_stats(1).
+
+=cut
+
+sub use_stats { 0 }
+
+
+=head2 $c->write( $data )
+
+Writes $data to the output stream. When using this method directly, you
+will need to manually set the C<Content-Length> header to the length of
+your output data, if known.
+
+=cut
+
+sub write {
+ my $c = shift;
+
+ # Finalize headers if someone manually writes output
+ $c->finalize_headers;
+
+ return $c->engine->write( $c, @_ );
+}
+
+=head2 version
+
+Returns the Catalyst version number. Mostly useful for "powered by"
+messages in template systems.
+
+=cut
+
+sub version { return $Catalyst::VERSION }
+
+=head1 INTERNAL ACTIONS
+
+Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
+C<_ACTION>, and C<_END>. These are by default not shown in the private
+action table, but you can make them visible with a config parameter.
+
+ MyApp->config->{show_internal_actions} = 1;
+
+=head1 CASE SENSITIVITY
+
+By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
+mapped to C</foo/bar>. You can activate case sensitivity with a config
+parameter.
+
+ MyApp->config->{case_sensitive} = 1;
+
+This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
+
+=head1 ON-DEMAND PARSER
+
+The request body is usually parsed at the beginning of a request,
+but if you want to handle input yourself, you can enable on-demand
+parsing with a config parameter.
+
+ MyApp->config->{parse_on_demand} = 1;
+
+=head1 PROXY SUPPORT
+
+Many production servers operate using the common double-server approach,
+with a lightweight frontend web server passing requests to a larger
+backend server. An application running on the backend server must deal
+with two problems: the remote user always appears to be C<127.0.0.1> and
+the server's hostname will appear to be C<localhost> regardless of the
+virtual host that the user connected through.
+
+Catalyst will automatically detect this situation when you are running
+the frontend and backend servers on the same machine. The following
+changes are made to the request.
+
+ $c->req->address is set to the user's real IP address, as read from
+ the HTTP X-Forwarded-For header.
+
+ The host value for $c->req->base and $c->req->uri is set to the real
+ host, as read from the HTTP X-Forwarded-Host header.
+
+Obviously, your web server must support these headers for this to work.
+
+In a more complex server farm environment where you may have your
+frontend proxy server(s) on different machines, you will need to set a
+configuration option to tell Catalyst to read the proxied data from the
+headers.
+
+ MyApp->config->{using_frontend_proxy} = 1;
+
+If you do not wish to use the proxy support at all, you may set:
+
+ MyApp->config->{ignore_frontend_proxy} = 1;
+
+=head1 THREAD SAFETY
+
+Catalyst has been tested under Apache 2's threading C<mpm_worker>,
+C<mpm_winnt>, and the standalone forking HTTP server on Windows. We
+believe the Catalyst core to be thread-safe.
+
+If you plan to operate in a threaded environment, remember that all other
+modules you are using must also be thread-safe. Some modules, most notably
+L<DBD::SQLite>, are not thread-safe.
+
+=head1 SUPPORT
+
+IRC:
+
+ Join #catalyst on irc.perl.org.
+
+Mailing Lists:
+
+ http://lists.rawmode.org/mailman/listinfo/catalyst
+ http://lists.rawmode.org/mailman/listinfo/catalyst-dev
+
+Web:
+
+ http://catalyst.perl.org
+
+Wiki:
+
+ http://dev.catalyst.perl.org
+
+=head1 SEE ALSO
+
+=head2 L<Task::Catalyst> - All you need to start with Catalyst
+
+=head2 L<Catalyst::Manual> - The Catalyst Manual
+
+=head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
+
+=head2 L<Catalyst::Engine> - Core engine
+
+=head2 L<Catalyst::Log> - Log class.
+
+=head2 L<Catalyst::Request> - Request object
+
+=head2 L<Catalyst::Response> - Response object
+
+=head2 L<Catalyst::Test> - The test suite.
+
+=head1 CREDITS
+
+Andy Grundman
+
+Andy Wardley
+
+Andreas Marienborg
+
+Andrew Bramble
+
+Andrew Ford
+
+Andrew Ruthven
+
+Arthur Bergman
+
+Autrijus Tang
+
+Brian Cassidy
+
+Carl Franks
+
+Christian Hansen
+
+Christopher Hicks
+
+Dan Sully
+
+Danijel Milicevic
+
+David Kamholz
+
+David Naughton
+
+Drew Taylor
+
+Gary Ashton Jones
+
+Geoff Richards
+
+Jesse Sheidlower
+
+Jesse Vincent
+
+Jody Belka
+
+Johan Lindstrom
+
+Juan Camacho
+
+Leon Brocard
+
+Marcus Ramberg
+
+Matt S Trout
+
+Robert Sedlacek
+
+Sam Vilain
+
+Sascha Kiefer
+
+Sebastian Willert
+
+Tatsuhiko Miyagawa
+
+Ulf Edvinsson
+
+Yuval Kogman
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at oook.de>
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/script/catalyst.pl
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/script/catalyst.pl (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/script/catalyst.pl 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,193 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Getopt::Long;
+use Pod::Usage;
+BEGIN {
+eval " use Catalyst::Devel 1.0; ";
+
+if ($@) {
+ die <<END;
+To use the Catalyst development tools including catalyst.pl and the
+generated script/myapp_create.pl you need Catalyst::Helper, which is
+part of the Catalyst-Devel distribution. Please install this via a
+vendor package or by running one of -
+
+ perl -MCPAN -e 'install Catalyst::Devel'
+ perl -MCPANPLUS -e 'install Catalyst::Devel'
+END
+
+}
+};
+
+use Catalyst::Helper;
+
+my $force = 0;
+my $help = 0;
+my $makefile = 0;
+my $scripts = 0;
+my $short = 0;
+
+GetOptions(
+ 'help|?' => \$help,
+ 'force|nonew' => \$force,
+ 'makefile' => \$makefile,
+ 'scripts' => \$scripts,
+ 'short' => \$short
+);
+
+pod2usage(1) if ( $help || !$ARGV[0] );
+
+my $helper = Catalyst::Helper->new(
+ {
+ '.newfiles' => !$force,
+ 'makefile' => $makefile,
+ 'scripts' => $scripts,
+ 'short' => $short,
+ }
+);
+pod2usage(1) unless $helper->mk_app( $ARGV[0] );
+
+1;
+__END__
+
+=head1 NAME
+
+catalyst - Bootstrap a Catalyst application
+
+=head1 SYNOPSIS
+
+catalyst.pl [options] application-name
+
+'catalyst.pl' creates a skeleton for a new application, and allows you to
+upgrade the skeleton of your old application.
+
+ Options:
+ -force don't create a .new file where a file to be created exists
+ -help display this help and exit
+ -makefile only update Makefile.PL
+ -scripts only update helper scripts
+ -short use short names, M/V/C instead of Model/View/Controller.
+
+ application-name must be a valid Perl module name and can include "::",
+ which will be converted to '-' in the project name.
+
+
+ Examples:
+ catalyst.pl My::App
+ catalyst.pl MyApp
+
+ To upgrade your app to a new version of Catalyst:
+ catalyst.pl -force -scripts MyApp
+
+
+=head1 DESCRIPTION
+
+The C<catalyst.pl> script bootstraps a Catalyst application, creating a
+directory structure populated with skeleton files.
+
+The application name must be a valid Perl module name. The name of the
+directory created is formed from the application name supplied, with double
+colons replaced with hyphens (so, for example, the directory for C<My::App> is
+C<My-App>).
+
+Using the example application name C<My::App>, the application directory will
+contain the following items:
+
+=over 4
+
+=item README
+
+a skeleton README file, which you are encouraged to expand on
+
+=item Changes
+
+a changes file with an initial entry for the creation of the application
+
+=item Makefile.PL
+
+Makefile.PL uses the C<Module::Install> system for packaging and distribution
+of the application.
+
+=item lib
+
+contains the application module (C<My/App.pm>) and
+subdirectories for model, view, and controller components (C<My/App/M>,
+C<My/App/V>, and C<My/App/C>).
+
+=item root
+
+root directory for your web document content. This is left empty.
+
+=item script
+
+a directory containing helper scripts:
+
+=over 4
+
+=item C<myapp_create.pl>
+
+helper script to generate new component modules
+
+=item C<myapp_server.pl>
+
+runs the generated application within a Catalyst test server, which can be
+used for testing without resorting to a full-blown web server configuration.
+
+=item C<myapp_cgi.pl>
+
+runs the generated application as a CGI script
+
+=item C<myapp_fastcgi.pl>
+
+runs the generated application as a FastCGI script
+
+=item C<myapp_test.pl>
+
+runs an action of the generated application from the comand line.
+
+=back
+
+=item t
+
+test directory
+
+=back
+
+
+The application module generated by the C<catalyst.pl> script is functional,
+although it reacts to all requests by outputting a friendly welcome screen.
+
+
+=head1 NOTE
+
+Neither C<catalyst.pl> nor the generated helper script will overwrite existing
+files. In fact the scripts will generate new versions of any existing files,
+adding the extension C<.new> to the filename. The C<.new> file is not created
+if would be identical to the existing file.
+
+This means you can re-run the scripts for example to see if newer versions of
+Catalyst or its plugins generate different code, or to see how you may have
+changed the generated code (although you do of course have all your code in a
+version control system anyway, don't you ...).
+
+
+
+=head1 SEE ALSO
+
+L<Catalyst::Manual>, L<Catalyst::Manual::Intro>
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri at oook.de>,
+Andrew Ford, C<A.Ford at ford-mason.co.uk>
+
+
+=head1 COPYRIGHT
+
+Copyright 2004-2005 Sebastian Riedel. All rights reserved.
+
+This library is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Property changes on: Catalyst-Runtime/5.70/tags/5.7015/script/catalyst.pl
___________________________________________________________________
Name: svn:executable
+ *
Added: Catalyst-Runtime/5.70/tags/5.7015/t/01use.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/01use.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/01use.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,3 @@
+use Test::More tests => 1;
+
+use_ok('Catalyst');
Added: Catalyst-Runtime/5.70/tags/5.7015/t/02pod.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/02pod.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/02pod.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,7 @@
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => 'Test::Pod 1.14 required' if $@;
+plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD} || -e 'inc/.author';
+
+all_pod_files_ok();
Added: Catalyst-Runtime/5.70/tags/5.7015/t/03podcoverage.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/03podcoverage.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/03podcoverage.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,7 @@
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
+plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD} || -e 'inc/.author';
+
+all_pod_coverage_ok();
Added: Catalyst-Runtime/5.70/tags/5.7015/t/04critic.rc
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/04critic.rc (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/04critic.rc 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,5 @@
+include = CodeLayout::ProhibitHardTabs
+only = 1
+
+[CodeLayout::ProhibitHardTabs]
+allow_leading_tabs = 0
\ No newline at end of file
Added: Catalyst-Runtime/5.70/tags/5.7015/t/04critic.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/04critic.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/04critic.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+
+use File::Spec;
+use FindBin ();
+use Test::More;
+
+if ( !-e "$FindBin::Bin/../MANIFEST.SKIP" ) {
+ plan skip_all => 'Critic test only for developers.';
+}
+else {
+ eval { require Test::Perl::Critic };
+ if ( $@ ) {
+ plan tests => 1;
+ fail( 'You must install Test::Perl::Critic 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
Added: Catalyst-Runtime/5.70/tags/5.7015/t/c3_mro.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/c3_mro.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/c3_mro.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,40 @@
+use strict;
+use warnings;
+
+use Test::More;
+require Catalyst;
+require Module::Pluggable::Object;
+
+eval "require Class::C3";
+plan skip_all => "This test requires Class::C3" if $@;
+
+# Get a list of all Catalyst:: packages in blib via M::P::O
+my @cat_mods;
+{
+ # problem with @INC on win32, see:
+ # http://rt.cpan.org/Ticket/Display.html?id=26452
+ if ($^O eq 'MSWin32') { require Win32; Win32::GetCwd(); }
+
+ local @INC = grep {/blib/} @INC;
+ @cat_mods = (
+ 'Catalyst',
+ Module::Pluggable::Object->new(search_path => ['Catalyst'])->plugins,
+ );
+}
+
+# plan one test per found package name
+plan tests => scalar @cat_mods;
+
+# Try to calculate the C3 MRO for each package
+#
+# In the case that the initial require fails (as in
+# Catalyst::Engine::FastCGI when FCGI is not installed),
+# the calculateMRO eval will not error out, which is
+# effectively a test skip.
+#
+foreach my $cat_mod (@cat_mods) {
+ eval " require $cat_mod ";
+ eval { Class::C3::calculateMRO($cat_mod) };
+ ok(!$@, "calculateMRO for $cat_mod");
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/catalyst_130pix.gif
===================================================================
(Binary files differ)
Property changes on: Catalyst-Runtime/5.70/tags/5.7015/t/catalyst_130pix.gif
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: Catalyst-Runtime/5.70/tags/5.7015/t/conf/extra.conf.in
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/conf/extra.conf.in (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/conf/extra.conf.in 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,45 @@
+<IfDefine !APACHE1>
+ # Needed to pass some %2F tests
+ AllowEncodedSlashes on
+</IfDefine>
+
+# CGI
+<IfModule @CGI_MODULE@>
+ ScriptAlias /cgi/ @ServerRoot@/tmp/TestApp/script/testapp_cgi.pl/
+
+ # REDIRECT_URL test
+ <IfModule mod_rewrite.c>
+ # Fix trailing slash on /cgi
+ # one CGI test will fail if you don't have mod_rewrite enabled
+ RewriteEngine on
+ RewriteRule /cgi$ /cgi/ [PT]
+
+ # Pass-through Authorization header for CGI/FastCGI
+ RewriteCond %{HTTP:Authorization} ^(.+)
+ RewriteRule ^(.*)$ $1 [E=HTTP_AUTHORIZATION:%1,PT]
+
+ <Location /rewrite>
+ RewriteEngine on
+ RewriteRule /rewrite$ /rewrite/ [PT]
+ RewriteRule /rewrite/(.*) /cgi/$1
+ </Location>
+ </IfModule>
+</IfModule>
+
+# FastCGI
+<IfModule mod_fastcgi.c>
+ FastCgiIpcDir @ServerRoot@/tmp/tmp
+ FastCgiServer @ServerRoot@/tmp/TestApp/script/testapp_fastcgi.pl -idle-timeout 300 -processes 1
+
+ # Test at a non-root location
+ ScriptAlias /fastcgi/deep/path/ @ServerRoot@/tmp/TestApp/script/testapp_fastcgi.pl/
+
+ # Test at root
+ ScriptAlias / @ServerRoot@/tmp/TestApp/script/testapp_fastcgi.pl/
+
+ <IfModule mod_rewrite.c>
+ # Fix trailing slash
+ RewriteEngine on
+ RewriteRule /fastcgi/deep/path$ /fastcgi/deep/path/ [PT]
+ </IfModule>
+</IfModule>
Added: Catalyst-Runtime/5.70/tags/5.7015/t/custom_live_component_controller_action_auto_doublebug.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/custom_live_component_controller_action_auto_doublebug.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/custom_live_component_controller_action_auto_doublebug.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,48 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 3*$iters;
+use Catalyst::Test 'TestAppDoubleAutoBug';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 3;
+ }
+
+ {
+ my @expected = qw[
+ TestAppDoubleAutoBug->auto
+ TestAppDoubleAutoBug->default
+ TestAppDoubleAutoBug->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/one'), 'auto + local' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'default, auto=1', 'Content OK' );
+ }
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/custom_live_path_bug.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/custom_live_path_bug.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/custom_live_path_bug.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,39 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 2*$iters;
+use Catalyst::Test 'TestAppPathBug';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 2;
+ }
+
+ {
+ my $expected = 'This is the foo method.';
+ ok( my $response = request('http://localhost/'), 'response ok' );
+ is( $response->content, $expected, 'Content OK' );
+ }
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/dead_load_multiple_chained_attributes.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/dead_load_multiple_chained_attributes.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/dead_load_multiple_chained_attributes.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,31 @@
+#!perl
+
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More;
+
+plan tests => 4;
+
+use Catalyst::Test 'TestApp';
+
+eval q{
+ package TestApp::Controller::Action::Chained;
+ sub should_fail : Chained('/') Chained('foo') Args(0) {}
+};
+ok(!$@);
+
+eval { TestApp->setup_actions; };
+ok($@, 'Multiple chained attributes make action setup fail');
+
+eval q{
+ package TestApp::Controller::Action::Chained;
+ no warnings 'redefine';
+ sub should_fail {}
+};
+ok(!$@);
+
+eval { TestApp->setup_actions };
+ok(!$@, 'And ok again') or warn $@;
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/TestAfter.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/TestAfter.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/TestAfter.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,15 @@
+package Catalyst::Action::TestAfter;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Action/;
+
+sub execute {
+ my $self = shift;
+ my ( $controller, $c ) = @_;
+ $self->NEXT::execute( @_ );
+ $c->res->header( 'X-Action-After', $c->stash->{after_message} );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/TestBefore.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/TestBefore.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Action/TestBefore.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,15 @@
+package Catalyst::Action::TestBefore;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Action/;
+
+sub execute {
+ my $self = shift;
+ my ( $controller, $c ) = @_;
+ $c->stash->{test} = 'works';
+ $self->NEXT::execute( @_ );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Errors.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Errors.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Errors.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,32 @@
+package Catalyst::Plugin::Test::Errors;
+
+use strict;
+
+sub error {
+ my $c = shift;
+
+ unless ( $_[0] ) {
+ return $c->NEXT::error(@_);
+ }
+
+ if ( $_[0] =~ /^(Unknown resource|No default action defined)/ ) {
+ $c->response->status(404);
+ }
+
+ if ( $_[0] =~ /^Couldn\'t forward/ ) {
+ $c->response->status(404);
+ }
+
+ if ( $_[0] =~ /^Caught exception/ ) {
+ $c->response->status(500);
+ }
+
+ my $error = $_[0];
+ $error =~ s/\n/, /g;
+
+ $c->response->headers->push_header( 'X-Catalyst-Error' => $error );
+
+ $c->NEXT::error(@_);
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Headers.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Headers.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Headers.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,33 @@
+package Catalyst::Plugin::Test::Headers;
+
+use strict;
+
+sub prepare {
+ my $class = shift;
+
+ my $c = $class->NEXT::prepare(@_);
+
+ $c->response->header( 'X-Catalyst-Engine' => $c->engine );
+ $c->response->header( 'X-Catalyst-Debug' => $c->debug ? 1 : 0 );
+
+ {
+ my $components = join( ', ', sort keys %{ $c->components } );
+ $c->response->header( 'X-Catalyst-Components' => $components );
+ }
+
+ {
+ no strict 'refs';
+ my $plugins = join ', ', $class->registered_plugins;
+ $c->response->header( 'X-Catalyst-Plugins' => $plugins );
+ }
+
+ return $c;
+}
+
+sub prepare_action {
+ my $c = shift;
+ $c->NEXT::prepare_action(@_);
+ $c->res->header( 'X-Catalyst-Action' => $c->req->action );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Plugin.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Plugin.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/Catalyst/Plugin/Test/Plugin.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,29 @@
+package Catalyst::Plugin::Test::Plugin;
+
+use strict;
+
+use base qw/Catalyst::Base Class::Data::Inheritable/;
+
+ __PACKAGE__->mk_classdata('ran_setup');
+
+sub setup {
+ my $c = shift;
+ $c->ran_setup('1');
+}
+
+sub prepare {
+
+ my $class = shift;
+
+ my $c = $class->NEXT::prepare(@_);
+ $c->response->header( 'X-Catalyst-Plugin-Setup' => $c->ran_setup );
+
+ return $c;
+
+}
+
+sub end : Private {
+ my ($self,$c) = @_;
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/PluginTestApp.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/PluginTestApp.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/PluginTestApp.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,67 @@
+package PluginTestApp;
+use Test::More;
+
+use Catalyst qw(
+ Test::Plugin
+ +TestApp::Plugin::FullyQualified
+ );
+
+sub compile_time_plugins : Local {
+ my ( $self, $c ) = @_;
+
+ isa_ok $c, 'Catalyst::Plugin::Test::Plugin';
+ isa_ok $c, 'TestApp::Plugin::FullyQualified';
+
+ can_ok $c, 'registered_plugins';
+ $c->_test_plugins;
+
+ $c->res->body("ok");
+}
+
+sub run_time_plugins : Local {
+ my ( $self, $c ) = @_;
+
+ $c->_test_plugins;
+ my $faux_plugin = 'Faux::Plugin';
+
+# Trick perl into thinking the plugin is already loaded
+ $INC{'Faux/Plugin.pm'} = 1;
+
+ __PACKAGE__->plugin( faux => $faux_plugin );
+
+ isa_ok $c, 'Catalyst::Plugin::Test::Plugin';
+ isa_ok $c, 'TestApp::Plugin::FullyQualified';
+ ok !$c->isa($faux_plugin),
+ '... and it should not inherit from the instant plugin';
+ can_ok $c, 'faux';
+ is $c->faux->count, 1, '... and it should behave correctly';
+ is_deeply [ $c->registered_plugins ],
+ [
+ qw/Catalyst::Plugin::Test::Plugin
+ Faux::Plugin
+ TestApp::Plugin::FullyQualified/
+ ],
+ 'registered_plugins() should report all plugins';
+ ok $c->registered_plugins('Faux::Plugin'),
+ '... and even the specific instant plugin';
+
+ $c->res->body("ok");
+}
+
+sub _test_plugins {
+ my $c = shift;
+ is_deeply [ $c->registered_plugins ],
+ [
+ qw/Catalyst::Plugin::Test::Plugin
+ TestApp::Plugin::FullyQualified/
+ ],
+ '... and it should report the correct plugins';
+ ok $c->registered_plugins('Catalyst::Plugin::Test::Plugin'),
+ '... or if we have a particular plugin';
+ ok $c->registered_plugins('Test::Plugin'),
+ '... even if it is not fully qualified';
+ ok !$c->registered_plugins('No::Such::Plugin'),
+ '... and it should return false if the plugin does not exist';
+}
+
+__PACKAGE__->setup;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/TestBefore.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/TestBefore.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/TestBefore.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,15 @@
+package TestApp::Action::TestBefore;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Action/;
+
+sub execute {
+ my $self = shift;
+ my ( $controller, $c, $test ) = @_;
+ $c->res->header( 'X-TestAppActionTestBefore', $test );
+ $self->NEXT::execute( @_ );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/TestMyAction.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/TestMyAction.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Action/TestMyAction.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+package TestApp::Action::TestMyAction;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Action/;
+
+sub execute {
+ my $self = shift;
+ my ( $controller, $c, $test ) = @_;
+ $c->res->header( 'X-TestAppActionTestMyAction', 'MyAction works' );
+ $self->NEXT::execute(@_);
+}
+
+1;
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Action.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Action.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Action.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,28 @@
+package TestApp::Controller::Action::Action;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub action_action_one : Global : ActionClass('TestBefore') {
+ my ( $self, $c ) = @_;
+ $c->res->header( 'X-Action', $c->stash->{test} );
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub action_action_two : Global : ActionClass('TestAfter') {
+ my ( $self, $c ) = @_;
+ $c->stash->{after_message} = 'awesome';
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub action_action_three : Global : ActionClass('+TestApp::Action::TestBefore') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub action_action_four : Global : MyAction('TestMyAction') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Abort.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Abort.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Abort.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,26 @@
+package TestApp::Controller::Action::Auto::Abort;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ return 0;
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'abort default' );
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'abort end' ) unless $c->res->body;
+}
+
+sub one : Local {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'abort one' );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Deep.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Deep.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Deep.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,21 @@
+package TestApp::Controller::Action::Auto::Deep;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ return 1;
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'deep default' );
+}
+
+sub one : Local {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'deep one' );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Default.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Default.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto/Default.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,22 @@
+package TestApp::Controller::Action::Auto::Default;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub begin : Private { }
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ $c->stash->{auto_ran}++;
+ return 1;
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( sprintf 'default (auto: %d)', $c->stash->{auto_ran} );
+}
+
+sub end : Private { }
+
+1;
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Auto.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,21 @@
+package TestApp::Controller::Action::Auto;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ return 1;
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'default' );
+}
+
+sub one : Local {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'one' );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Begin.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Begin.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Begin.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+package TestApp::Controller::Action::Begin;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub begin : Private {
+ my ( $self, $c ) = @_;
+ $self->SUPER::begin($c);
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/ArgsOrder.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/ArgsOrder.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/ArgsOrder.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,35 @@
+package TestApp::Controller::Action::Chained::ArgsOrder;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# This controller builds a simple chain of three actions that
+# will output the arguments they got passed to @_ after the
+# context object. We do this to test if that passing works
+# as it should.
+#
+
+sub base :Chained('/') PathPart('argsorder') CaptureArgs(0) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'base', $arg;
+}
+
+sub index :Chained('base') PathPart('') Args(0) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'index', $arg;
+}
+
+sub all :Chained('base') PathPart('') Args() {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'all', $arg;
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ no warnings 'uninitialized';
+ $c->response->body( join '; ', @{ $c->stash->{ passed_args } } );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Bar.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Bar.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Bar.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+package TestApp::Controller::Action::Chained::Auto::Bar;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# Test chain reaction if auto action returns 0.
+#
+sub auto : Private { 0 }
+
+sub barend : Chained('.') Args(1) { }
+
+sub crossloose : Chained PathPart('chained/auto_cross') CaptureArgs(1) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Detach.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Detach.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Detach.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,18 @@
+package TestApp::Controller::Action::Chained::Auto::Detach;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# For testing behaviour of a detaching auto action in a chain.
+#
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ $c->detach( '/action/chained/auto/fw3' );
+ return 1;
+}
+
+sub detachend : Chained('/action/chained/auto/dt1') Args(1) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Foo.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Foo.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Foo.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+package TestApp::Controller::Action::Chained::Auto::Foo;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# Test chain reaction if auto action returns 1.
+#
+sub auto : Private { 1 }
+
+sub fooend : Chained('.') Args(1) { }
+
+sub crossend : Chained('/action/chained/auto/bar/crossloose') Args(1) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Forward.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Forward.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto/Forward.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,18 @@
+package TestApp::Controller::Action::Chained::Auto::Forward;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# For testing behaviour of a forwarding auto action in a chain.
+#
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ $c->forward( '/action/chained/auto/fw3' );
+ return 1;
+}
+
+sub forwardend : Chained('/action/chained/auto/fw1') Args(1) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Auto.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,33 @@
+package TestApp::Controller::Action::Chained::Auto;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# Provided for sub-auto tests. This just always returns true.
+#
+sub auto : Private { 1 }
+
+#
+# Simple chains with auto actions returning 1 and 0
+#
+sub foo : Chained PathPart('chained/autochain1') CaptureArgs(1) { }
+sub bar : Chained PathPart('chained/autochain2') CaptureArgs(1) { }
+
+#
+# Detaching out of an auto action.
+#
+sub dt1 : Chained PathPart('chained/auto_detach') CaptureArgs(1) { }
+
+#
+# Forwarding out of an auto action.
+#
+sub fw1 : Chained PathPart('chained/auto_forward') CaptureArgs(1) { }
+
+#
+# Target for dispatch and forward tests.
+#
+sub fw3 : Private { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Bar.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Bar.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Bar.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,14 @@
+package TestApp::Controller::Action::Chained::Bar;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Controller/;
+
+#
+# Redispatching between controllers that are not in a parent/child
+# relation. This is the root.
+#
+sub cross1 :PathPart('chained/cross') :CaptureArgs(1) :Chained('/') { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Foo.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Foo.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Foo.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,39 @@
+package TestApp::Controller::Action::Chained::Foo;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Controller/;
+
+#
+# Child of current namespace
+#
+sub spoon :Chained('.') :Args(0) { }
+
+#
+# Root for a action in a "parent" controller
+#
+sub higher_root :PathPart('chained/higher_root') :Chained('/') :CaptureArgs(1) { }
+
+#
+# Parent controller -> this subcontroller -> parent controller test
+#
+sub pcp2 :Chained('/action/chained/pcp1') :CaptureArgs(1) { }
+
+#
+# Controllers not in parent/child relation. This tests the end.
+#
+sub cross2 :PathPart('end') :Chained('/action/chained/bar/cross1') :Args(1) { }
+
+#
+# Create a uri to the root index
+#
+sub to_root : Chained('/') PathPart('action/chained/to_root') {
+ my ( $self, $c ) = @_;
+ my $uri = $c->uri_for(
+ $c->controller('Root')->action_for('chain_root_index') );
+ $c->res->body( "URI:$uri" );
+ $c->stash->{no_end}++;
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/ParentChain.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/ParentChain.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/ParentChain.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,13 @@
+package TestApp::Controller::Action::Chained::ParentChain;
+use warnings;
+use strict;
+
+use base qw/ Catalyst::Controller /;
+
+#
+# Chains to the action /action/chained/parentchain in the
+# Action::Chained controller.
+#
+sub child :Chained('.') :Args(1) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/PassedArgs.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/PassedArgs.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/PassedArgs.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,34 @@
+package TestApp::Controller::Action::Chained::PassedArgs;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# This controller builds a simple chain of three actions that
+# will output the arguments they got passed to @_ after the
+# context object. We do this to test if that passing works
+# as it should.
+#
+
+sub first : PathPart('chained/passedargs/a') Chained('/') CaptureArgs(1) {
+ my ( $self, $c, $arg ) = @_;
+ $c->stash->{ passed_args } = [ $arg ];
+}
+
+sub second : PathPart('b') Chained('first') CaptureArgs(1) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, $arg;
+}
+
+sub third : PathPart('c') Chained('second') Args(1) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, $arg;
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ $c->response->body( join '; ', @{ $c->stash->{ passed_args } } );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Root.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Root.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained/Root.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,13 @@
+package TestApp::Controller::Action::Chained::Root;
+
+use strict;
+use warnings;
+
+use base qw( Catalyst::Controller );
+
+__PACKAGE__->config->{namespace} = '';
+
+sub rootsub : PathPart Chained( '/' ) CaptureArgs( 1 ) { }
+sub endpointsub : PathPart Chained( 'rootsub' ) Args( 1 ) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Chained.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,186 @@
+package TestApp::Controller::Action::Chained;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Controller/;
+
+sub begin :Private { }
+
+#
+# TODO
+# :Chained('') means what?
+#
+
+#
+# Simple parent/child action test
+#
+sub foo :PathPart('chained/foo') :CaptureArgs(1) :Chained('/') { }
+sub endpoint :PathPart('end') :Chained('/action/chained/foo') :Args(1) { }
+
+#
+# Parent/child test with two args each
+#
+sub foo2 :PathPart('chained/foo2') :CaptureArgs(2) :Chained('/') { }
+sub endpoint2 :PathPart('end2') :Chained('/action/chained/foo2') :Args(2) { }
+
+#
+# Relative specification of parent action
+#
+sub bar :PathPart('chained/bar') :Chained('/') :CaptureArgs(0) { }
+sub finale :PathPart('') :Chained('bar') :Args { }
+
+#
+# three chain with concurrent endpoints
+#
+sub one :PathPart('chained/one') :Chained('/') :CaptureArgs(1) { }
+sub two :PathPart('two') :Chained('/action/chained/one') :CaptureArgs(2) { }
+sub three_end :PathPart('three') :Chained('two') :Args(3) { }
+sub one_end :PathPart('chained/one') :Chained('/') :Args(1) { }
+sub two_end :PathPart('two') :Chained('one') :Args(2) { }
+
+#
+# Dispatch on number of arguments
+#
+sub multi1 :PathPart('chained/multi') :Chained('/') :Args(1) { }
+sub multi2 :PathPart('chained/multi') :Chained('/') :Args(2) { }
+
+#
+# Roots in an action defined in a higher controller
+#
+sub higher_root :PathPart('bar') :Chained('/action/chained/foo/higher_root') :Args(1) { }
+
+#
+# Controller -> subcontroller -> controller
+#
+sub pcp1 :PathPart('chained/pcp1') :Chained('/') :CaptureArgs(1) { }
+sub pcp3 :Chained('/action/chained/foo/pcp2') :Args(1) { }
+
+#
+# Dispatch on capture number
+#
+sub multi_cap1 :PathPart('chained/multi_cap') :Chained('/') :CaptureArgs(1) { }
+sub multi_cap2 :PathPart('chained/multi_cap') :Chained('/') :CaptureArgs(2) { }
+sub multi_cap_end1 :PathPart('baz') :Chained('multi_cap1') :Args(0) { }
+sub multi_cap_end2 :PathPart('baz') :Chained('multi_cap2') :Args(0) { }
+
+#
+# Priority: Slurpy args vs. chained actions
+#
+sub priority_a1 :PathPart('chained/priority_a') :Chained('/') :Args { }
+sub priority_a2 :PathPart('chained/priority_a') :Chained('/') :CaptureArgs(1) { }
+sub priority_a2_end :PathPart('end') :Chained('priority_a2') :Args(1) { }
+
+
+#
+# Priority: Fixed args vs. chained actions
+#
+sub priority_b1 :PathPart('chained/priority_b') :Chained('/') :Args(3) { }
+sub priority_b2 :PathPart('chained/priority_b') :Chained('/') :CaptureArgs(1) { }
+sub priority_b2_end :PathPart('end') :Chained('priority_b2') :Args(1) { }
+
+#
+# Priority: With no Args()
+#
+sub priority_c1 :PathPart('chained/priority_c') :Chained('/') :CaptureArgs(1) { }
+sub priority_c2 :PathPart('') :Chained('priority_c1') { }
+sub priority_c2_xyz :PathPart('xyz') :Chained('priority_c1') { }
+
+
+#
+# Optional specification of :Args in endpoint
+#
+sub opt_args :PathPart('chained/opt_args') :Chained('/') { }
+
+#
+# Optional PathPart test -> /chained/optpp/*/opt_pathpart/*
+#
+sub opt_pp_start :Chained('/') :PathPart('chained/optpp') :CaptureArgs(1) { }
+sub opt_pathpart :Chained('opt_pp_start') :Args(1) { }
+
+#
+# Optional Args *and* PathPart -> /chained/optall/*/oa/...
+#
+sub opt_all_start :Chained('/') :PathPart('chained/optall') :CaptureArgs(1) { }
+sub oa :Chained('opt_all_start') { }
+
+#
+# :Chained is the same as :Chained('/')
+#
+sub rootdef :Chained :PathPart('chained/rootdef') :Args(1) { }
+
+#
+# the ParentChain controller chains to this action by
+# specifying :Chained('.')
+#
+sub parentchain :Chained('/') :PathPart('chained/parentchain') :CaptureArgs(1) { }
+
+#
+# This is just for a test that a loose end is not callable
+#
+sub loose :Chained :PathPart('chained/loose') CaptureArgs(1) { }
+
+#
+# Forwarding out of the middle of a chain.
+#
+sub chain_fw_a :Chained :PathPart('chained/chain_fw') :CaptureArgs(1) {
+ $_[1]->forward( '/action/chained/fw_dt_target' );
+}
+sub chain_fw_b :Chained('chain_fw_a') :PathPart('end') :Args(1) { }
+
+#
+# Detaching out of the middle of a chain.
+#
+sub chain_dt_a :Chained :PathPart('chained/chain_dt') :CaptureArgs(1) {
+ $_[1]->detach( '/action/chained/fw_dt_target' );
+}
+sub chain_dt_b :Chained('chain_dt_a') :PathPart('end') :Args(1) { }
+
+#
+# Target for former forward and chain tests.
+#
+sub fw_dt_target :Private { }
+
+#
+# Test multiple chained actions with no captures
+#
+sub empty_chain_a : Chained('/') PathPart('chained/empty') CaptureArgs(0) { }
+sub empty_chain_b : Chained('empty_chain_a') PathPart('') CaptureArgs(0) { }
+sub empty_chain_c : Chained('empty_chain_b') PathPart('') CaptureArgs(0) { }
+sub empty_chain_d : Chained('empty_chain_c') PathPart('') CaptureArgs(1) { }
+sub empty_chain_e : Chained('empty_chain_d') PathPart('') CaptureArgs(0) { }
+sub empty_chain_f : Chained('empty_chain_e') PathPart('') Args(1) { }
+
+sub mult_nopp_base : Chained('/') PathPart('chained/mult_nopp') CaptureArgs(0) { }
+sub mult_nopp_all : Chained('mult_nopp_base') PathPart('') Args(0) { }
+sub mult_nopp_new : Chained('mult_nopp_base') PathPart('new') Args(0) { }
+sub mult_nopp_id : Chained('mult_nopp_base') PathPart('') CaptureArgs(1) { }
+sub mult_nopp_idall : Chained('mult_nopp_id') PathPart('') Args(0) { }
+sub mult_nopp_idnew : Chained('mult_nopp_id') PathPart('new') Args(0) { }
+
+#
+# Test Choice between branches and early return logic
+# Declaration order is important for $children->{$*}, since this is first match best.
+#
+sub cc_base : Chained('/') PathPart('chained/choose_capture') CaptureArgs(0) { }
+sub cc_link : Chained('cc_base') PathPart('') CaptureArgs(0) { }
+sub cc_anchor : Chained('cc_link') PathPart('anchor.html') Args(0) { }
+sub cc_all : Chained('cc_base') PathPart('') Args() { }
+
+sub cc_a : Chained('cc_base') PathPart('') CaptureArgs(1) { }
+sub cc_a_link : Chained('cc_a') PathPart('a') CaptureArgs(0) { }
+sub cc_a_anchor : Chained('cc_a_link') PathPart('') Args() { }
+
+sub cc_b : Chained('cc_base') PathPart('b') CaptureArgs(0) { }
+sub cc_b_link : Chained('cc_b') PathPart('') CaptureArgs(1) { }
+sub cc_b_anchor : Chained('cc_b_link') PathPart('anchor.html') Args() { }
+
+sub end :Private {
+ my ($self, $c) = @_;
+ return if $c->stash->{no_end};
+ my $out = join('; ', map { join(', ', @$_) }
+ ($c->req->captures, $c->req->args));
+ $c->res->body($out);
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Default.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Default.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Default.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,11 @@
+package TestApp::Controller::Action::Default;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Detach.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Detach.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Detach.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,45 @@
+package TestApp::Controller::Action::Detach;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub one : Local {
+ my ( $self, $c ) = @_;
+ $c->detach('two');
+ $c->forward('error');
+}
+
+sub two : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub error : Local {
+ my ( $self, $c ) = @_;
+ $c->res->output('error');
+}
+
+sub path : Local {
+ my ( $self, $c ) = @_;
+ $c->detach('/action/detach/two');
+ $c->forward('error');
+}
+
+sub with_args : Local {
+ my ( $self, $c, $orig ) = @_;
+ $c->detach( 'args', [qq/new/] );
+}
+
+sub with_method_and_args : Local {
+ my ( $self, $c, $orig ) = @_;
+ $c->detach( qw/TestApp::Controller::Action::Detach args/, [qq/new/] );
+}
+
+sub args : Local {
+ my ( $self, $c, $val ) = @_;
+ die "Expected argument 'new', got '$val'" unless $val eq 'new';
+ die "passed argument does not match args" unless $val eq $c->req->args->[0];
+ $c->res->body( $c->req->args->[0] );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/End.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/End.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/End.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,15 @@
+package TestApp::Controller::Action::End;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Forward.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Forward.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Forward.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,93 @@
+package TestApp::Controller::Action::Forward;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub one : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('two');
+}
+
+sub two : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('three');
+}
+
+sub three : Local {
+ my ( $self, $c ) = @_;
+ $c->forward( $self, 'four' );
+}
+
+sub four : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('/action/forward/five');
+}
+
+sub five : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('View::Dump::Request');
+}
+
+sub jojo : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('one');
+ $c->forward( $c->controller('Action::Forward'), 'three' );
+}
+
+sub inheritance : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('/action/inheritance/a/b/default');
+ $c->forward('five');
+}
+
+sub global : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('/global_action');
+}
+
+sub with_args : Local {
+ my ( $self, $c, $orig ) = @_;
+ $c->forward( 'args', [qq/new/] );
+ $c->res->body( $c->req->args->[0] );
+}
+
+sub with_method_and_args : Local {
+ my ( $self, $c, $orig ) = @_;
+ $c->forward( qw/TestApp::Controller::Action::Forward args/, [qq/new/] );
+ $c->res->body( $c->req->args->[0] );
+}
+
+sub args : Local {
+ my ( $self, $c, $val ) = @_;
+ die "Expected argument 'new', got '$val'" unless $val eq 'new';
+ die "passed argument does not match args" unless $val eq $c->req->args->[0];
+}
+
+sub args_embed_relative : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('embed/ok');
+}
+
+sub args_embed_absolute : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('/action/forward/embed/ok');
+}
+
+sub embed : Local {
+ my ( $self, $c, $ok ) = @_;
+
+ $ok ||= 'not ok';
+ $c->res->body($ok);
+}
+
+sub class_forward_test_action : Local {
+ my ( $self, $c ) = @_;
+ $c->forward(qw/TestApp class_forward_test_method/);
+}
+
+sub forward_to_uri_check : Local {
+ my ( $self, $c ) = @_;
+ $c->forward( 'Action::ForwardTo', 'uri_check' );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/ForwardTo.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/ForwardTo.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/ForwardTo.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,11 @@
+package TestApp::Controller::Action::ForwardTo;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub uri_check : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( $c->uri_for('foo/bar')->path );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Global.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Global.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Global.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,21 @@
+package TestApp::Controller::Action::Global;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub action_global_one : Action Absolute {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub action_global_two : Action Global {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub action_global_three : Action Path('/action_global_three') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Index.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Index.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Index.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,11 @@
+package TestApp::Controller::Action::Index;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub index : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'Action-Index index' );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Inheritance.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Inheritance.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Inheritance.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,74 @@
+package TestApp::Controller::Action::Inheritance;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ return 1;
+}
+
+sub begin : Private {
+ my ( $self, $c ) = @_;
+ $self->SUPER::begin($c);
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+}
+
+package TestApp::Controller::Action::Inheritance::A;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ return 1;
+}
+
+sub begin : Private {
+ my ( $self, $c ) = @_;
+ $self->SUPER::begin($c);
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+}
+
+package TestApp::Controller::Action::Inheritance::A::B;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ return 1;
+}
+
+sub begin : Private {
+ my ( $self, $c ) = @_;
+ $self->SUPER::begin($c);
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+}
+
+1;
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Local.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Local.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Local.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,26 @@
+package TestApp::Controller::Action::Local;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub one : Action Relative {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub two : Action Local Args(2) {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub three : Action Path('three') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub four : Action Path('four/five/six') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Path.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Path.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Path.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,38 @@
+package TestApp::Controller::Action::Path;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+__PACKAGE__->config(
+ actions => {
+ 'one' => { 'Path' => [ 'a path with spaces' ] },
+ 'two' => { 'Path' => "åäö" },
+ },
+);
+
+sub one : Action Path("this_will_be_overriden") {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub two : Action {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub three :Path {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub four : Path( 'spaces_near_parens_singleq' ) {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub five : Path( "spaces_near_parens_doubleq" ) {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Private.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Private.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Private.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,36 @@
+package TestApp::Controller::Action::Private;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->res->output('access denied');
+}
+
+sub one : Private {
+ my ( $self, $c ) = @_;
+ $c->res->output('access allowed');
+}
+
+sub two : Private Relative {
+ my ( $self, $c ) = @_;
+ $c->res->output('access allowed');
+}
+
+sub three : Private Absolute {
+ my ( $self, $c ) = @_;
+ $c->res->output('access allowed');
+}
+
+sub four : Private Path('/action/private/four') {
+ my ( $self, $c ) = @_;
+ $c->res->output('access allowed');
+}
+
+sub five : Private Path('five') {
+ my ( $self, $c ) = @_;
+ $c->res->output('access allowed');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Regexp.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Regexp.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Regexp.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,21 @@
+package TestApp::Controller::Action::Regexp;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub one : Action Regex('^action/regexp/(\w+)/(\d+)$') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub two : Action LocalRegexp('^(\d+)/(\w+)$') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub three : Action LocalRegex('^(mandatory)(/optional)?$'){
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Streaming.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Streaming.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/Streaming.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,30 @@
+package TestApp::Controller::Action::Streaming;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub streaming : Global {
+ my ( $self, $c ) = @_;
+ for my $line ( split "\n", <<'EOF' ) {
+foo
+bar
+baz
+EOF
+ $c->res->write("$line\n");
+ }
+}
+
+sub body : Local {
+ my ( $self, $c ) = @_;
+
+ my $file = "$FindBin::Bin/01use.t";
+ my $fh = IO::File->new( $file, 'r' );
+ if ( defined $fh ) {
+ $c->res->body( $fh );
+ }
+ else {
+ $c->res->body( "Unable to read $file" );
+ }
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/TestMultipath.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/TestMultipath.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/TestMultipath.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,21 @@
+package TestApp::Controller::Action::TestMultipath;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+__PACKAGE__->config(
+ namespace => 'action/multipath'
+);
+
+sub multipath : Local : Global : Path('/multipath1') : Path('multipath2') {
+ my ( $self, $c ) = @_;
+ for my $line ( split "\n", <<'EOF' ) {
+foo
+bar
+baz
+EOF
+ $c->res->write("$line\n");
+ }
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/TestRelative.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/TestRelative.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action/TestRelative.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,20 @@
+package TestApp::Controller::Action::TestRelative;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+__PACKAGE__->config(
+ path => 'action/relative'
+);
+
+sub relative : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('/action/forward/one');
+}
+
+sub relative_two : Local {
+ my ( $self, $c ) = @_;
+ $c->forward( 'TestApp::Controller::Action::Forward', 'one' );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Action.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,18 @@
+package TestApp::Controller::Action;
+
+use strict;
+use base 'Catalyst::Controller';
+
+sub begin : Private {
+ my ( $self, $c ) = @_;
+ $c->res->header( 'X-Test-Class' => ref($self) );
+ $c->response->content_type('text/plain; charset=utf-8');
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->res->output("Error - TestApp::Controller::Action\n");
+ $c->res->status(404);
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Args.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Args.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Args.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,17 @@
+package TestApp::Controller::Args;
+
+use strict;
+use base 'Catalyst::Base';
+use Data::Dumper;
+
+sub args :Local {
+ my ( $self, $c ) = @_;
+ $c->res->body( join('',@{$c->req->args}) );
+}
+
+sub params :Local {
+ my ( $self, $c ) = splice @_, 0, 2;
+ $c->res->body( join('', at _) );
+}
+
+1;
\ No newline at end of file
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Dump.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Dump.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Dump.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,32 @@
+package TestApp::Controller::Dump;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub default : Action Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump');
+}
+
+sub env : Action Relative {
+ my ( $self, $c ) = @_;
+ $c->stash( env => \%ENV );
+ $c->forward('TestApp::View::Dump');
+}
+
+sub parameters : Action Relative {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Parameters');
+}
+
+sub request : Action Relative {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub response : Action Relative {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Response');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/URI.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/URI.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/URI.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,80 @@
+package TestApp::Controller::Engine::Request::URI;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub change_path : Local {
+ my ( $self, $c ) = @_;
+
+ # change the path
+ $c->req->path( '/my/app/lives/here' );
+
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub change_base : Local {
+ my ( $self, $c ) = @_;
+
+ # change the base and uri paths
+ $c->req->base->path( '/new/location' );
+ $c->req->uri->path( '/new/location/engine/request/uri/change_base' );
+
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub uri_with : Local {
+ my ( $self, $c ) = @_;
+
+ # change the current uri
+ my $uri = $c->req->uri_with( { b => 1 } );
+ my %query = $uri->query_form;
+
+ $c->res->header( 'X-Catalyst-Param-a' => $query{ a } );
+ $c->res->header( 'X-Catalyst-Param-b' => $query{ b } );
+
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub uri_with_object : Local {
+ my ( $self, $c ) = @_;
+
+ my $uri = $c->req->uri_with( { a => $c->req->base } );
+ my %query = $uri->query_form;
+
+ $c->res->header( 'X-Catalyst-Param-a' => $query{ a } );
+
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub uri_with_utf8 : Local {
+ my ( $self, $c ) = @_;
+
+ # change the current uri
+ my $uri = $c->req->uri_with( { unicode => "\x{2620}" } );
+
+ $c->res->header( 'X-Catalyst-uri-with' => "$uri" );
+
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub uri_with_undef : Local {
+ my ( $self, $c ) = @_;
+
+ my $warnings = 0;
+ local $SIG{__WARN__} = sub { $warnings++ };
+
+ # change the current uri
+ my $uri = $c->req->uri_with( { foo => undef } );
+
+ $c->res->header( 'X-Catalyst-warnings' => $warnings );
+
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/Uploads.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/Uploads.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Request/Uploads.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,12 @@
+package TestApp::Controller::Engine::Request::Uploads;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub slurp : Relative {
+ my ( $self, $c ) = @_;
+ $c->response->content_type('text/plain; charset=utf-8');
+ $c->response->output( $c->request->upload('slurp')->slurp );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Cookies.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Cookies.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Cookies.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,35 @@
+package TestApp::Controller::Engine::Response::Cookies;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub one : Local {
+ my ( $self, $c ) = @_;
+ $c->res->cookies->{catalyst} = { value => 'cool', path => '/bah' };
+ $c->res->cookies->{cool} = { value => 'catalyst', path => '/' };
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub two : Local {
+ my ( $self, $c ) = @_;
+ $c->res->cookies->{catalyst} = { value => 'cool', path => '/bah' };
+ $c->res->cookies->{cool} = { value => 'catalyst', path => '/' };
+ $c->res->redirect('http://www.google.com/');
+}
+
+sub three : Local {
+ my ( $self, $c ) = @_;
+
+ $c->res->cookies->{object} = CGI::Simple::Cookie->new(
+ -name => "this_is_the_real_name",
+ -value => [qw/foo bar/],
+ );
+
+ $c->res->cookies->{hash} = {
+ value => [qw/a b c/],
+ };
+
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Errors.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Errors.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Errors.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,23 @@
+package TestApp::Controller::Engine::Response::Errors;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub one : Relative {
+ my ( $self, $c ) = @_;
+ my $a = 0;
+ my $b = 0;
+ my $t = $a / $b;
+}
+
+sub two : Relative {
+ my ( $self, $c ) = @_;
+ $c->forward('/non/existing/path');
+}
+
+sub three : Relative {
+ my ( $self, $c ) = @_;
+ die("I'm going to die!\n");
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Headers.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Headers.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Headers.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,14 @@
+package TestApp::Controller::Engine::Response::Headers;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub one : Relative {
+ my ( $self, $c ) = @_;
+ $c->res->header( 'X-Header-Catalyst' => 'Cool' );
+ $c->res->header( 'X-Header-Cool' => 'Catalyst' );
+ $c->res->header( 'X-Header-Numbers' => join ', ', 1 .. 10 );
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Large.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Large.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Large.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+package TestApp::Controller::Engine::Response::Large;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub one : Relative {
+ my ( $self, $c ) = @_;
+ $c->res->output( 'x' x (100 * 1024) );
+}
+
+sub two : Relative {
+ my ( $self, $c ) = @_;
+ $c->res->output( 'y' x (1024 * 1024) );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Redirect.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Redirect.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Redirect.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,29 @@
+package TestApp::Controller::Engine::Response::Redirect;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub one : Relative {
+ my ( $self, $c ) = @_;
+ $c->response->redirect('/test/writing/is/boring');
+}
+
+sub two : Relative {
+ my ( $self, $c ) = @_;
+ $c->response->redirect('http://www.google.com/');
+}
+
+sub three : Relative {
+ my ( $self, $c ) = @_;
+ $c->response->redirect('http://www.google.com/');
+ $c->response->status(301); # Moved Permanently
+}
+
+sub four : Relative {
+ my ( $self, $c ) = @_;
+ $c->response->redirect('http://www.google.com/');
+ $c->response->status(307); # Temporary Redirect
+}
+
+1;
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Status.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Status.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Engine/Response/Status.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,42 @@
+package TestApp::Controller::Engine::Response::Status;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub begin : Private {
+ my ( $self, $c ) = @_;
+ $c->response->content_type('text/plain');
+ return 1;
+}
+
+sub s200 : Relative {
+ my ( $self, $c ) = @_;
+ $c->res->status(200);
+ $c->res->output("200 OK\n");
+}
+
+sub s400 : Relative {
+ my ( $self, $c ) = @_;
+ $c->res->status(400);
+ $c->res->output("400 Bad Request\n");
+}
+
+sub s403 : Relative {
+ my ( $self, $c ) = @_;
+ $c->res->status(403);
+ $c->res->output("403 Forbidden\n");
+}
+
+sub s404 : Relative {
+ my ( $self, $c ) = @_;
+ $c->res->status(404);
+ $c->res->output("404 Not Found\n");
+}
+
+sub s500 : Relative {
+ my ( $self, $c ) = @_;
+ $c->res->status(500);
+ $c->res->output("500 Internal Server Error\n");
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Fork.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Fork.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Fork.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,60 @@
+#!/usr/bin/perl
+# Fork.pm
+# Copyright (c) 2006 Jonathan Rockway <jrockway at cpan.org>
+
+package TestApp::Controller::Fork;
+
+use strict;
+use warnings;
+use base 'Catalyst::Controller';
+use YAML;
+
+sub system : Local {
+ my ($self, $c, $ls) = @_;
+ my ($result, $code) = (undef, 1);
+
+ if(!-e $ls || !-x _){
+ $result = 'skip';
+ }
+ else {
+ $result = system($ls, $ls, $ls);
+ $result = $! if $result != 0;
+ }
+
+ $c->response->body(Dump({result => $result}));
+}
+
+sub backticks : Local {
+ my ($self, $c, $ls) = @_;
+ my ($result, $code) = (undef, 1);
+
+ if(!-e $ls || !-x _){
+ $result = 'skip';
+ $code = 0;
+ }
+ else {
+ $result = `$ls $ls $ls` || $!;
+ $code = $?;
+ }
+
+ $c->response->body(Dump({result => $result, code => $code}));
+}
+
+sub fork : Local {
+ my ($self, $c) = @_;
+ my $pid;
+ my $x = 0;
+
+ if($pid = fork()){
+ $x = "ok";
+ }
+ else {
+ exit(0);
+ }
+
+ waitpid $pid,0 or die;
+
+ $c->response->body(Dump({pid => $pid, result => $x}));
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Index.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Index.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Index.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,11 @@
+package TestApp::Controller::Index;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub index : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'Index index' );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/MultiMethod.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/MultiMethod.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/MultiMethod.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,19 @@
+package TestApp::Controller::Priorities::MultiMethod;
+
+use strict;
+use warnings;
+use base qw/Catalyst::Controller/;
+
+sub auto :Private {
+ my ($self, $c) = @_;
+ $c->res->body(join(' ', $c->action->name, @{$c->req->args}));
+ return 1;
+}
+
+sub zero :Path :Args(0) { }
+
+sub one :Path :Args(1) { }
+
+sub two :Path :Args(2) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/loc_vs_index.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/loc_vs_index.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/loc_vs_index.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,8 @@
+package TestApp::Controller::Priorities::loc_vs_index;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub index :Private { $_[1]->res->body( 'index' ) }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/locre_vs_index.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/locre_vs_index.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/locre_vs_index.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,8 @@
+package TestApp::Controller::Priorities::locre_vs_index;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub index :Private { $_[1]->res->body( 'index' ) }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/path_vs_index.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/path_vs_index.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/path_vs_index.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,8 @@
+package TestApp::Controller::Priorities::path_vs_index;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub index :Private { $_[1]->res->body( 'index' ) }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/re_vs_index.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/re_vs_index.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities/re_vs_index.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,8 @@
+package TestApp::Controller::Priorities::re_vs_index;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub index :Private { $_[1]->res->body( 'index' ) }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Priorities.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,75 @@
+package TestApp::Controller::Priorities;
+
+use strict;
+use base 'Catalyst::Base';
+
+#
+# Regex vs. Local
+#
+
+sub re_vs_loc_re :Regex('/priorities/re_vs_loc') { $_[1]->res->body( 'regex' ) }
+sub re_vs_loc :Local { $_[1]->res->body( 'local' ) }
+
+#
+# Regex vs. LocalRegex
+#
+
+sub re_vs_locre_locre :LocalRegex('re_vs_(locre)') { $_[1]->res->body( 'local_regex' ) }
+sub re_vs_locre_re :Regex('/priorities/re_vs_locre') { $_[1]->res->body( 'regex' ) }
+
+#
+# Regex vs. Path
+#
+
+sub re_vs_path_path :Path('/priorities/re_vs_path') { $_[1]->res->body( 'path' ) }
+sub re_vs_path_re :Regex('/priorities/re_vs_path') { $_[1]->res->body( 'regex' ) }
+
+#
+# Local vs. LocalRegex
+#
+
+sub loc_vs_locre_locre :LocalRegex('loc_vs_locre') { $_[1]->res->body( 'local_regex' ) }
+sub loc_vs_locre :Local { $_[1]->res->body( 'local' ) }
+
+#
+# Local vs. Path (depends on definition order)
+#
+
+sub loc_vs_path1_loc :Path('/priorities/loc_vs_path1') { $_[1]->res->body( 'path' ) }
+sub loc_vs_path1 :Local { $_[1]->res->body( 'local' ) }
+
+sub loc_vs_path2 :Local { $_[1]->res->body( 'local' ) }
+sub loc_vs_path2_loc :Path('/priorities/loc_vs_path2') { $_[1]->res->body( 'path' ) }
+
+#
+# Path vs. LocalRegex
+#
+
+sub path_vs_locre_locre :LocalRegex('path_vs_(locre)') { $_[1]->res->body( 'local_regex' ) }
+sub path_vs_locre_path :Path('/priorities/path_vs_locre') { $_[1]->res->body( 'path' ) }
+
+#
+# Regex vs. index (has sub controller)
+#
+
+sub re_vs_idx :Regex('/priorities/re_vs_index') { $_[1]->res->body( 'regex' ) }
+
+#
+# Local vs. index (has sub controller)
+#
+
+sub loc_vs_index :Local { $_[1]->res->body( 'local' ) }
+
+#
+# LocalRegex vs. index (has sub controller)
+#
+
+sub locre_vs_idx :LocalRegex('locre_vs_index') { $_[1]->res->body( 'local_regex' ) }
+
+#
+# Path vs. index (has sub controller)
+#
+
+sub path_vs_idx :Path('/priorities/path_vs_index') { $_[1]->res->body( 'path' ) }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Root.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Root.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Controller/Root.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+package TestApp::Controller::Root;
+
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+sub chain_root_index : Chained('/') PathPart('') Args(0) { }
+
+sub zero : Path('0') {
+ my ( $self, $c ) = @_;
+ $c->res->header( 'X-Test-Class' => ref($self) );
+ $c->response->content_type('text/plain; charset=utf-8');
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo/Bar.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo/Bar.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo/Bar.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,5 @@
+package TestApp::Model::Foo::Bar;
+
+sub model_foo_bar_method_from_foo_bar { "model_foo_bar_method_from_foo_bar" }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Model/Foo.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+package TestApp::Model::Foo;
+
+use strict;
+use warnings;
+
+use base qw/ Catalyst::Model /;
+
+sub model_foo_method { 1 }
+
+package TestApp::Model::Foo::Bar;
+sub model_foo_bar_method_from_foo { 1 }
+
+package TestApp::Model::Foo;
+sub bar { "TestApp::Model::Foo::Bar" }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Plugin/FullyQualified.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Plugin/FullyQualified.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/Plugin/FullyQualified.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,13 @@
+package TestApp::Plugin::FullyQualified;
+
+use strict;
+
+sub fully_qualified {
+ my $c = shift;
+
+ $c->stash->{fully_qualified} = 1;
+
+ return $c;
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Parameters.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Parameters.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Parameters.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,11 @@
+package TestApp::View::Dump::Parameters;
+
+use strict;
+use base 'TestApp::View::Dump';
+
+sub process {
+ my ( $self, $c ) = @_;
+ return $self->SUPER::process( $c, $c->req->parameters );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Request.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Request.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Request.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,11 @@
+package TestApp::View::Dump::Request;
+
+use strict;
+use base qw[TestApp::View::Dump];
+
+sub process {
+ my ( $self, $c ) = @_;
+ return $self->SUPER::process( $c, $c->request );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Response.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Response.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump/Response.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,11 @@
+package TestApp::View::Dump::Response;
+
+use strict;
+use base qw[TestApp::View::Dump];
+
+sub process {
+ my ( $self, $c ) = @_;
+ return $self->SUPER::process( $c, $c->response );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp/View/Dump.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,57 @@
+package TestApp::View::Dump;
+
+use strict;
+use base 'Catalyst::Base';
+
+use Data::Dumper ();
+use Scalar::Util qw(weaken);
+
+sub dump {
+ my ( $self, $reference ) = @_;
+
+ return unless $reference;
+
+ my $dumper = Data::Dumper->new( [$reference] );
+ $dumper->Indent(1);
+ $dumper->Purity(1);
+ $dumper->Useqq(0);
+ $dumper->Deepcopy(1);
+ $dumper->Quotekeys(0);
+ $dumper->Terse(1);
+
+ return $dumper->Dump;
+}
+
+sub process {
+ my ( $self, $c, $reference ) = @_;
+
+ # Force processing of on-demand data
+ $c->prepare_body;
+
+ # Remove context from reference if needed
+ my $context = delete $reference->{_context};
+
+ # Remove body from reference if needed
+ my $body = delete $reference->{_body};
+
+ if ( my $output =
+ $self->dump( $reference || $c->stash->{dump} || $c->stash ) )
+ {
+
+ $c->res->headers->content_type('text/plain');
+ $c->res->output($output);
+
+ # Repair context
+ $reference->{_context} = $context;
+ weaken( $reference->{_context} );
+
+ # Repair body
+ $reference->{_body} = $body;
+
+ return 1;
+ }
+
+ return 0;
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestApp.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,101 @@
+package TestApp;
+
+use strict;
+use Catalyst qw/
+ Test::Errors
+ Test::Headers
+ Test::Plugin
+ Test::Inline
+ +TestApp::Plugin::FullyQualified
+/;
+use Catalyst::Utils;
+
+our $VERSION = '0.01';
+
+TestApp->config( name => 'TestApp', root => '/some/dir' );
+
+TestApp->setup;
+
+sub index : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body('root index');
+}
+
+sub global_action : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub execute {
+ my $c = shift;
+ my $class = ref( $c->component( $_[0] ) ) || $_[0];
+ my $action = "$_[1]";
+
+ my $method;
+
+ if ( $action =~ /->(\w+)$/ ) {
+ $method = $1;
+ }
+ elsif ( $action =~ /\/(\w+)$/ ) {
+ $method = $1;
+ }
+ elsif ( $action =~ /^(\w+)$/ ) {
+ $method = $action;
+ }
+
+ if ( $class && $method && $method !~ /^_/ ) {
+ my $executed = sprintf( "%s->%s", $class, $method );
+ my @executed = $c->response->headers->header('X-Catalyst-Executed');
+ push @executed, $executed;
+ $c->response->headers->header(
+ 'X-Catalyst-Executed' => join ', ',
+ @executed
+ );
+ }
+
+ return $c->SUPER::execute(@_);
+}
+
+# Replace the very large HTML error page with
+# useful info if something crashes during a test
+sub finalize_error {
+ my $c = shift;
+
+ $c->NEXT::finalize_error(@_);
+
+ $c->res->status(500);
+ $c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) );
+}
+
+sub class_forward_test_method :Private {
+ my ( $self, $c ) = @_;
+ $c->response->headers->header( 'X-Class-Forward-Test-Method' => 1 );
+}
+
+sub loop_test : Local {
+ my ( $self, $c ) = @_;
+
+ for( 1..1001 ) {
+ $c->forward( 'class_forward_test_method' );
+ }
+}
+
+sub recursion_test : Local {
+ my ( $self, $c ) = @_;
+ $c->forward( 'recursion_test' );
+}
+
+{
+ no warnings 'redefine';
+ sub Catalyst::Log::error { }
+}
+
+# Make sure we can load Inline plugins.
+
+package Catalyst::Plugin::Test::Inline;
+
+use strict;
+
+use base qw/Catalyst::Base Class::Data::Inheritable/;
+
+1;
\ No newline at end of file
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart/Controller/Foo.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart/Controller/Foo.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart/Controller/Foo.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,10 @@
+package TestAppChainedAbsolutePathPart::Controller::Foo;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Controller/;
+
+sub foo : Chained PathPart('/foo/bar') Args(1) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedAbsolutePathPart.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,20 @@
+package TestAppChainedAbsolutePathPart;
+
+use strict;
+use Catalyst qw/
+ Test::Errors
+ Test::Headers
+/;
+use Catalyst::Utils;
+
+our $VERSION = '0.01';
+
+TestAppChainedAbsolutePathPart
+ ->config(
+ name => 'TestAppChainedAbsolutePathPart',
+ root => '/some/dir'
+ );
+
+TestAppChainedAbsolutePathPart->setup;
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive/Controller/Foo.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive/Controller/Foo.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive/Controller/Foo.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,11 @@
+package TestAppChainedRecursive::Controller::Foo;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Controller/;
+
+sub foo : Chained('bar') CaptureArgs(1) { }
+sub bar : Chained('foo') CaptureArgs(1) { }
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppChainedRecursive.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,19 @@
+package TestAppChainedRecursive;
+
+use strict;
+use Catalyst qw/
+ Test::Errors
+ Test::Headers
+/;
+use Catalyst::Utils;
+
+our $VERSION = '0.01';
+
+TestAppChainedRecursive->config(
+ name => 'TestAppChainedRecursive',
+ root => '/some/dir'
+);
+
+TestAppChainedRecursive->setup;
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppDoubleAutoBug.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppDoubleAutoBug.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppDoubleAutoBug.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,59 @@
+use strict;
+use warnings;
+
+package TestAppDoubleAutoBug;
+
+use Catalyst qw/
+ Test::Errors
+ Test::Headers
+ Test::Plugin
+/;
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config( name => 'TestAppDoubleAutoBug', root => '/some/dir' );
+
+__PACKAGE__->setup;
+
+sub execute {
+ my $c = shift;
+ my $class = ref( $c->component( $_[0] ) ) || $_[0];
+ my $action = "$_[1]";
+
+ my $method;
+
+ if ( $action =~ /->(\w+)$/ ) {
+ $method = $1;
+ }
+ elsif ( $action =~ /\/(\w+)$/ ) {
+ $method = $1;
+ }
+ elsif ( $action =~ /^(\w+)$/ ) {
+ $method = $action;
+ }
+
+ if ( $class && $method && $method !~ /^_/ ) {
+ my $executed = sprintf( "%s->%s", $class, $method );
+ my @executed = $c->response->headers->header('X-Catalyst-Executed');
+ push @executed, $executed;
+ $c->response->headers->header(
+ 'X-Catalyst-Executed' => join ', ',
+ @executed
+ );
+ }
+
+ return $c->SUPER::execute(@_);
+}
+
+
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ ++$c->stash->{auto_count};
+ return 1;
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( sprintf 'default, auto=%d', $c->stash->{auto_count} );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand/Controller/Body.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand/Controller/Body.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand/Controller/Body.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,29 @@
+package TestAppOnDemand::Controller::Body;
+
+use strict;
+use base 'Catalyst::Base';
+
+use Data::Dump ();
+
+sub params : Local {
+ my ( $self, $c ) = @_;
+
+ $c->res->body( Data::Dump::dump( $c->req->body_parameters ) );
+}
+
+sub read : Local {
+ my ( $self, $c ) = @_;
+
+ # read some data
+ my @chunks;
+
+ while ( my $data = $c->read( 10_000 ) ) {
+ push @chunks, $data;
+ }
+
+ $c->res->content_type( 'text/plain');
+
+ $c->res->body( join ( '|', map { length $_ } @chunks ) );
+}
+
+1;
\ No newline at end of file
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppOnDemand.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,20 @@
+package TestAppOnDemand;
+
+use strict;
+use Catalyst qw/
+ Test::Errors
+ Test::Headers
+/;
+use Catalyst::Utils;
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config(
+ name => __PACKAGE__,
+ root => '/some/dir',
+ parse_on_demand => 1,
+);
+
+__PACKAGE__->setup;
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppPathBug.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppPathBug.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppPathBug.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,19 @@
+use strict;
+use warnings;
+
+package TestAppPathBug;
+
+use Catalyst;
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config( name => 'TestAppPathBug', root => '/some/dir' );
+
+__PACKAGE__->setup;
+
+sub foo : Path {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'This is the foo method.' );
+}
+
+1;
Added: Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppStats.pm
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppStats.pm (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/lib/TestAppStats.pm 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,31 @@
+use strict;
+use warnings;
+
+package TestAppStats;
+
+use Catalyst qw/
+ -Stats=1
+/;
+
+our $VERSION = '0.01';
+our @log_messages;
+
+__PACKAGE__->config( name => 'TestAppStats', root => '/some/dir' );
+
+__PACKAGE__->log(TestAppStats::Log->new);
+
+__PACKAGE__->setup;
+
+# Return log messages from previous request
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->stats->profile("test");
+ $c->res->body(join("\n", @log_messages));
+ @log_messages = ();
+}
+
+package TestAppStats::Log;
+use base qw/Catalyst::Log/;
+
+sub info { push(@log_messages, @_); }
+sub debug { push(@log_messages, @_); }
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_action.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_action.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_action.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,110 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 28 * $iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action_action_one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_action_one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Action',
+ 'Test Class'
+ );
+ is( $response->header('X-Action'), 'works' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action_action_two'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_action_two', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Action',
+ 'Test Class'
+ );
+ is( $response->header('X-Action-After'), 'awesome' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action_action_three/one/two'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_action_three', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Action',
+ 'Test Class'
+ );
+ is( $response->header('X-TestAppActionTestBefore'), 'one' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action_action_four'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_action_four', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Action',
+ 'Test Class'
+ );
+ is( $response->header('X-TestAppActionTestMyAction'), 'MyAction works' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_auto.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_auto.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_auto.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,136 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 18*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+
+ # new dispatcher:
+ # 11 wallclock secs (10.14 usr + 0.20 sys = 10.34 CPU) @ 15.18/s (n=157)
+ # old dispatcher (r1486):
+ # 11 wallclock secs (10.34 usr + 0.20 sys = 10.54 CPU) @ 13.76/s (n=145)
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ # test auto + local method
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto->one
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/one'), 'auto + local' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'one', 'Content OK' );
+ }
+
+ # test auto + default
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto->default
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/anything'), 'auto + default' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'default', 'Content OK' );
+ }
+
+ # test auto + auto + local
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto::Deep->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto::Deep->auto
+ TestApp::Controller::Action::Auto::Deep->one
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/deep/one'), 'auto + auto + local' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'deep one', 'Content OK' );
+ }
+
+ # test auto + auto + default
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto::Deep->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto::Deep->auto
+ TestApp::Controller::Action::Auto::Deep->default
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/deep/anything'), 'auto + auto + default' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'deep default', 'Content OK' );
+ }
+
+ # test auto + failing auto + local + end
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto::Abort->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto::Abort->auto
+ TestApp::Controller::Action::Auto::Abort->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/abort/one'), 'auto + failing auto + local' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'abort end', 'Content OK' );
+ }
+
+ # test auto + default (bug on invocation of default twice)
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto::Default->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto::Default->auto
+ TestApp::Controller::Action::Auto::Default->default
+ TestApp::Controller::Action::Auto::Default->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/default/moose'), 'auto + default' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'default (auto: 1)', 'Content OK' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_begin.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_begin.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_begin.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,53 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 7*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Begin->begin
+ TestApp::Controller::Action::Begin->default
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/begin'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Begin',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_chained.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_chained.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_chained.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,866 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 124*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests($_);
+ }
+}
+
+sub run_tests {
+ my ($run_number) = @_;
+
+ #
+ # This is a simple test where the parent and child actions are
+ # within the same controller.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->foo
+ TestApp::Controller::Action::Chained->endpoint
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/foo/1/end/2'), 'chained + local endpoint' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # This makes sure the above isn't found if the argument for the
+ # end action isn't supplied.
+ #
+ {
+ my $expected = undef;
+
+ ok( my $response = request('http://localhost/chained/foo/1/end'),
+ 'chained + local endpoint; missing last argument' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->code, 500, 'Status OK' );
+ }
+
+ #
+ # Tests the case when the child action is placed in a subcontroller.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->foo
+ TestApp::Controller::Action::Chained::Foo->spoon
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/foo/1/spoon'), 'chained + subcontroller endpoint' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; ', 'Content OK' );
+ }
+
+ #
+ # Tests if the relative specification (e.g.: Chained('bar') ) works
+ # as expected.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->bar
+ TestApp::Controller::Action::Chained->finale
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/bar/1/spoon'), 'chained + relative endpoint' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 1, spoon', 'Content OK' );
+ }
+
+ #
+ # Just a test for multiple arguments.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->foo2
+ TestApp::Controller::Action::Chained->endpoint2
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/foo2/10/20/end2/15/25'),
+ 'chained + local (2 args each)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '10, 20; 15, 25', 'Content OK' );
+ }
+
+ #
+ # The first three-chain test tries to call the action with :Args(1)
+ # specification. There's also a one action with a :CaptureArgs(1)
+ # attribute, that should not be dispatched to.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->one_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/one/23'),
+ 'three-chain (only first)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 23', 'Content OK' );
+ }
+
+ #
+ # This is the second three-chain test, it goes for the action that
+ # handles "/one/$cap/two/$arg1/$arg2" paths. Should be the two action
+ # having :Args(2), not the one having :CaptureArgs(2).
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->one
+ TestApp::Controller::Action::Chained->two_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/one/23/two/23/46'),
+ 'three-chain (up to second)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '23; 23, 46', 'Content OK' );
+ }
+
+ #
+ # Last of the three-chain tests. Has no concurrent action with :CaptureArgs
+ # and is more thought to simply test the chain as a whole and the 'two'
+ # action specifying :CaptureArgs.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->one
+ TestApp::Controller::Action::Chained->two
+ TestApp::Controller::Action::Chained->three_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/one/23/two/23/46/three/1/2/3'),
+ 'three-chain (all three)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '23, 23, 46; 1, 2, 3', 'Content OK' );
+ }
+
+ #
+ # Tests dispatching on number of arguments for :Args. This should be
+ # dispatched to the action expecting one argument.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->multi1
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/multi/23'),
+ 'multi-action (one arg)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 23', 'Content OK' );
+ }
+
+ #
+ # Belongs to the former test and goes for the action expecting two arguments.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->multi2
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/multi/23/46'),
+ 'multi-action (two args)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 23, 46', 'Content OK' );
+ }
+
+ #
+ # Dispatching on argument count again, this time we provide too many
+ # arguments, so dispatching should fail.
+ #
+ {
+ my $expected = undef;
+
+ ok( my $response = request('http://localhost/chained/multi/23/46/67'),
+ 'multi-action (three args, should lead to error)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->code, 500, 'Status OK' );
+ }
+
+ #
+ # This tests the case when an action says it's the child of an action in
+ # a subcontroller.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Foo->higher_root
+ TestApp::Controller::Action::Chained->higher_root
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/higher_root/23/bar/11'),
+ 'root higher than child' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '23; 11', 'Content OK' );
+ }
+
+ #
+ # Just a more complex version of the former test. It tests if a controller ->
+ # subcontroller -> controller dispatch works.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->pcp1
+ TestApp::Controller::Action::Chained::Foo->pcp2
+ TestApp::Controller::Action::Chained->pcp3
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/pcp1/1/pcp2/2/pcp3/3'),
+ 'parent -> child -> parent' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1, 2; 3', 'Content OK' );
+ }
+
+ #
+ # Tests dispatch on capture number. This test is for a one capture action.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->multi_cap1
+ TestApp::Controller::Action::Chained->multi_cap_end1
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/multi_cap/1/baz'),
+ 'dispatch on capture num 1' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; ', 'Content OK' );
+ }
+
+ #
+ # Belongs to the former test. This one goes for the action expecting two
+ # captures.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->multi_cap2
+ TestApp::Controller::Action::Chained->multi_cap_end2
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/multi_cap/1/2/baz'),
+ 'dispatch on capture num 2' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1, 2; ', 'Content OK' );
+ }
+
+ #
+ # Tests the priority of a slurpy arguments action (with :Args) against
+ # two actions chained together. The two actions should win.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->priority_a2
+ TestApp::Controller::Action::Chained->priority_a2_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/priority_a/1/end/2'),
+ 'priority - slurpy args vs. parent/child' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # This belongs to the former test but tests if two chained actions have
+ # priority over an action with the exact arguments.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->priority_b2
+ TestApp::Controller::Action::Chained->priority_b2_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/priority_b/1/end/2'),
+ 'priority - fixed args vs. parent/child' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # This belongs to the former test but tests if two chained actions have
+ # priority over an action with one child action not having the Args() attr set.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->priority_c1
+ TestApp::Controller::Action::Chained->priority_c2_xyz
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/priority_c/1/xyz/'),
+ 'priority - no Args() order mismatch' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; ', 'Content OK' );
+ }
+
+ #
+ # Test dispatching between two controllers that are on the same level and
+ # therefor have no parent/child relationship.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Bar->cross1
+ TestApp::Controller::Action::Chained::Foo->cross2
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/cross/1/end/2'),
+ 'cross controller w/o par/child relation' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # This is for testing if the arguments got passed to the actions
+ # correctly.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::PassedArgs->first
+ TestApp::Controller::Action::Chained::PassedArgs->second
+ TestApp::Controller::Action::Chained::PassedArgs->third
+ TestApp::Controller::Action::Chained::PassedArgs->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/passedargs/a/1/b/2/c/3'),
+ 'Correct arguments passed to actions' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2; 3', 'Content OK' );
+ }
+
+ #
+ # The :Args attribute is optional, we check the action not specifying
+ # it with these tests.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->opt_args
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/opt_args/1/2/3'),
+ 'Optional :Args attribute working' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 1, 2, 3', 'Content OK' );
+ }
+
+ #
+ # Tests for optional PathPart attribute.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->opt_pp_start
+ TestApp::Controller::Action::Chained->opt_pathpart
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/optpp/1/opt_pathpart/2'),
+ 'Optional :PathName attribute working' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Tests for optional PathPart *and* Args attributes.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->opt_all_start
+ TestApp::Controller::Action::Chained->oa
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/optall/1/oa/2/3'),
+ 'Optional :PathName *and* :Args attributes working' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2, 3', 'Content OK' );
+ }
+
+ #
+ # Test if :Chained is the same as :Chained('/')
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->rootdef
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/rootdef/23'),
+ ":Chained is the same as :Chained('/')" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 23', 'Content OK' );
+ }
+
+ #
+ # Test if :Chained('.') is working
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->parentchain
+ TestApp::Controller::Action::Chained::ParentChain->child
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/parentchain/1/child/2'),
+ ":Chained('.') chains to parent controller action" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test behaviour of auto actions returning '1' for the chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Foo->auto
+ TestApp::Controller::Action::Chained::Auto->foo
+ TestApp::Controller::Action::Chained::Auto::Foo->fooend
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/autochain1/1/fooend/2'),
+ "Behaviour when auto returns 1 correct" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test behaviour of auto actions returning '0' for the chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Bar->auto
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/autochain2/1/barend/2'),
+ "Behaviour when auto returns 0 correct" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test what auto actions are run when namespaces are changed
+ # horizontally.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Foo->auto
+ TestApp::Controller::Action::Chained::Auto::Bar->crossloose
+ TestApp::Controller::Action::Chained::Auto::Foo->crossend
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/auto_cross/1/crossend/2'),
+ "Correct auto actions are run on cross controller dispatch" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test forwarding from auto action in chain dispatch.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Forward->auto
+ TestApp::Controller::Action::Chained::Auto->fw3
+ TestApp::Controller::Action::Chained::Auto->fw1
+ TestApp::Controller::Action::Chained::Auto::Forward->forwardend
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/auto_forward/1/forwardend/2'),
+ "Forwarding out of auto in chain" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Detaching out of the auto action of a chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Detach->auto
+ TestApp::Controller::Action::Chained::Auto->fw3
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/auto_detach/1/detachend/2'),
+ "Detaching out of auto in chain" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test forwarding from auto action in chain dispatch.
+ #
+ {
+ my $expected = undef;
+
+ ok( my $response = request('http://localhost/chained/loose/23'),
+ "Loose end is not callable" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->code, 500, 'Status OK' );
+ }
+
+ #
+ # Test forwarding out of a chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->chain_fw_a
+ TestApp::Controller::Action::Chained->fw_dt_target
+ TestApp::Controller::Action::Chained->chain_fw_b
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/chain_fw/1/end/2'),
+ "Forwarding out a chain" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test detaching out of a chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->chain_dt_a
+ TestApp::Controller::Action::Chained->fw_dt_target
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/chain_dt/1/end/2'),
+ "Forwarding out a chain" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Tests that an uri_for to a chained root index action
+ # returns the right value.
+ #
+ {
+ ok( my $response = request(
+ 'http://localhost/action/chained/to_root' ),
+ 'uri_for with chained root action as arg' );
+ like( $response->content,
+ qr(URI:https?://[^/]+/),
+ 'Correct URI generated' );
+ }
+
+ #
+ # Test interception of recursive chains. This test was added because at
+ # one point during the :Chained development, Catalyst used to hang on
+ # recursive chains.
+ #
+ {
+ eval { require 'TestAppChainedRecursive.pm' };
+ if ($run_number == 1) {
+ ok( ! $@, "Interception of recursive chains" );
+ }
+ else { pass( "Interception of recursive chains already tested" ) }
+ }
+
+ #
+ # Test failure of absolute path part arguments.
+ #
+ {
+ eval { require 'TestAppChainedAbsolutePathPart.pm' };
+ if ($run_number == 1) {
+ like( $@, qr(foo/foo),
+ "Usage of absolute path part argument emits error" );
+ }
+ else { pass( "Error on absolute path part arguments already tested" ) }
+ }
+
+ #
+ # Test chained actions in the root controller
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained::Root->rootsub
+ TestApp::Controller::Action::Chained::Root->endpointsub
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/rootsub/1/endpointsub/2'), 'chained in root namespace' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '', 'Content OK' );
+ }
+
+ #
+ # Complex path with multiple empty pathparts
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->mult_nopp_base
+ TestApp::Controller::Action::Chained->mult_nopp_all
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/mult_nopp'),
+ "Complex path with multiple empty pathparts" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; ', 'Content OK' );
+ }
+
+ #
+ # Higher Args() hiding more specific CaptureArgs chains sections
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->cc_base
+ TestApp::Controller::Action::Chained->cc_link
+ TestApp::Controller::Action::Chained->cc_anchor
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join ', ', @expected;
+
+ ok( my $response = request('http://localhost/chained/choose_capture/anchor.html'),
+ 'Choose between an early Args() and a later more ideal chain' );
+ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
+ is( $response->content => '; ', 'Content OK' );
+ }
+
+ #
+ # Less specific chain not being seen correctly due to earlier looser capture
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->cc_base
+ TestApp::Controller::Action::Chained->cc_b
+ TestApp::Controller::Action::Chained->cc_b_link
+ TestApp::Controller::Action::Chained->cc_b_anchor
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join ', ', @expected;
+
+ ok( my $response = request('http://localhost/chained/choose_capture/b/a/anchor.html'),
+ 'Choose between a more specific chain and an earlier looser one' );
+ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
+ is( $response->content => 'a; ', 'Content OK' );
+ }
+
+ #
+ # Check we get the looser one when it's the correct match
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->cc_base
+ TestApp::Controller::Action::Chained->cc_a
+ TestApp::Controller::Action::Chained->cc_a_link
+ TestApp::Controller::Action::Chained->cc_a_anchor
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join ', ', @expected;
+
+ ok( my $response = request('http://localhost/chained/choose_capture/a/a/anchor.html'),
+ 'Choose between a more specific chain and an earlier looser one' );
+ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
+ is( $response->content => 'a; anchor.html', 'Content OK' );
+ }
+
+ #
+ # Args(0) should win over Args() if we actually have no arguments.
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::ArgsOrder->base
+ TestApp::Controller::Action::Chained::ArgsOrder->index
+ TestApp::Controller::Action::Chained::ArgsOrder->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # With no args, we should run "index"
+ ok( my $response = request('http://localhost/argsorder/'),
+ 'Correct arg order ran' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'base; ; index; ', 'Content OK' );
+
+ # With args given, run "all"
+ ok( $response = request('http://localhost/argsorder/X'),
+ 'Correct arg order ran' );
+ is( $response->header('X-Catalyst-Executed'),
+ join(", ",
+ qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::ArgsOrder->base
+ TestApp::Controller::Action::Chained::ArgsOrder->all
+ TestApp::Controller::Action::Chained::ArgsOrder->end
+ ])
+ );
+ is( $response->content, 'base; ; all; X', 'Content OK' );
+
+ }
+
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_default.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_default.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_default.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,96 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 16 * $iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Default->begin
+ TestApp::Controller::Action::Default->default
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/default'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Default',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ ok( $response = request('http://localhost/foo/bar/action'), 'Request' );
+ is( $response->code, 500, 'Invalid URI returned 500' );
+ }
+
+ # test that args are passed properly to default
+ {
+ my $creq;
+ my $expected = [qw/action default arg1 arg2/];
+
+ ok( my $response = request('http://localhost/action/default/arg1/arg2'),
+ 'Request' );
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ is_deeply( $creq->{arguments}, $expected, 'Arguments ok' );
+ }
+
+
+ # Test that /foo and /foo/ both do the same thing
+ {
+ my @expected = qw[
+ TestApp::Controller::Action->begin
+ TestApp::Controller::Action->default
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action'), 'Request' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected,
+ 'Executed actions for /action'
+ );
+
+ ok( $response = request('http://localhost/action/'), 'Request' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected,
+ 'Executed actions for /action/'
+ );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_detach.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_detach.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_detach.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,100 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 18*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Detach->begin
+ TestApp::Controller::Action::Detach->one
+ TestApp::Controller::Action::Detach->two
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test detach to chain of actions.
+ ok( my $response = request('http://localhost/action/detach/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/detach/one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Detach',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ }
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Detach->begin
+ TestApp::Controller::Action::Detach->path
+ TestApp::Controller::Action::Detach->two
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test detach to chain of actions.
+ ok( my $response = request('http://localhost/action/detach/path'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/detach/path', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Detach',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/detach/with_args/old'),
+ 'Request with args'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'new' );
+ }
+
+ {
+ ok(
+ my $response = request(
+ 'http://localhost/action/detach/with_method_and_args/old'),
+ 'Request with args and method'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'new' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_end.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_end.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_end.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,54 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 7*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::End->begin
+ TestApp::Controller::Action::End->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::End->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/end'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::End',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_forward.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_forward.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_forward.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,249 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 50 * $iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Forward->begin
+ TestApp::Controller::Action::Forward->one
+ TestApp::Controller::Action::Forward->two
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test forward to global private action
+ ok( my $response = request('http://localhost/action/forward/global'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/forward/global', 'Main Class Action' );
+
+ # Test forward to chain of actions.
+ ok( $response = request('http://localhost/action/forward/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/forward/one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Forward',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Forward->begin
+ TestApp::Controller::Action::Forward->jojo
+ TestApp::Controller::Action::Forward->one
+ TestApp::Controller::Action::Forward->two
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/forward/jojo'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/forward/jojo', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Forward',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/forward/with_args/old'),
+ 'Request with args'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'old' );
+ }
+
+ {
+ ok(
+ my $response = request(
+ 'http://localhost/action/forward/with_method_and_args/old'),
+ 'Request with args and method'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'old' );
+ }
+
+ # test forward with embedded args
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/forward/args_embed_relative'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'ok' );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/forward/args_embed_absolute'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'ok' );
+ }
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::TestRelative->begin
+ TestApp::Controller::Action::TestRelative->relative
+ TestApp::Controller::Action::Forward->one
+ TestApp::Controller::Action::Forward->two
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test forward to chain of actions.
+ ok( my $response = request('http://localhost/action/relative/relative'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/relative/relative', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::TestRelative',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::TestRelative->begin
+ TestApp::Controller::Action::TestRelative->relative_two
+ TestApp::Controller::Action::Forward->one
+ TestApp::Controller::Action::Forward->two
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test forward to chain of actions.
+ ok(
+ my $response =
+ request('http://localhost/action/relative/relative_two'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Catalyst-Action'),
+ 'action/relative/relative_two',
+ 'Test Action'
+ );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::TestRelative',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ # test class forwards
+ {
+ ok(
+ my $response = request(
+ 'http://localhost/action/forward/class_forward_test_action'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header('X-Class-Forward-Test-Method'), 1,
+ 'Test Method' );
+ }
+
+ # test uri_for re r7385
+ {
+ ok( my $response = request(
+ 'http://localhost/action/forward/forward_to_uri_check'),
+ 'forward_to_uri_check request');
+
+ ok( $response->is_success, 'forward_to_uri_check successful');
+ is( $response->content, '/action/forward/foo/bar',
+ 'forward_to_uri_check correct namespace');
+ }
+
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_global.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_global.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_global.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,83 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 18*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action_global_one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_global_one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Global',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action_global_two'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_global_two', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Global',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action_global_three'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_global_three', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Global',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_index.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_index.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_index.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,100 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 20*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ # test root index
+ {
+ my @expected = qw[
+ TestApp->index
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+ ok( my $response = request('http://localhost/'), 'root index' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'root index', 'root index ok' );
+
+ ok( $response = request('http://localhost'), 'root index no slash' );
+ is( $response->content, 'root index', 'root index no slash ok' );
+ }
+
+ # test first-level controller index
+ {
+ my @expected = qw[
+ TestApp::Controller::Index->index
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/index/'), 'first-level controller index' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'Index index', 'first-level controller index ok' );
+
+ ok( $response = request('http://localhost/index'), 'first-level controller index no slash' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'Index index', 'first-level controller index no slash ok' );
+ }
+
+ # test second-level controller index
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Index->begin
+ TestApp::Controller::Action::Index->index
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/index/'), 'second-level controller index' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'Action-Index index', 'second-level controller index ok' );
+
+ ok( $response = request('http://localhost/action/index'), 'second-level controller index no slash' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'Action-Index index', 'second-level controller index no slash ok' );
+ }
+
+ # test controller default when index is present
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Index->begin
+ TestApp::Controller::Action::Index->default
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/index/foo'), 'default with index' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, "Error - TestApp::Controller::Action\n", 'default with index ok' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_inheritance.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_inheritance.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_inheritance.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,119 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 21*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Inheritance->begin
+ TestApp::Controller::Action::Inheritance->auto
+ TestApp::Controller::Action::Inheritance->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::Inheritance->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/inheritance'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Inheritance',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Inheritance::A->begin
+ TestApp::Controller::Action::Inheritance->auto
+ TestApp::Controller::Action::Inheritance::A->auto
+ TestApp::Controller::Action::Inheritance::A->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::Inheritance::A->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/inheritance/a'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Inheritance::A',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Inheritance::A::B->begin
+ TestApp::Controller::Action::Inheritance->auto
+ TestApp::Controller::Action::Inheritance::A->auto
+ TestApp::Controller::Action::Inheritance::A::B->auto
+ TestApp::Controller::Action::Inheritance::A::B->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::Inheritance::A::B->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/inheritance/a/b'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Inheritance::A::B',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_local.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_local.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_local.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,138 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 32*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action/local/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/local/two/1/2'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/two', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/local/two'),
+ 'Request' );
+ ok( !$response->is_success, 'Request with wrong number of args failed' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/local/three'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/three', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/local/four/five/six'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/four/five/six', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "tests for %2F on remote server", 6;
+ }
+
+ ok(
+ my $response =
+ request('http://localhost/action/local/one/foo%2Fbar'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr~arguments => \[\s*'foo/bar'\s*\]~,
+ "Parameters don't split on %2F"
+ );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_multipath.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_multipath.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_multipath.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,71 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+my $content = q/foo
+bar
+baz
+/;
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 16*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ # Local
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/multipath/multipath'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $content, 'Content is a stream' );
+ }
+
+ # Global
+ {
+ ok( my $response = request('http://localhost/multipath'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $content, 'Content is a stream' );
+ }
+
+ # Path('/multipath1')
+ {
+ ok( my $response = request('http://localhost/multipath1'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $content, 'Content is a stream' );
+ }
+
+ # Path('multipath2')
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/multipath/multipath2'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $content, 'Content is a stream' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_path.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_path.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_path.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,145 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 36*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/path/a%20path%20with%20spaces'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Catalyst-Action'),
+ 'action/path/a%20path%20with%20spaces',
+ 'Test Action'
+ );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/path/åäö'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/path/%C3%A5%C3%A4%C3%B6', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/path/'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/path', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/path/spaces_near_parens_singleq'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/path/spaces_near_parens_singleq', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/path/spaces_near_parens_doubleq'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/path/spaces_near_parens_doubleq', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/0'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '0', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Root',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_private.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_private.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_private.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,89 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 24*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action/private/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Private',
+ 'Test Class'
+ );
+ is( $response->content, 'access denied', 'Access' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/private/two'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Private',
+ 'Test Class'
+ );
+ is( $response->content, 'access denied', 'Access' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/three'), 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->content_type, 'text/html', 'Response Content-Type' );
+ like(
+ $response->header('X-Catalyst-Error'),
+ qr/^Unknown resource "three"/,
+ 'Catalyst Error'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/private/four'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Private',
+ 'Test Class'
+ );
+ is( $response->content, 'access denied', 'Access' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/private/five'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Private',
+ 'Test Class'
+ );
+ is( $response->content, 'access denied', 'Access' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_regexp.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_regexp.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_regexp.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,106 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 28*$iters;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action/regexp/10/hello'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '^action/regexp/(\d+)/(\w+)$', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Regexp',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/regexp/hello/10'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '^action/regexp/(\w+)/(\d+)$', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Regexp',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/regexp/mandatory'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '^action/regexp/(mandatory)(/optional)?$', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Regexp',
+ 'Test Class'
+ );
+ my $content = $response->content;
+ my $req = eval $content;
+
+ is( scalar @{ $req->captures }, 2, 'number of captures' );
+ is( $req->captures->[ 0 ], 'mandatory', 'mandatory capture' );
+ ok( !defined $req->captures->[ 1 ], 'optional capture' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/regexp/mandatory/optional'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '^action/regexp/(mandatory)(/optional)?$', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Regexp',
+ 'Test Class'
+ );
+ my $content = $response->content;
+ my $req = eval $content;
+
+ is( scalar @{ $req->captures }, 2, 'number of captures' );
+ is( $req->captures->[ 0 ], 'mandatory', 'mandatory capture' );
+ is( $req->captures->[ 1 ], '/optional', 'optional capture' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_streaming.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_streaming.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_action_streaming.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,72 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 10*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ # test direct streaming
+ {
+ ok( my $response = request('http://localhost/streaming'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 1;
+ }
+
+ # XXX: Length should be undef here, but HTTP::Request::AsCGI sets it
+ is( $response->content_length, 12, 'Response Content-Length' );
+ }
+
+ is( $response->content,, <<'EOF', 'Content is a stream' );
+foo
+bar
+baz
+EOF
+ }
+
+ # test streaming by passing a handle to $c->res->body
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 5;
+ }
+
+ my $file = "$FindBin::Bin/01use.t";
+ my $fh = IO::File->new( $file, 'r' );
+ my $buffer;
+ if ( defined $fh ) {
+ $fh->read( $buffer, 1024 );
+ $fh->close;
+ }
+
+ ok( my $response = request('http://localhost/action/streaming/body'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content_length, -s $file, 'Response Content-Length' );
+ is( $response->content, $buffer, 'Content is read from filehandle' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_args.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_args.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_component_controller_args.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,98 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use URI::Escape;
+
+our @paths;
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1;
+
+ # add special paths to test here
+ @paths = (
+ # all reserved in uri's
+ qw~ : / ? [ ] @ ! $ & ' ( ) * + ; = ~, ',' , '#',
+
+ # unreserved
+ 'a'..'z','A'..'Z',0..9,qw( - . _ ~ ),
+ " ",
+
+ # just to test %2F/%
+ [ qw~ / / ~ ],
+
+ # testing %25/%25
+ [ qw~ % % ~ ],
+ );
+}
+
+use Test::More tests => 6*@paths * $iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+
+ # new dispatcher:
+ # 11 wallclock secs (10.14 usr + 0.20 sys = 10.34 CPU) @ 15.18/s (n=157)
+ # old dispatcher (r1486):
+ # 11 wallclock secs (10.34 usr + 0.20 sys = 10.54 CPU) @ 13.76/s (n=145)
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ run_test_for($_) for @paths;
+}
+
+sub run_test_for {
+ my $test = shift;
+
+ my $path;
+ if (ref $test) {
+ $path = join "/", map uri_escape($_), @$test;
+ $test = join '', @$test;
+ } else {
+ $path = uri_escape($test);
+ }
+
+ SKIP:
+ {
+ # Skip %2F, ., [, (, and ) tests on real webservers
+ # Both Apache and lighttpd don't seem to like these
+ if ( $ENV{CATALYST_SERVER} && $path =~ /(?:%2F|\.|%5B|\(|\))/ ) {
+ skip "Skipping $path tests on remote server", 6;
+ }
+
+ my $response;
+
+ ok( $response = request("http://localhost/args/args/$path"), "Requested args for path $path");
+
+ is( $response->content, $test, "$test as args" );
+
+ undef $response;
+
+ ok( $response = request("http://localhost/args/params/$path"), "Requested params for path $path");
+
+ is( $response->content, $test, "$test as params" );
+
+ undef $response;
+
+ if( $test =~ m{/} ) {
+ $test =~ s{/}{}g;
+ $path = uri_escape( $test );
+ }
+
+ ok( $response = request("http://localhost/chained/multi_cap/$path/baz"), "Requested capture for path $path");
+
+ is( $response->content, join( ', ', split( //, $test ) ) ."; ", "$test as capture" );
+ }
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_auth.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_auth.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_auth.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,43 @@
+#!perl
+
+# This tests to make sure the Authorization header is passed through by the engine.
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 7;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $request = GET(
+ 'http://localhost/dump/request',
+ 'Authorization' => 'Basic dGVzdDoxMjM0NQ==',
+ );
+
+ 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/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+
+ is( $creq->header('Authorization'), 'Basic dGVzdDoxMjM0NQ==', 'auth header ok' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_body.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_body.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_body.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,77 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 18;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'text/plain',
+ 'Content' => 'Hello Catalyst'
+ );
+
+ 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/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+}
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'text/plain',
+ 'Content' => 'x' x 100_000
+ );
+
+ 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\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_body_demand.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_body_demand.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_body_demand.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,66 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 8;
+use Catalyst::Test 'TestAppOnDemand';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+# Test a simple POST request to make sure body parsing
+# works in on-demand mode.
+SKIP:
+{
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 8;
+ }
+
+ {
+ my $params;
+
+ my $request = POST(
+ 'http://localhost/body/params',
+ 'Content-Type' => 'application/x-www-form-urlencoded',
+ 'Content' => 'foo=bar&baz=quux'
+ );
+
+ my $expected = { foo => 'bar', baz => 'quux' };
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$params = ' . $response->content,
+ 'Unserialize params'
+ );
+ }
+
+ is_deeply( $params, $expected, 'Catalyst::Request body parameters' );
+ }
+
+ # Test reading chunks of the request body using $c->read
+ {
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/body/read',
+ 'Content-Type' => 'text/plain',
+ 'Content' => 'x' x 105_000
+ );
+
+ my $expected = '10000|10000|10000|10000|10000|10000|10000|10000|10000|10000|5000';
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $expected, 'Response Content' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_cookies.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_cookies.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_cookies.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,45 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 13;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use CGI::Simple::Cookie;
+use HTTP::Headers;
+use HTTP::Request::Common;
+use URI;
+
+{
+ my $creq;
+
+ my $request = GET( 'http://localhost/dump/request',
+ 'Cookie' => 'Catalyst=Cool; Cool=Catalyst', );
+
+ 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/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ isa_ok( $creq, 'Catalyst::Request' );
+ isa_ok( $creq->cookies->{Catalyst}, 'CGI::Simple::Cookie',
+ 'Cookie Catalyst' );
+ is( $creq->cookies->{Catalyst}->name, 'Catalyst', 'Cookie Catalyst name' );
+ is( $creq->cookies->{Catalyst}->value, 'Cool', 'Cookie Catalyst value' );
+ isa_ok( $creq->cookies->{Cool}, 'CGI::Simple::Cookie', 'Cookie Cool' );
+ is( $creq->cookies->{Cool}->name, 'Cool', 'Cookie Cool name' );
+ is( $creq->cookies->{Cool}->value, 'Catalyst', 'Cookie Cool value' );
+
+ my $cookies = {
+ Catalyst => $creq->cookies->{Catalyst},
+ Cool => $creq->cookies->{Cool}
+ };
+
+ is_deeply( $creq->cookies, $cookies, 'Cookies' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_headers.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_headers.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_headers.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,71 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 17;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $request = GET( 'http://localhost/dump/request',
+ 'User-Agent' => 'MyAgen/1.0',
+ 'X-Whats-Cool' => 'Catalyst',
+ 'X-Multiple' => [ 1 .. 5 ],
+ 'X-Forwarded-Host' => 'frontend.server.com',
+ 'X-Forwarded-For' => '192.168.1.1, 1.2.3.4',
+ );
+
+ 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\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ isa_ok( $creq, 'Catalyst::Request' );
+ isa_ok( $creq->headers, 'HTTP::Headers', 'Catalyst::Request->headers' );
+ is( $creq->header('X-Whats-Cool'), $request->header('X-Whats-Cool'), 'Catalyst::Request->header X-Whats-Cool' );
+
+ { # Test that multiple headers are joined as per RFC 2616 4.2 and RFC 3875 4.1.18
+
+ my $excpected = '1, 2, 3, 4, 5';
+ my $got = $creq->header('X-Multiple'); # HTTP::Headers is context sensitive, "force" scalar context
+
+ is( $got, $excpected, 'Multiple message-headers are joined as a comma-separated list' );
+ }
+
+ is( $creq->header('User-Agent'), $request->header('User-Agent'), 'Catalyst::Request->header User-Agent' );
+
+ my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
+ is( $creq->header('Host'), $host, 'Catalyst::Request->header Host' );
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} && $ENV{CATALYST_SERVER} !~ /127.0.0.1|localhost/ ) {
+ skip "Using remote server", 2;
+ }
+
+ is( $creq->base->host, 'frontend.server.com', 'Catalyst::Request proxied base' );
+ is( $creq->address, '1.2.3.4', 'Catalyst::Request proxied address' );
+ }
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 4;
+ }
+ # test that we can ignore the proxy support
+ TestApp->config->{ignore_frontend_proxy} = 1;
+ ok( $response = request($request), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->base, 'http://localhost/', 'Catalyst::Request non-proxied base' );
+ is( $creq->address, '127.0.0.1', 'Catalyst::Request non-proxied address' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_parameters.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_parameters.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_parameters.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,139 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 40;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $parameters = { 'a' => [qw(A b C d E f G)], };
+
+ my $query = join( '&', map { 'a=' . $_ } @{ $parameters->{a} } );
+
+ ok( my $response = request("http://localhost/dump/request?$query"),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ 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,
+ 'Catalyst::Request parameters' );
+}
+
+{
+ my $creq;
+ ok( my $response = request("http://localhost/dump/request?q=foo%2bbar"),
+ 'Request' );
+ 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';
+}
+
+{
+ my $creq;
+ ok( my $response = request("http://localhost/dump/request?q=foo=bar"),
+ 'Request' );
+ 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';
+}
+
+{
+ my $creq;
+
+ my $parameters = {
+ 'a' => [qw(A b C d E f G)],
+ '%' => [ '%', '"', '& - &' ],
+ 'blank' => '',
+ };
+
+ my $request = POST(
+ 'http://localhost/dump/request/a/b?a=1&a=2&a=3',
+ 'Content' => $parameters,
+ 'Content-Type' => 'application/x-www-form-urlencoded'
+ );
+
+ unshift( @{ $parameters->{a} }, 1, 2, 3 );
+
+ 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\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ 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,
+ 'Catalyst::Request parameters' );
+ is_deeply( $creq->arguments, [qw(a b)], 'Catalyst::Request arguments' );
+ is_deeply( $creq->{uploads}, {}, 'Catalyst::Request uploads' );
+ is_deeply( $creq->cookies, {}, 'Catalyst::Request cookie' );
+}
+
+# http://dev.catalyst.perl.org/ticket/37
+# multipart/form-data parameters that contain 'http://'
+# was an HTTP::Message bug, but HTTP::Body handles it properly now
+{
+ my $creq;
+
+ my $parameters = {
+ 'url' => 'http://www.google.com',
+ 'blank' => '',
+ };
+
+ my $request = POST( 'http://localhost/dump/request',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' => $parameters,
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
+}
+
+# raw query string support
+{
+ my $creq;
+
+ my $parameters = {
+ a => 1,
+ blank => '',
+ };
+
+ my $request = POST(
+ 'http://localhost/dump/request/a/b?query+string',
+ 'Content' => $parameters,
+ 'Content-Type' => 'application/x-www-form-urlencoded'
+ );
+
+ 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->query_keywords, 'query string', 'Catalyst::Request query_keywords' );
+ 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' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_uploads.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_uploads.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_uploads.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,244 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 75;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use Catalyst::Request::Upload;
+use HTTP::Headers;
+use HTTP::Headers::Util 'split_header_words';
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'form-data',
+ 'Content' => [
+ 'live_engine_request_cookies.t' =>
+ ["$FindBin::Bin/live_engine_request_cookies.t"],
+ 'live_engine_request_headers.t' =>
+ ["$FindBin::Bin/live_engine_request_headers.t"],
+ 'live_engine_request_uploads.t' =>
+ ["$FindBin::Bin/live_engine_request_uploads.t"],
+ ]
+ );
+
+ 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\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'multipart/form-data',
+ 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+
+ for my $part ( $request->parts ) {
+
+ my $disposition = $part->header('Content-Disposition');
+ my %parameters = @{ ( split_header_words($disposition) )[0] };
+
+ my $upload = $creq->{uploads}->{ $parameters{filename} };
+
+ isa_ok( $upload, 'Catalyst::Request::Upload' );
+
+ is( $upload->type, $part->content_type, 'Upload Content-Type' );
+ is( $upload->size, length( $part->content ), 'Upload Content-Length' );
+
+ # make sure upload is accessible via legacy params->{$file}
+ is( $creq->{parameters}->{ $upload->filename },
+ $upload->filename, 'legacy param method ok' );
+
+ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
+ }
+}
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' => [
+ 'testfile' => ["$FindBin::Bin/live_engine_request_cookies.t"],
+ 'testfile' => ["$FindBin::Bin/live_engine_request_headers.t"],
+ 'testfile' => ["$FindBin::Bin/live_engine_request_uploads.t"],
+ ]
+ );
+
+ 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\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'multipart/form-data',
+ 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+
+ my @parts = $request->parts;
+
+ for ( my $i = 0 ; $i < @parts ; $i++ ) {
+
+ my $part = $parts[$i];
+ my $disposition = $part->header('Content-Disposition');
+ my %parameters = @{ ( split_header_words($disposition) )[0] };
+
+ 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' );
+
+ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
+ }
+}
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/engine/request/uploads/slurp',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' =>
+ [ 'slurp' => ["$FindBin::Bin/live_engine_request_uploads.t"], ]
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, ( $request->parts )[0]->content, 'Content' );
+}
+
+{
+ my $request = POST(
+ 'http://localhost/dump/request',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' =>
+ [ 'file' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
+ );
+
+ # LWP will auto-correct Content-Length when using a remote server
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 2;
+ }
+
+ # Sending wrong Content-Length here and see if subequent requests fail
+ $request->header('Content-Length' => $request->header('Content-Length') + 1);
+
+ ok( my $response = request($request), 'Request' );
+ ok( !$response->is_success, 'Response Error' );
+ }
+
+ $request = POST(
+ 'http://localhost/dump/request',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' =>
+ [ 'file1' => ["$FindBin::Bin/catalyst_130pix.gif"],
+ 'file2' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
+ );
+
+ 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/file1 => bless/, 'Upload with name file1');
+ like( $response->content, qr/file2 => bless/, 'Upload with name file2');
+}
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'form-data',
+ 'Content' => [
+ 'testfile' => 'textfield value',
+ 'testfile' => ["$FindBin::Bin/catalyst_130pix.gif"],
+ ]
+ );
+
+ 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\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'multipart/form-data',
+ 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+
+ my $param = $creq->{parameters}->{testfile};
+
+ ok( @$param == 2, '2 values' );
+ is( $param->[0], 'textfield value', 'correct value' );
+ like( $param->[1], qr/\Qcatalyst_130pix.gif/, 'filename' );
+
+ for my $part ( $request->parts ) {
+
+ my $disposition = $part->header('Content-Disposition');
+ my %parameters = @{ ( split_header_words($disposition) )[0] };
+
+ next unless exists $parameters{filename};
+
+ 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' );
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_uri.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_uri.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_request_uri.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,122 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 49;
+use Catalyst::Test 'TestApp';
+use Catalyst::Request;
+
+my $creq;
+
+# test that the path can be changed
+{
+ ok( my $response = request('http://localhost/engine/request/uri/change_path'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ like( $creq->uri, qr{/my/app/lives/here$}, 'URI contains new path' );
+}
+
+# test that path properly removes the base location
+{
+ ok( my $response = request('http://localhost/engine/request/uri/change_base'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ like( $creq->base, qr{/new/location}, 'Base URI contains new location' );
+ is( $creq->path, 'engine/request/uri/change_base', 'URI contains correct path' );
+}
+
+# test that base + path is correct
+{
+ ok( my $response = request('http://localhost/engine/request/uri'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->base . $creq->path, $creq->uri, 'Base + Path ok' );
+}
+
+# test base is correct for HTTPS URLs
+SKIP:
+{
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 5;
+ }
+
+ local $ENV{HTTPS} = 'on';
+ ok( my $response = request('https://localhost/engine/request/uri'), 'HTTPS Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->base, 'https://localhost/', 'HTTPS base ok' );
+ is( $creq->uri, 'https://localhost/engine/request/uri', 'HTTPS uri ok' );
+}
+
+# test that we can use semi-colons as separators
+{
+ my $parameters = {
+ a => [ qw/1 2/ ],
+ b => 3,
+ };
+
+ 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' );
+}
+
+# test that query params are unescaped properly
+{
+ 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' );
+}
+
+# test that uri_with adds params
+{
+ ok( my $response = request('http://localhost/engine/request/uri/uri_with'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( !defined $response->header( 'X-Catalyst-Param-a' ), 'param "a" ok' );
+ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
+}
+
+# test that uri_with adds params (and preserves)
+{
+ ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' );
+ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
+}
+
+# test that uri_with replaces params (and preserves)
+{
+ ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1&b=2'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' );
+ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
+}
+
+# test that uri_with replaces params (and preserves)
+{
+ ok( my $response = request('http://localhost/engine/request/uri/uri_with_object'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ like( $response->header( 'X-Catalyst-Param-a' ), qr(https?://localhost[^/]*/), 'param "a" ok' );
+}
+
+# test that uri_with is utf8 safe
+{
+ ok( my $response = request("http://localhost/engine/request/uri/uri_with_utf8"), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ like( $response->header( 'X-Catalyst-uri-with' ), qr/%E2%98%A0$/, 'uri_with ok' );
+}
+
+# test with undef -- no warnings should be thrown
+{
+ ok( my $response = request("http://localhost/engine/request/uri/uri_with_undef"), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header( 'X-Catalyst-warnings' ), 0, 'no warnings emitted' );
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_cookies.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_cookies.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_cookies.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,73 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 15;
+use Catalyst::Test 'TestApp';
+use HTTP::Headers::Util 'split_header_words';
+
+my $expected = {
+ catalyst => [qw|catalyst cool path /bah|],
+ cool => [qw|cool catalyst path /|]
+};
+
+{
+ ok( my $response = request('http://localhost/engine/response/cookies/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/cookies/one', 'Test Action' );
+
+ my $cookies = {};
+
+ for my $string ( $response->header('Set-Cookie') ) {
+ my $cookie = [ split_header_words $string];
+ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
+ }
+
+ is_deeply( $cookies, $expected, 'Response Cookies' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/cookies/two'),
+ 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 302, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/cookies/two', 'Test Action' );
+
+ my $cookies = {};
+
+ for my $string ( $response->header('Set-Cookie') ) {
+ my $cookie = [ split_header_words $string];
+ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
+ }
+
+ is_deeply( $cookies, $expected, 'Response Cookies' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/cookies/three'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/cookies/three', 'Test Action' );
+
+ my $cookies = {};
+
+ for my $string ( $response->header('Set-Cookie') ) {
+ my $cookie = [ split_header_words $string];
+ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
+ }
+
+ is_deeply( $cookies, {
+ hash => [ qw(hash a&b&c path /) ],
+ this_is_the_real_name => [ qw(this_is_the_real_name foo&bar path /) ], # not "object"
+ }, 'Response Cookies' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_errors.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_errors.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_errors.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,60 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 18;
+use Catalyst::Test 'TestApp';
+
+close STDERR; # i'm naughty :)
+
+{
+ ok( my $response = request('http://localhost/engine/response/errors/one'),
+ 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->code, 500, 'Response Code' );
+ is( $response->content_type, 'text/html', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/errors/one', 'Test Action' );
+ like(
+ $response->header('X-Catalyst-Error'),
+ qr/^Caught exception/,
+ 'Catalyst Error'
+ );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/errors/two'),
+ 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->code, 500, 'Response Code' );
+ is( $response->content_type, 'text/html', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/errors/two', 'Test Action' );
+ like(
+ $response->header('X-Catalyst-Error'),
+ qr/^Couldn't forward to/,
+ 'Catalyst Error'
+ );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/errors/three'),
+ 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->code, 500, 'Response Code' );
+ is( $response->content_type, 'text/html', 'Response Content-Type' );
+ is(
+ $response->header('X-Catalyst-Action'),
+ 'engine/response/errors/three',
+ 'Test Action'
+ );
+ like(
+ $response->header('X-Catalyst-Error'),
+ qr/I'm going to die!/,
+ 'Catalyst Error'
+ );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_headers.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_headers.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_headers.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,58 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 18;
+use Catalyst::Test 'TestApp';
+use HTTP::Request::Common;
+
+my $content_length;
+
+foreach my $method qw(HEAD GET) {
+ my $expected = join( ', ', 1 .. 10 );
+
+ my $request = HTTP::Request::Common->can($method)
+ ->( 'http://localhost/engine/response/headers/one' );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->code, 200, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/headers/one', 'Test Action' );
+ is( $response->header('X-Header-Catalyst'),
+ 'Cool', 'Response Header X-Header-Catalyst' );
+ is( $response->header('X-Header-Cool'),
+ 'Catalyst', 'Response Header X-Header-Cool' );
+ is( $response->header('X-Header-Numbers'),
+ $expected, 'Response Header X-Header-Numbers' );
+
+ use bytes;
+ if ( $method eq 'HEAD' ) {
+ $content_length = $response->header('Content-Length');
+ ok( $content_length > 0, 'Response Header Content-Length' );
+ is( length($response->content),
+ 0,
+ 'HEAD method content is empty' );
+ }
+ elsif ( $method eq 'GET' ) {
+ # method name is echo'd back in content-body, which
+ # accounts for difference in content length. In normal
+ # cases the Content-Length should be the same regardless
+ # of if its a GET or HEAD request.
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 2;
+ }
+ is( $response->header('Content-Length'),
+ $content_length - 1, 'Response Header Content-Length' );
+ is( length($response->content),
+ $response->header('Content-Length'),
+ 'GET method content' );
+ }
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_large.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_large.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_large.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,27 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 6;
+use Catalyst::Test 'TestApp';
+
+# phaylon noticed that refactored was truncating output on large images.
+# This test tests 100K and 1M output content.
+
+my $expected = {
+ one => 'x' x (100 * 1024),
+ two => 'y' x (1024 * 1024),
+};
+
+for my $action ( keys %{$expected} ) {
+ ok( my $response = request('http://localhost/engine/response/large/' . $action ),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+
+ is( length( $response->content ), length( $expected->{$action} ), 'Length OK' );
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_redirect.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_redirect.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_redirect.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,48 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 26;
+use Catalyst::Test 'TestApp';
+
+{
+ ok( my $response = request('http://localhost/engine/response/redirect/one'), 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 302, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/one', 'Test Action' );
+ is( $response->header('Location'), '/test/writing/is/boring', 'Response Header Location' );
+ ok( $response->header('Content-Length'), '302 Redirect contains Content-Length' );
+ ok( $response->content, '302 Redirect contains a response body' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/redirect/two'), 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 302, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/two', 'Test Action' );
+ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/redirect/three'), 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 301, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/three', 'Test Action' );
+ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
+ ok( $response->header('Content-Length'), '301 Redirect contains Content-Length' );
+ ok( $response->content, '301 Redirect contains a response body' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/redirect/four'), 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 307, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/four', 'Test Action' );
+ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
+ ok( $response->header('Content-Length'), '307 Redirect contains Content-Length' );
+ ok( $response->content, '307 Redirect contains a response body' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_status.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_status.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_response_status.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,55 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 30;
+use Catalyst::Test 'TestApp';
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s200'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->code, 200, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s200', 'Test Action' );
+ like( $response->content, qr/^200/, 'Response Content' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s400'), 'Request' );
+ ok( $response->is_error, 'Response Client Error 4xx' );
+ is( $response->code, 400, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s400', 'Test Action' );
+ like( $response->content, qr/^400/, 'Response Content' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s403'), 'Request' );
+ ok( $response->is_error, 'Response Client Error 4xx' );
+ is( $response->code, 403, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s403', 'Test Action' );
+ like( $response->content, qr/^403/, 'Response Content' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s404'), 'Request' );
+ ok( $response->is_error, 'Response Client Error 4xx' );
+ is( $response->code, 404, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s404', 'Test Action' );
+ like( $response->content, qr/^404/, 'Response Content' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s500'), 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->code, 500, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s500', 'Test Action' );
+ like( $response->content, qr/^500/, 'Response Content' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_setup_basics.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_setup_basics.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_setup_basics.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,19 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+SKIP:
+{
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 1;
+ }
+ # Allow overriding automatic root.
+ is( TestApp->config->{root}, '/some/dir' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_setup_plugins.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_setup_plugins.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_engine_setup_plugins.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 2;
+use Catalyst::Test 'TestApp';
+
+{
+ # Allow overriding automatic root.
+ ok( my $response = request('http://localhost/engine/response/headers/one'), 'Request' );
+ is( $response->header('X-Catalyst-Plugin-Setup'), '1' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_fork.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_fork.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_fork.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,60 @@
+#!/usr/bin/perl
+# live_fork.t
+# Copyright (c) 2006 Jonathan Rockway <jrockway at cpan.org>
+
+=head1 SYNOPSIS
+
+Tests if Catalyst can fork/exec other processes successfully
+
+=cut
+use strict;
+use warnings;
+use Test::More;
+use YAML;
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use Catalyst::Test qw(TestApp);
+
+plan skip_all => 'Using remote server'
+ if $ENV{CATALYST_SERVER};
+
+plan skip_all => 'Skipping fork tests: no /bin/ls'
+ if !-e '/bin/ls'; # see if /bin/ls exists
+
+plan tests => 13; # otherwise
+
+{
+ system:
+ ok(my $result = get('/fork/system/%2Fbin%2Fls'), 'system');
+ my @result = split /$/m, $result;
+ $result = join q{}, @result[-4..-1];
+
+ my $result_ref = eval { Load($result) };
+ ok($result_ref, 'is YAML');
+ is($result_ref->{result}, 0, 'exited OK');
+}
+
+{
+ backticks:
+ ok(my $result = get('/fork/backticks/%2Fbin%2Fls'), '`backticks`');
+ my @result = split /$/m, $result;
+ $result = join q{}, @result[-4..-1];
+
+ my $result_ref = eval { Load($result) };
+ ok($result_ref, 'is YAML');
+ is($result_ref->{code}, 0, 'exited successfully');
+ like($result_ref->{result}, qr{^/bin/ls[^:]}, 'contains ^/bin/ls$');
+ like($result_ref->{result}, qr{\n.*\n}m, 'contains two newlines');
+}
+{
+ fork:
+ ok(my $result = get('/fork/fork'), 'fork');
+ my @result = split /$/m, $result;
+ $result = join q{}, @result[-4..-1];
+
+ my $result_ref = eval { Load($result) };
+ ok($result_ref, 'is YAML');
+ isnt($result_ref->{pid}, 0, q{fork's "pid" wasn't 0});
+ isnt($result_ref->{pid}, $$, 'fork got a new pid');
+ is($result_ref->{result}, 'ok', 'fork was effective');
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_loop.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_loop.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_loop.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,23 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 3;
+use Catalyst::Test 'TestApp';
+
+SKIP:
+{
+ # Net::HTTP::Methods crashes when talking to a remote server because this
+ # test causes a very long header line to be sent
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 3;
+ }
+
+ ok( my $response = request('http://localhost/loop_test'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( $response->header('X-Class-Forward-Test-Method'), 'Loop OK' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_plugin_loaded.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_plugin_loaded.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_plugin_loaded.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,27 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 5;
+use Catalyst::Test 'TestApp';
+
+my @expected = qw[
+ Catalyst::Plugin::Test::Errors
+ Catalyst::Plugin::Test::Headers
+ Catalyst::Plugin::Test::Inline
+ Catalyst::Plugin::Test::Plugin
+ TestApp::Plugin::FullyQualified
+];
+
+my $expected = join( ", ", @expected );
+
+ok( my $response = request('http://localhost/dump/request'), 'Request' );
+ok( $response->is_success, 'Response Successful 2xx' );
+is( $response->content_type, 'text/plain', 'Response Content-Type' );
+like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+is( $response->header('X-Catalyst-Plugins'), $expected, 'Loaded plugins' );
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_priorities.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_priorities.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_priorities.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,81 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 28;
+use Catalyst::Test 'TestApp';
+use Data::Dumper;
+
+local $^W = 0;
+
+my $uri_base = 'http://localhost/priorities';
+my @tests = (
+
+ # Simple
+ 'Regex vs. Local', { path => '/re_vs_loc', expect => 'local' },
+ 'Regex vs. LocalRegex', { path => '/re_vs_locre', expect => 'regex' },
+ 'Regex vs. Path', { path => '/re_vs_path', expect => 'path' },
+ 'Local vs. LocalRegex', { path => '/loc_vs_locre', expect => 'local' },
+ 'Local vs. Path 1', { path => '/loc_vs_path1', expect => 'local' },
+ 'Local vs. Path 2', { path => '/loc_vs_path2', expect => 'path' },
+ 'Path vs. LocalRegex', { path => '/path_vs_locre', expect => 'path' },
+
+ # index
+ 'index vs. Regex', { path => '/re_vs_index', expect => 'index' },
+ 'index vs. Local', { path => '/loc_vs_index', expect => 'index' },
+ 'index vs. LocalRegex', { path => '/locre_vs_index', expect => 'index' },
+ 'index vs. Path', { path => '/path_vs_index', expect => 'index' },
+
+ 'multimethod zero', { path => '/multimethod', expect => 'zero' },
+ 'multimethod one', { path => '/multimethod/1', expect => 'one 1' },
+ 'multimethod two', { path => '/multimethod/1/2',
+ expect => 'two 1 2' },
+);
+
+while ( @tests ) {
+
+ my $name = shift @tests;
+ my $data = shift @tests;
+
+ # Run tests for path with trailing slash and without
+ SKIP: for my $req_uri
+ (
+ join( '' => $uri_base, $data->{ path } ), # Without trailing path
+ join( '' => $uri_base, $data->{ path }, '/' ), # With trailing path
+ ) {
+ my $end_slash = ( $req_uri =~ qr(/$) ? 1 : 0 );
+
+ # use slash_expect argument if URI ends with slash
+ # and the slash_expect argument is defined
+ my $expect = $data->{ expect } || '';
+ if ( $end_slash and exists $data->{ slash_expect } ) {
+ $expect = $data->{ slash_expect };
+ }
+
+ # Call the URI on the TestApp
+ my $response = request( $req_uri );
+
+ # Leave expect out to see the result
+ unless ( $expect ) {
+ skip 'Nothing expected, winner is ' . $response->content, 1;
+ }
+
+ # Show error if response was no success
+ if ( not $response->is_success ) {
+ diag 'Error: ' . $response->headers->{ 'x-catalyst-error' };
+ }
+
+ # Test if content matches expectations.
+ # TODO This might flood the screen with the catalyst please-come-later
+ # page. So I don't know it is a good idea.
+ is( $response->content, $expect,
+ "$name: @{[ $data->{ expect } ]} wins"
+ . ( $end_slash ? ' (trailing slash)' : '' )
+ );
+ }
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_recursion.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_recursion.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_recursion.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,25 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 3;
+use Catalyst::Test 'TestApp';
+
+local $^W = 0;
+
+SKIP:
+{
+ # Net::HTTP::Methods crashes when talking to a remote server because this
+ # test causes a very long header line to be sent
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 3;
+ }
+
+ ok( my $response = request('http://localhost/recursion_test'), 'Request' );
+ ok( !$response->is_success, 'Response Not Successful' );
+ is( $response->header('X-Catalyst-Error'), 'Deep recursion detected calling "/recursion_test"', 'Deep Recursion Detected' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/live_stats.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/live_stats.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/live_stats.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,29 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More;
+use Catalyst::Test 'TestAppStats';
+
+if ( $ENV{CATALYST_SERVER} ) {
+ plan skip_all => 'Using remote server';
+}
+else {
+ plan tests => 5;
+}
+
+{
+ ok( my $response = request('http://localhost/'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+}
+{
+ ok( my $response = request('http://localhost/'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( $response->content =~ m/\/default.*?[\d.]+s.*- test.*[\d.]+s/s, 'Stats report');
+
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi-rewrite.pl
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi-rewrite.pl (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi-rewrite.pl 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,65 @@
+#!perl
+
+# Run all tests against CGI mode under Apache
+#
+# Note, to get this to run properly, you may need to give it the path to your
+# httpd.conf:
+#
+# perl t/optional_apache-cgi.pl -httpd_conf /etc/apache/httpd.conf
+
+use strict;
+use warnings;
+
+use Apache::Test;
+use Apache::TestRun ();
+
+use File::Path;
+use File::Copy::Recursive;
+use FindBin;
+use IO::Socket;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# create a TestApp and copy the test libs into it
+mkdir "$FindBin::Bin/../t/tmp";
+chdir "$FindBin::Bin/../t/tmp";
+system "$FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests so Apache::Test doesn't try to run them
+rmtree 't/tmp/TestApp/t';
+
+$ENV{CATALYST_SERVER} = 'http://localhost:8529/rewrite';
+
+if ( !-e 't/optional_apache-cgi-rewrite.pl' ) {
+ die "ERROR: Please run test from the Catalyst-Runtime directory\n";
+}
+
+push @ARGV, glob( 't/live_*' );
+
+Apache::TestRun->new->run(@ARGV);
+
+# clean up if the server has shut down
+# this allows the test files to stay around if the user ran -start-httpd
+if ( !check_port( 'localhost', 8529 ) ) {
+ rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+}
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
Property changes on: Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi-rewrite.pl
___________________________________________________________________
Name: svn:executable
+ *
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi.pl
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi.pl (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi.pl 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,65 @@
+#!perl
+
+# Run all tests against CGI mode under Apache
+#
+# Note, to get this to run properly, you may need to give it the path to your
+# httpd.conf:
+#
+# perl t/optional_apache-cgi.pl -httpd_conf /etc/apache/httpd.conf
+
+use strict;
+use warnings;
+
+use Apache::Test;
+use Apache::TestRun ();
+
+use File::Path;
+use File::Copy::Recursive;
+use FindBin;
+use IO::Socket;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# create a TestApp and copy the test libs into it
+mkdir "$FindBin::Bin/../t/tmp";
+chdir "$FindBin::Bin/../t/tmp";
+system "$FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests so Apache::Test doesn't try to run them
+rmtree 't/tmp/TestApp/t';
+
+$ENV{CATALYST_SERVER} = 'http://localhost:8529/cgi';
+
+if ( !-e 't/optional_apache-cgi.pl' ) {
+ die "ERROR: Please run test from the Catalyst-Runtime directory\n";
+}
+
+push @ARGV, glob( 't/live_*' );
+
+Apache::TestRun->new->run(@ARGV);
+
+# clean up if the server has shut down
+# this allows the test files to stay around if the user ran -start-httpd
+if ( !check_port( 'localhost', 8529 ) ) {
+ rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+}
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
Property changes on: Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-cgi.pl
___________________________________________________________________
Name: svn:executable
+ *
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi-non-root.pl
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi-non-root.pl (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi-non-root.pl 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,65 @@
+#!perl
+
+# Run all tests against FastCGI mode under Apache
+#
+# Note, to get this to run properly, you may need to give it the path to your
+# httpd.conf:
+#
+# perl t/optional_apache-fastcgi-non-root.pl -httpd_conf /etc/apache/httpd.conf
+
+use strict;
+use warnings;
+
+use Apache::Test;
+use Apache::TestRun ();
+
+use File::Path;
+use File::Copy::Recursive;
+use FindBin;
+use IO::Socket;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# create a TestApp and copy the test libs into it
+mkdir "$FindBin::Bin/../t/tmp";
+chdir "$FindBin::Bin/../t/tmp";
+system "$FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests so Apache::Test doesn't try to run them
+rmtree 't/tmp/TestApp/t';
+
+$ENV{CATALYST_SERVER} = 'http://localhost:8529/fastcgi/deep/path';
+
+if ( !-e 't/optional_apache-fastcgi.pl' ) {
+ die "ERROR: Please run test from the Catalyst-Runtime directory\n";
+}
+
+push @ARGV, glob( 't/live_*' );
+
+Apache::TestRun->new->run(@ARGV);
+
+# clean up if the server has shut down
+# this allows the test files to stay around if the user ran -start-httpd
+if ( !check_port( 'localhost', 8529 ) ) {
+ rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+}
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
Property changes on: Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi-non-root.pl
___________________________________________________________________
Name: svn:executable
+ *
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi.pl
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi.pl (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi.pl 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,65 @@
+#!perl
+
+# Run all tests against FastCGI mode under Apache
+#
+# Note, to get this to run properly, you may need to give it the path to your
+# httpd.conf:
+#
+# perl t/optional_apache-fastcgi.pl -httpd_conf /etc/apache/httpd.conf
+
+use strict;
+use warnings;
+
+use Apache::Test;
+use Apache::TestRun ();
+
+use File::Path;
+use File::Copy::Recursive;
+use FindBin;
+use IO::Socket;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# create a TestApp and copy the test libs into it
+mkdir "$FindBin::Bin/../t/tmp";
+chdir "$FindBin::Bin/../t/tmp";
+system "$FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests so Apache::Test doesn't try to run them
+rmtree 't/tmp/TestApp/t';
+
+$ENV{CATALYST_SERVER} = 'http://localhost:8529';
+
+if ( !-e 't/optional_apache-fastcgi.pl' ) {
+ die "ERROR: Please run test from the Catalyst-Runtime directory\n";
+}
+
+push @ARGV, glob( 't/live_*' );
+
+Apache::TestRun->new->run(@ARGV);
+
+# clean up if the server has shut down
+# this allows the test files to stay around if the user ran -start-httpd
+if ( !check_port( 'localhost', 8529 ) ) {
+ rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+}
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
Property changes on: Catalyst-Runtime/5.70/tags/5.7015/t/optional_apache-fastcgi.pl
___________________________________________________________________
Name: svn:executable
+ *
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_http-server-restart.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_http-server-restart.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_http-server-restart.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,244 @@
+#!perl
+
+# This test tests the standalone server's auto-restart feature.
+
+use strict;
+use warnings;
+
+use File::Path;
+use FindBin;
+use LWP::Simple;
+use IO::Socket;
+use Test::More;
+use Time::HiRes qw/sleep/;
+eval "use Catalyst::Devel 1.0;";
+
+plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
+plan skip_all => 'Catalyst::Devel required' if $@;
+plan skip_all => 'Catalyst::Devel >= 1.04 required' if $Catalyst::Devel::VERSION <= 1.03;
+eval "use File::Copy::Recursive";
+plan skip_all => 'File::Copy::Recursive required' if $@;
+
+plan tests => 120;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# create a TestApp and copy the test libs into it
+mkdir "$FindBin::Bin/../t/tmp";
+chdir "$FindBin::Bin/../t/tmp";
+system
+ "perl -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests
+rmtree 't/tmp/TestApp/t';
+
+# spawn the standalone HTTP server
+my $port = 30000 + int rand( 1 + 10000 );
+
+my $pid = open my $server,
+"perl -I$FindBin::Bin/../lib $FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl -port $port -restart 2>&1 |"
+ or die "Unable to spawn standalone HTTP server: $!";
+
+# switch to non-blocking reads so we can fail
+# gracefully instead of just hanging forever
+
+$server->blocking( 0 );
+
+# wait for it to start
+print "Waiting for server to start...\n";
+while ( check_port( 'localhost', $port ) != 1 ) {
+ sleep 1;
+}
+
+# change various files
+my @files = (
+ "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp.pm",
+ "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm",
+"$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Engine/Request/URI.pm",
+);
+
+# change some files and make sure the server restarts itself
+NON_ERROR_RESTART:
+for ( 1 .. 20 ) {
+ my $index = rand @files;
+ open my $pm, '>>', $files[$index]
+ or die "Unable to open $files[$index] for writing: $!";
+ print $pm "\n";
+ close $pm;
+
+ # give the server time to notice the change and restart
+ my $count = 0;
+ my $line;
+
+ while ( ( $line || '' ) !~ /can connect/ ) {
+ # wait for restart message
+ $line = $server->getline;
+ sleep 0.1;
+ if ( $count++ > 100 ) {
+ fail "Server restarted";
+ SKIP: {
+ skip "Server didn't restart, no sense in checking response", 1;
+ }
+ next NON_ERROR_RESTART;
+ }
+ };
+ pass "Server restarted";
+
+ $count = 0;
+ while ( check_port( 'localhost', $port ) != 1 ) {
+ # wait for it to restart
+ sleep 0.1;
+ die "Server appears to have died" if $count++ > 100;
+ }
+ my $response = get("http://localhost:$port/action/default");
+ like( $response, qr/Catalyst::Request/, 'Non-error restart, request OK' );
+
+ # give the server some time to reindex its files
+ sleep 1;
+}
+
+# add errors to the file and make sure server does not die or restart
+NO_RESTART_ON_ERROR:
+for ( 1 .. 20 ) {
+ my $index = rand @files;
+ open my $pm, '>>', $files[$index]
+ or die "Unable to open $files[$index] for writing: $!";
+ print $pm "bleh";
+ close $pm;
+
+ my $count = 0;
+ my $line;
+
+ while ( ( $line || '' ) !~ /failed/ ) {
+ # wait for restart message
+ $line = $server->getline;
+ sleep 0.1;
+ if ( $count++ > 100 ) {
+ fail "Server restarted";
+ SKIP: {
+ skip "Server didn't restart, no sense in checking response", 1;
+ }
+ next NO_RESTART_ON_ERROR;
+ }
+ };
+
+ pass "Server refused to restart";
+
+ if ( check_port( 'localhost', $port ) != 1 ) {
+ die "Server appears to have died";
+ }
+ my $response = get("http://localhost:$port/action/default");
+ like( $response, qr/Catalyst::Request/,
+ 'Syntax error, no restart, request OK' );
+
+ # give the server some time to reindex its files
+ sleep 1;
+
+}
+
+# multiple restart directories
+
+# we need different options so we have to rebuild most
+# of the testing environment
+
+kill 'KILL', $pid;
+close $server;
+
+# pick next port because the last one might still be blocked from
+# previous server. This might fail if this port is unavailable
+# but picking the first one has the same problem so this is acceptable
+
+$port += 1;
+
+{ no warnings 'once'; $File::Copy::Recursive::RMTrgFil = 1; }
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# change various files
+ at files = (
+ "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm",
+ "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Engine/Request/URI.pm",
+);
+
+my $app_root = "$FindBin::Bin/../t/tmp/TestApp";
+my $restartdirs = join ' ', map{
+ "-restartdirectory $app_root/lib/TestApp/Controller/$_"
+} qw/Action Engine/;
+
+$pid = open $server,
+"perl -I$FindBin::Bin/../lib $FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl -port $port -restart $restartdirs 2>&1 |"
+ or die "Unable to spawn standalone HTTP server: $!";
+$server->blocking( 0 );
+
+
+# wait for it to start
+print "Waiting for server to start...\n";
+while ( check_port( 'localhost', $port ) != 1 ) {
+ sleep 1;
+}
+
+MULTI_DIR_RESTART:
+for ( 1 .. 20 ) {
+ my $index = rand @files;
+ open my $pm, '>>', $files[$index]
+ or die "Unable to open $files[$index] for writing: $!";
+ print $pm "\n";
+ close $pm;
+
+ # give the server time to notice the change and restart
+ my $count = 0;
+ my $line;
+
+ while ( ( $line || '' ) !~ /can connect/ ) {
+ # wait for restart message
+ $line = $server->getline;
+ sleep 0.1;
+ if ( $count++ > 100 ) {
+ fail "Server restarted";
+ SKIP_NO_RESTART_2: {
+ skip "Server didn't restart, no sense in checking response", 1;
+ }
+ next MULTI_DIR_RESTART;
+ }
+ };
+ pass "Server restarted with multiple restartdirs";
+
+ $count = 0;
+ while ( check_port( 'localhost', $port ) != 1 ) {
+ # wait for it to restart
+ sleep 0.1;
+ die "Server appears to have died" if $count++ > 100;
+ }
+ my $response = get("http://localhost:$port/action/default");
+ like( $response, qr/Catalyst::Request/, 'Non-error restart, request OK' );
+
+ # give the server some time to reindex its files
+ sleep 1;
+}
+
+# shut it down again
+
+kill 'KILL', $pid;
+close $server;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_http-server.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_http-server.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_http-server.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,80 @@
+#!perl
+
+use strict;
+use warnings;
+
+use File::Path;
+use FindBin;
+use IO::Socket;
+use Test::More;
+
+plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
+eval "use Catalyst::Devel 1.0";
+plan skip_all => 'Catalyst::Devel required' if $@;
+eval "use File::Copy::Recursive";
+plan skip_all => 'File::Copy::Recursive required' if $@;
+plan tests => 1;
+
+# Run a single test by providing it as the first arg
+my $single_test = shift;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# create a TestApp and copy the test libs into it
+mkdir "$FindBin::Bin/../t/tmp";
+chdir "$FindBin::Bin/../t/tmp";
+system "perl -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests
+rmtree 't/tmp/TestApp/t';
+
+# spawn the standalone HTTP server
+my $port = 30000 + int rand(1 + 10000);
+my $pid = open my $server,
+ "perl -I$FindBin::Bin/../lib $FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl -port $port 2>&1 |"
+ or die "Unable to spawn standalone HTTP server: $!";
+
+# wait for it to start
+print "Waiting for server to start...\n";
+while ( check_port( 'localhost', $port ) != 1 ) {
+ sleep 1;
+}
+
+# run the testsuite against the HTTP server
+$ENV{CATALYST_SERVER} = "http://localhost:$port";
+
+if ( $single_test ) {
+ system( "perl -Ilib/ $single_test" );
+}
+else {
+ system( 'prove -r -Ilib/ t/live_*' );
+}
+
+# shut it down
+kill 'INT', $pid;
+close $server;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+ok( 'done' );
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_lighttpd-fastcgi-non-root.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_lighttpd-fastcgi-non-root.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_lighttpd-fastcgi-non-root.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,138 @@
+#!perl
+
+use strict;
+use warnings;
+
+use File::Path;
+use FindBin;
+use IO::Socket;
+use Test::More;
+
+plan skip_all => 'set TEST_LIGHTTPD to enable this test'
+ unless $ENV{TEST_LIGHTTPD};
+
+eval "use FCGI";
+plan skip_all => 'FCGI required' if $@;
+
+eval "use Catalyst::Devel 1.0";
+plan skip_all => 'Catalyst::Devel required' if $@;
+
+eval "use File::Copy::Recursive";
+plan skip_all => 'File::Copy::Recursive required' if $@;
+
+eval "use Test::Harness";
+plan skip_all => 'Test::Harness required' if $@;
+
+my $lighttpd_bin = $ENV{LIGHTTPD_BIN} || `which lighttpd`;
+chomp $lighttpd_bin;
+
+plan skip_all => 'Please set LIGHTTPD_BIN to the path to lighttpd'
+ unless $lighttpd_bin && -x $lighttpd_bin;
+
+plan tests => 1;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# create a TestApp and copy the test libs into it
+mkdir "$FindBin::Bin/../t/tmp";
+chdir "$FindBin::Bin/../t/tmp";
+system "perl -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests
+rmtree 't/tmp/TestApp/t';
+
+# Create a temporary lighttpd config
+my $docroot = "$FindBin::Bin/../t/tmp";
+my $port = 8529;
+
+# Clean up docroot path
+$docroot =~ s{/t/..}{};
+
+my $conf = <<"END";
+# basic lighttpd config file for testing fcgi+catalyst
+server.modules = (
+ "mod_access",
+ "mod_fastcgi",
+ "mod_rewrite",
+ "mod_accesslog"
+)
+
+server.document-root = "$docroot"
+
+server.errorlog = "$docroot/error.log"
+accesslog.filename = "$docroot/access.log"
+
+server.bind = "127.0.0.1"
+server.port = $port
+
+# Work around inability to hit http://localhost/deep/path
+# without a trailing slash
+url.rewrite = ( "deep/path\$" => "deep/path/" )
+
+# catalyst app specific fcgi setup
+fastcgi.server = (
+ "/deep/path" => (
+ "FastCgiTest" => (
+ "socket" => "$docroot/test.socket",
+ "check-local" => "disable",
+ "bin-path" => "$docroot/TestApp/script/testapp_fastcgi.pl",
+ "min-procs" => 1,
+ "max-procs" => 1,
+ "idle-timeout" => 20,
+ "bin-environment" => (
+ "PERL5LIB" => "$docroot/../../lib"
+ )
+ )
+ )
+)
+END
+
+open(my $lightconf, '>', "$docroot/lighttpd.conf")
+ or die "Can't open $docroot/lighttpd.conf: $!";
+print {$lightconf} $conf or die "Write error: $!";
+close $lightconf;
+
+my $pid = open my $lighttpd, "$lighttpd_bin -D -f $docroot/lighttpd.conf 2>&1 |"
+ or die "Unable to spawn lighttpd: $!";
+
+# wait for it to start
+while ( check_port( 'localhost', $port ) != 1 ) {
+ diag "Waiting for server to start...";
+ sleep 1;
+}
+
+# run the testsuite against the server
+$ENV{CATALYST_SERVER} = "http://localhost:$port/deep/path";
+
+my @tests = (shift) || glob('t/live_*');
+eval {
+ runtests(@tests);
+};
+ok(!$@, 'lighttpd tests ran OK');
+
+# shut it down
+kill 'INT', $pid;
+close $lighttpd;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_lighttpd-fastcgi.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_lighttpd-fastcgi.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_lighttpd-fastcgi.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,133 @@
+#!perl
+
+use strict;
+use warnings;
+
+use File::Path;
+use FindBin;
+use IO::Socket;
+use Test::More;
+
+plan skip_all => 'set TEST_LIGHTTPD to enable this test'
+ unless $ENV{TEST_LIGHTTPD};
+
+eval "use FCGI";
+plan skip_all => 'FCGI required' if $@;
+
+eval "use Catalyst::Devel 1.0";
+plan skip_all => 'Catalyst::Devel required' if $@;
+
+eval "use File::Copy::Recursive";
+plan skip_all => 'File::Copy::Recursive required' if $@;
+
+eval "use Test::Harness";
+plan skip_all => 'Test::Harness required' if $@;
+
+my $lighttpd_bin = $ENV{LIGHTTPD_BIN} || `which lighttpd`;
+chomp $lighttpd_bin;
+
+plan skip_all => 'Please set LIGHTTPD_BIN to the path to lighttpd'
+ unless $lighttpd_bin && -x $lighttpd_bin;
+
+plan tests => 1;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# create a TestApp and copy the test libs into it
+mkdir "$FindBin::Bin/../t/tmp";
+chdir "$FindBin::Bin/../t/tmp";
+system "perl -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests
+rmtree 't/tmp/TestApp/t';
+
+# Create a temporary lighttpd config
+my $docroot = "$FindBin::Bin/../t/tmp";
+my $port = 8529;
+
+# Clean up docroot path
+$docroot =~ s{/t/..}{};
+
+my $conf = <<"END";
+# basic lighttpd config file for testing fcgi+catalyst
+server.modules = (
+ "mod_access",
+ "mod_fastcgi",
+ "mod_accesslog"
+)
+
+server.document-root = "$docroot"
+
+server.errorlog = "$docroot/error.log"
+accesslog.filename = "$docroot/access.log"
+
+server.bind = "127.0.0.1"
+server.port = $port
+
+# catalyst app specific fcgi setup
+fastcgi.server = (
+ "" => (
+ "FastCgiTest" => (
+ "socket" => "$docroot/test.socket",
+ "check-local" => "disable",
+ "bin-path" => "$docroot/TestApp/script/testapp_fastcgi.pl",
+ "min-procs" => 1,
+ "max-procs" => 1,
+ "idle-timeout" => 20,
+ "bin-environment" => (
+ "PERL5LIB" => "$docroot/../../lib"
+ )
+ )
+ )
+)
+END
+
+open(my $lightconf, '>', "$docroot/lighttpd.conf")
+ or die "Can't open $docroot/lighttpd.conf: $!";
+print {$lightconf} $conf or die "Write error: $!";
+close $lightconf;
+
+my $pid = open my $lighttpd, "$lighttpd_bin -D -f $docroot/lighttpd.conf 2>&1 |"
+ or die "Unable to spawn lighttpd: $!";
+
+# wait for it to start
+while ( check_port( 'localhost', $port ) != 1 ) {
+ diag "Waiting for server to start...";
+ sleep 1;
+}
+
+# run the testsuite against the server
+$ENV{CATALYST_SERVER} = "http://localhost:$port";
+
+my @tests = (shift) || glob('t/live_*');
+eval {
+ runtests(@tests);
+};
+ok(!$@, 'lighttpd tests ran OK');
+
+# shut it down
+kill 'INT', $pid;
+close $lighttpd;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_memleak.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_memleak.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_memleak.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,83 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More;
+use Catalyst::Test 'TestApp';
+use YAML;
+eval "use Proc::ProcessTable";
+
+plan skip_all => 'set TEST_MEMLEAK to enable this test'
+ unless $ENV{TEST_MEMLEAK};
+plan skip_all => 'Proc::ProcessTable required for this test' if $@;
+
+eval "use HTTP::Body 0.03";
+plan skip_all => 'HTTP::Body >= 0.03 required for this test' if $@;
+
+our $t = Proc::ProcessTable->new( cache_ttys => 1 );
+our ( $initial, $final ) = ( 0, 0 );
+our $tests = YAML::LoadFile("$FindBin::Bin/optional_stress.yml");
+
+my $total_tests = 0;
+
+# let the user specify a single uri to test
+my $user_test = shift;
+if ( $user_test ) {
+ plan tests => 1;
+ run_test( $user_test );
+}
+# otherwise, run all tests
+else {
+ map { $total_tests += scalar @{ $tests->{$_} } } keys %{$tests};
+ plan tests => $total_tests;
+
+ foreach my $test_group ( keys %{$tests} ) {
+ foreach my $test ( @{ $tests->{$test_group} } ) {
+ run_test( $test );
+ }
+ }
+}
+
+sub run_test {
+ my $uri = shift || die 'No URI given for test';
+
+ print "TESTING $uri\n";
+
+ # make a few requests to set initial memory size
+ for ( 1 .. 3 ) {
+ request( $uri );
+ }
+
+ $initial = size_of($$);
+ print "Initial Size: $initial\n";
+
+ for ( 1 .. 500 ) {
+ request( $uri );
+ }
+
+ $final = size_of($$);
+ print "Final Size: $final\n";
+
+ if ( $final > $initial ) {
+ print "Leaked: " . ($final - $initial) . "\n";
+ }
+
+ is( $final, $initial, "'$uri' memory is not leaking" );
+}
+
+sub size_of {
+ my $pid = shift;
+
+ foreach my $p ( @{ $t->table } ) {
+ if ( $p->pid == $pid ) {
+ return $p->size;
+ }
+ }
+
+ die "Pid $pid not found?";
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_stress.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_stress.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_stress.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,37 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More;
+use Catalyst::Test 'TestApp';
+use YAML;
+
+our ( $iters, $tests );
+
+BEGIN {
+ plan skip_all => 'set TEST_STRESS to enable this test'
+ unless $ENV{TEST_STRESS};
+
+ $iters = $ENV{TEST_STRESS} || 10;
+ $tests = YAML::LoadFile("$FindBin::Bin/optional_stress.yml");
+
+ my $total_tests = 0;
+ map { $total_tests += scalar @{ $tests->{$_} } } keys %{$tests};
+ plan tests => $iters * $total_tests;
+}
+
+for ( 1 .. $iters ) {
+ run_tests();
+}
+
+sub run_tests {
+ foreach my $test_group ( keys %{$tests} ) {
+ foreach my $test ( @{ $tests->{$test_group} } ) {
+ ok( request($test), $test_group . ' - ' . $test );
+ }
+ }
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_stress.yml
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_stress.yml (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_stress.yml 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,103 @@
+---
+component/controller/action/auto:
+ - http://localhost/action/auto/one
+ - http://localhost/action/auto/anything
+ - http://localhost/action/auto/deep/one
+ - http://localhost/action/auto/deep/anything
+ - http://localhost/action/auto/abort/one
+ - http://localhost/action/auto/abort/anything
+component/controller/action/begin:
+ - http://localhost/action/begin
+component/controller/action/default:
+ - http://localhost/action/default
+ - http://localhost/foo/bar/action
+ - http://localhost/action/default/arg1/arg2
+component/controller/action/detach:
+ - http://localhost/action/detach/one
+ - http://localhost/action/detach/path
+ - http://localhost/action/detach/with_args/old
+ - http://localhost/action/detach/with_method_and_args/old
+component/controller/action/end:
+ - http://localhost/action/end
+component/controller/action/forward:
+ - http://localhost/action/forward/global
+ - http://localhost/action/forward/one
+ - http://localhost/action/forward/jojo
+ - http://localhost/action/forward/with_args/old
+ - http://localhost/action/forward/with_method_and_args/old
+ - http://localhost/action/forward/args_embed_relative
+ - http://localhost/action/forward/args_embed_absolute
+component/controller/action/global:
+ - http://localhost/action_global_one
+ - http://localhost/action_global_two
+ - http://localhost/action_global_three
+component/controller/action/index:
+ - http://localhost/
+ - http://localhost
+ - http://localhost/index/
+ - http://localhost/index
+ - http://localhost/action/index/
+ - http://localhost/action/index
+ - http://localhost/action/index/foo
+component/controller/action/inheritance:
+ - http://localhost/action/inheritance
+ - http://localhost/action/inheritance/a
+ - http://localhost/action/inheritance/a/b
+component/controller/action/local:
+ - http://localhost/action/local/one
+ - http://localhost/action/local/two
+ - http://localhost/action/local/three
+ - http://localhost/action/local/four/five/six
+component/controller/action/multipath:
+ - http://localhost/action/multipath/multipath
+ - http://localhost/multipath
+ - http://localhost/multipath1
+ - http://localhost/action/multipath/multipath2
+component/controller/action/path:
+ - http://localhost/action/path/a path with spaces
+ - http://localhost/action/path/åäö
+component/controller/action/private:
+ - http://localhost/action/private/one
+ - http://localhost/action/private/two
+ - http://localhost/three
+ - http://localhost/action/private/four
+ - http://localhost/action/private/five
+component/controller/action/regexp:
+ - http://localhost/action/regexp/10/hello
+ - http://localhost/action/regexp/hello/10
+component/controller/action/streaming:
+ - http://localhost/streaming
+ - http://localhost/action/streaming/body
+engine/request/body: []
+engine/request/cookies: []
+engine/request/headers: []
+engine/request/parameters: []
+engine/request/uploads: []
+engine/request/uri:
+ - http://localhost/engine/request/uri/change_path
+ - http://localhost/engine/request/uri/change_base
+ - http://localhost/engine/request/uri
+ - http://localhost/engine/request/uri?a=1;a=2;b=3
+ - http://localhost/engine/request/uri?text=Catalyst%20Rocks
+engine/response/cookies:
+ - http://localhost/engine/response/cookies/one
+ - http://localhost/engine/response/cookies/two
+engine/response/errors:
+ - http://localhost/engine/response/errors/one
+ - http://localhost/engine/response/errors/two
+ - http://localhost/engine/response/errors/three
+engine/response/headers:
+ - http://localhost/engine/response/headers/one
+engine/response/large:
+ - http://localhost/engine/response/large/
+engine/response/redirect:
+ - http://localhost/engine/response/redirect/one
+ - http://localhost/engine/response/redirect/two
+ - http://localhost/engine/response/redirect/three
+ - http://localhost/engine/response/redirect/four
+engine/response/status:
+ - http://localhost/engine/response/status/s200
+ - http://localhost/engine/response/status/s400
+ - http://localhost/engine/response/status/s403
+ - http://localhost/engine/response/status/s404
+ - http://localhost/engine/response/status/s500
Added: Catalyst-Runtime/5.70/tags/5.7015/t/optional_threads.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/optional_threads.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/optional_threads.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,54 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More;
+use Catalyst::Test 'TestApp';
+use Catalyst::Request;
+use Config;
+use HTTP::Response;
+
+plan skip_all => 'set TEST_THREADS to enable this test'
+ unless $ENV{TEST_THREADS};
+
+if ( $Config{useithreads} && !$ENV{CATALYST_SERVER} ) {
+ require threads;
+ plan tests => 3;
+}
+else {
+ if ( $ENV{CATALYST_SERVER} ) {
+ plan skip_all => 'Using remote server';
+ }
+ else {
+ plan skip_all => 'Needs a Perl with ithreads enabled';
+ }
+}
+
+no warnings 'redefine';
+sub request {
+ my $thr = threads->new(
+ sub { Catalyst::Test::local_request('TestApp', at _) },
+ @_
+ );
+ $thr->join;
+}
+
+# test that running inside a thread works ok
+{
+ my @expected = qw[
+ TestApp::Controller::Action::Default->begin
+ TestApp::Controller::Action::Default->default
+ TestApp::View::Dump::Request->process
+ TestApp->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/default'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header('X-Catalyst-Executed'), $expected, 'Executed actions' );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/something/Makefile.PL
===================================================================
Added: Catalyst-Runtime/5.70/tags/5.7015/t/something/script/foo/bar/for_dist
===================================================================
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_config.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_config.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_config.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,91 @@
+## ============================================================================
+## Test to make sure that subclassed controllers (catalyst controllers
+## that inherit from a custom base catalyst controller) don't experienc
+## any namespace collision in the values under config.
+## ============================================================================
+
+use Test::More tests => 9;
+
+use strict;
+use warnings;
+
+use_ok('Catalyst');
+
+## ----------------------------------------------------------------------------
+## First We define a base controller that inherits from Catalyst::Controller
+## We add something to the config that we expect all children classes to
+## be able to find.
+## ----------------------------------------------------------------------------
+
+{
+ package base_controller;
+
+ use base 'Catalyst::Controller';
+
+ __PACKAGE__->config( base_key => 'base_value' );
+}
+
+## ----------------------------------------------------------------------------
+## Next we instantiate two classes that inherit from the base controller. We
+## Add some local config information to these.
+## ----------------------------------------------------------------------------
+
+{
+ package controller_a;
+
+ use base 'base_controller';
+
+ __PACKAGE__->config( key_a => 'value_a' );
+}
+
+
+{
+ package controller_b;
+
+ use base 'base_controller';
+
+ __PACKAGE__->config->{key_b} = 'value_b';
+}
+
+## Okay, we expect that the base controller has a config with one key
+## and that the two children controllers inherit that config key and then
+## add one more. So the base controller has one config value and the two
+## children each have two.
+
+## ----------------------------------------------------------------------------
+## THE TESTS. Basically we first check to make sure that all the children of
+## the base_controller properly inherit the {base_key => 'base_value'} info
+## and that each of the children also has it's local config data and that none
+## of the classes have data that is unexpected.
+## ----------------------------------------------------------------------------
+
+
+# First round, does everything have what we expect to find? If these tests fail there is something
+# wrong with the way config is storing it's information.
+
+ok( base_controller->config->{base_key} eq 'base_value', 'base_controller has expected config value for "base_key"') or
+ diag('"base_key" defined as "'.base_controller->config->{base_key}.'" and not "base_value" in config');
+
+ok( controller_a->config->{base_key} eq 'base_value', 'controller_a has expected config value for "base_key"') or
+ diag('"base_key" defined as "'.controller_a->config->{base_key}.'" and not "base_value" in config');
+
+ok( controller_a->config->{key_a} eq 'value_a', 'controller_a has expected config value for "key_a"') or
+ diag('"key_a" defined as "'.controller_a->config->{key_a}.'" and not "value_a" in config');
+
+ok( controller_b->config->{base_key} eq 'base_value', 'controller_b has expected config value for "base_key"') or
+ diag('"base_key" defined as "'.controller_b->config->{base_key}.'" and not "base_value" in config');
+
+ok( controller_b->config->{key_b} eq 'value_b', 'controller_b has expected config value for "key_b"') or
+ diag('"key_b" defined as "'.controller_b->config->{key_b}.'" and not "value_b" in config');
+
+# second round, does each controller have the expected number of config values? If this test fails there is
+# probably some data collision between the controllers.
+
+ok( scalar(keys %{base_controller->config}) == 1, 'base_controller has the expected number of config values') or
+ diag("base_controller should have 1 config value, but it has ".scalar(keys %{base_controller->config}));
+
+ok( scalar(keys %{controller_a->config}) == 2, 'controller_a has the expected number of config values') or
+ diag("controller_a should have 2 config value, but it has ".scalar(keys %{base_controller->config}));
+
+ok( scalar(keys %{controller_b->config}) == 2, 'controller_b has the expected number of config values') or
+ diag("controller_a should have 2 config value, but it has ".scalar(keys %{base_controller->config}));
Property changes on: Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_config.t
___________________________________________________________________
Name: svn:executable
+ *
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_namespace.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_namespace.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_controller_namespace.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,24 @@
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+BEGIN {
+ package MyApp::Controller::Foo;
+
+ use base qw/Catalyst::Controller/;
+
+ package MyApp::Controller::Root;
+
+ use base qw/Catalyst::Controller/;
+
+ __PACKAGE__->config(namespace => '');
+
+ package Stub;
+
+ sub config { {} };
+}
+
+is(MyApp::Controller::Foo->action_namespace('Stub'), 'foo');
+
+is(MyApp::Controller::Root->action_namespace('Stub'), '');
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_action_for.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_action_for.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_action_for.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,20 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More;
+
+plan tests => 3;
+
+use_ok('TestApp');
+
+is(TestApp->action_for('global_action')->code, TestApp->can('global_action'),
+ 'action_for on appclass ok');
+
+is(TestApp->controller('Args')->action_for('args')->code,
+ TestApp::Controller::Args->can('args'),
+ 'action_for on controller ok');
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,28 @@
+use Test::More tests => 7;
+use strict;
+use warnings;
+
+use_ok('Catalyst');
+
+my @complist = map { "MyApp::$_"; } qw/C::Controller M::Model V::View/;
+
+{
+ package MyApp;
+
+ use base qw/Catalyst/;
+
+ __PACKAGE__->components({ map { ($_, $_) } @complist });
+}
+
+is(MyApp->comp('MyApp::V::View'), 'MyApp::V::View', 'Explicit return ok');
+
+is(MyApp->comp('C::Controller'), 'MyApp::C::Controller', 'Two-part return ok');
+
+is(MyApp->comp('Model'), 'MyApp::M::Model', 'Single part return ok');
+
+is(MyApp->comp('::M::'), 'MyApp::M::Model', 'Regex return ok');
+
+is_deeply([ MyApp->comp() ], \@complist, 'Empty return ok');
+
+is_deeply([ MyApp->comp('Foo') ], \@complist, 'Fallthrough return ok');
+ # Is this desired behaviour?
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component_layers.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component_layers.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component_layers.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,21 @@
+use Test::More tests => 5;
+use strict;
+use warnings;
+use lib 't/lib';
+
+# This tests that we actually load the physical
+# copy of Model::Foo::Bar, in the case that Model::Foo
+# defines the Model::Foo::Bar namespace in memory,
+# but does not load the corresponding file.
+
+use_ok 'TestApp';
+
+my $model_foo = TestApp->model('Foo');
+
+can_ok($model_foo, 'model_foo_method');
+can_ok($model_foo, 'bar');
+
+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');
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component_loading.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component_loading.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_component_loading.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,196 @@
+# 2 initial tests, and 6 per component in the loop below
+# (do not forget to update the number of components in test 3 as well)
+# 5 extra tests for the loading options
+use Test::More tests => 2 + 6 * 24 + 5;
+
+use strict;
+use warnings;
+
+use File::Spec;
+use File::Path;
+
+my $libdir = 'test_trash';
+unshift(@INC, $libdir);
+
+my $appclass = 'TestComponents';
+my @components = (
+ { type => 'Controller', prefix => 'C', name => 'Bar' },
+ { type => 'Controller', prefix => 'C', name => 'Foo::Bar' },
+ { type => 'Controller', prefix => 'C', name => 'Foo::Foo::Bar' },
+ { type => 'Controller', prefix => 'C', name => 'Foo::Foo::Foo::Bar' },
+ { type => 'Controller', prefix => 'Controller', name => 'Bar::Bar::Bar::Foo' },
+ { type => 'Controller', prefix => 'Controller', name => 'Bar::Bar::Foo' },
+ { type => 'Controller', prefix => 'Controller', name => 'Bar::Foo' },
+ { type => 'Controller', prefix => 'Controller', name => 'Foo' },
+ { type => 'Model', prefix => 'M', name => 'Bar' },
+ { type => 'Model', prefix => 'M', name => 'Foo::Bar' },
+ { type => 'Model', prefix => 'M', name => 'Foo::Foo::Bar' },
+ { type => 'Model', prefix => 'M', name => 'Foo::Foo::Foo::Bar' },
+ { type => 'Model', prefix => 'Model', name => 'Bar::Bar::Bar::Foo' },
+ { type => 'Model', prefix => 'Model', name => 'Bar::Bar::Foo' },
+ { type => 'Model', prefix => 'Model', name => 'Bar::Foo' },
+ { type => 'Model', prefix => 'Model', name => 'Foo' },
+ { type => 'View', prefix => 'V', name => 'Bar' },
+ { type => 'View', prefix => 'V', name => 'Foo::Bar' },
+ { type => 'View', prefix => 'V', name => 'Foo::Foo::Bar' },
+ { type => 'View', prefix => 'V', name => 'Foo::Foo::Foo::Bar' },
+ { type => 'View', prefix => 'View', name => 'Bar::Bar::Bar::Foo' },
+ { type => 'View', prefix => 'View', name => 'Bar::Bar::Foo' },
+ { type => 'View', prefix => 'View', name => 'Bar::Foo' },
+ { type => 'View', prefix => 'View', name => 'Foo' },
+);
+
+sub write_component_file {
+ my ($dir_list, $module_name, $content) = @_;
+
+ my $dir = File::Spec->catdir(@$dir_list);
+ my $file = File::Spec->catfile($dir, $module_name . '.pm');
+
+ mkpath(join(q{/}, @$dir_list) );
+ open(my $fh, '>', $file) or die "Could not open file $file for writing: $!";
+ print $fh $content;
+ close $fh;
+}
+
+sub make_component_file {
+ my ($type, $prefix, $name) = @_;
+
+ my $compbase = "Catalyst::${type}";
+ my $fullname = "${appclass}::${prefix}::${name}";
+ my @namedirs = split(/::/, $name);
+ my $name_final = pop(@namedirs);
+ my @dir_list = ($libdir, $appclass, $prefix, @namedirs);
+
+ write_component_file(\@dir_list, $name_final, <<EOF);
+package $fullname;
+use base '$compbase';
+sub COMPONENT {
+ my \$self = shift->NEXT::COMPONENT(\@_);
+ no strict 'refs';
+ *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };
+ \$self;
+}
+1;
+
+EOF
+}
+
+foreach my $component (@components) {
+ make_component_file($component->{type},
+ $component->{prefix},
+ $component->{name});
+}
+
+eval "package $appclass; use Catalyst; __PACKAGE__->setup";
+
+can_ok( $appclass, 'components');
+
+my $complist = $appclass->components;
+
+# the +1 below is for the app class itself
+is(scalar keys %$complist, 24+1, "Correct number of components loaded");
+
+foreach (keys %$complist) {
+
+ # Skip the component which happens to be the app itself
+ next if $_ eq $appclass;
+
+ my $instance = $appclass->component($_);
+ isa_ok($instance, $_);
+ can_ok($instance, 'whoami');
+ is($instance->whoami, $_);
+
+ if($_ =~ /^${appclass}::(?:V|View)::(.*)/) {
+ my $moniker = $1;
+ isa_ok($instance, 'Catalyst::View');
+ can_ok($appclass->view($moniker), 'whoami');
+ is($appclass->view($moniker)->whoami, $_);
+ }
+ elsif($_ =~ /^${appclass}::(?:M|Model)::(.*)/) {
+ my $moniker = $1;
+ isa_ok($instance, 'Catalyst::Model');
+ can_ok($appclass->model($moniker), 'whoami');
+ is($appclass->model($moniker)->whoami, $_);
+ }
+ elsif($_ =~ /^${appclass}::(?:C|Controller)::(.*)/) {
+ my $moniker = $1;
+ isa_ok($instance, 'Catalyst::Controller');
+ can_ok($appclass->controller($moniker), 'whoami');
+ is($appclass->controller($moniker)->whoami, $_);
+ }
+ else {
+ die "Something is wrong with this test, this should"
+ . " have been unreachable";
+ }
+}
+
+rmtree($libdir);
+
+# test extra component loading options
+
+$appclass = 'ExtraOptions';
+push @components, { type => 'View', prefix => 'Extra', name => 'Foo' };
+
+foreach my $component (@components) {
+ make_component_file($component->{type},
+ $component->{prefix},
+ $component->{name});
+}
+
+eval qq(
+package $appclass;
+use Catalyst;
+__PACKAGE__->config->{ setup_components } = {
+ search_extra => [ '::Extra' ],
+ except => [ "${appclass}::Controller::Foo" ]
+};
+__PACKAGE__->setup;
+);
+
+can_ok( $appclass, 'components');
+
+$complist = $appclass->components;
+
+is(scalar keys %$complist, 24+1, "Correct number of components loaded");
+
+ok( !exists $complist->{ "${appclass}::Controller::Foo" }, 'Controller::Foo was skipped' );
+ok( exists $complist->{ "${appclass}::Extra::Foo" }, 'Extra::Foo was loaded' );
+
+rmtree($libdir);
+
+$appclass = "ComponentOnce";
+
+write_component_file([$libdir, $appclass, 'Model'], 'TopLevel', <<EOF);
+package ${appclass}::Model::TopLevel;
+use base 'Catalyst::Model';
+sub COMPONENT {
+
+ my \$self = shift->NEXT::COMPONENT(\@_);
+ no strict 'refs';
+ *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };
+ \$self;
+}
+
+package ${appclass}::Model::TopLevel::Nested;
+
+sub COMPONENT { die "COMPONENT called in the wrong order!"; }
+
+1;
+
+EOF
+
+write_component_file([$libdir, $appclass, 'Model', 'TopLevel'], 'Nested', <<EOF);
+package ${appclass}::Model::TopLevel::Nested;
+use base 'Catalyst::Model';
+
+no warnings 'redefine';
+sub COMPONENT { return shift->NEXT::COMPONENT(\@_); }
+1;
+
+EOF
+
+eval "package $appclass; use Catalyst; __PACKAGE__->setup";
+
+is($@, '', "Didn't load component twice");
+
+rmtree($libdir);
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_log.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_log.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_log.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,72 @@
+use strict;
+use warnings;
+
+use Test::More tests => 23;
+
+my $LOG;
+
+BEGIN {
+ chdir 't' if -d 't';
+ use lib '../lib';
+ $LOG = 'Catalyst::Log';
+ use_ok $LOG or die;
+}
+my @MESSAGES;
+{
+ no warnings 'redefine';
+ *Catalyst::Log::_send_to_log = sub {
+ my $self = shift;
+ push @MESSAGES, @_;
+ };
+}
+
+can_ok $LOG, 'new';
+ok my $log = $LOG->new, '... and creating a new log object should succeed';
+isa_ok $log, $LOG, '... and the object it returns';
+
+can_ok $log, 'is_info';
+ok $log->is_info, '... and the default behavior is to allow info messages';
+
+can_ok $log, 'info';
+ok $log->info('hello there!'),
+ '... passing it an info message should succeed';
+
+can_ok $log, "_flush";
+$log->_flush;
+ok @MESSAGES, '... and flushing the log should succeed';
+is scalar @MESSAGES, 1, '... with one log message';
+like $MESSAGES[0], qr/^\[info\] hello there!$/,
+ '... which should match the format we expect';
+
+{
+
+ package Catalyst::Log::Subclass;
+ use base qw/Catalyst::Log/;
+
+ sub _send_to_log {
+ my $self = shift;
+ push @MESSAGES, '---';
+ push @MESSAGES, @_;
+ }
+}
+
+my $SUBCLASS = 'Catalyst::Log::Subclass';
+can_ok $SUBCLASS, 'new';
+ok $log = Catalyst::Log::Subclass->new,
+ '... and the log subclass constructor shoudl return a new object';
+isa_ok $log, $SUBCLASS, '... and the object it returns';
+isa_ok $log, $LOG, '... and it also';
+
+can_ok $log, 'info';
+ok $log->info('hi there!'),
+ '... passing it an info message should succeed';
+
+can_ok $log, "_flush";
+ at MESSAGES = (); # clear the message log
+$log->_flush;
+ok @MESSAGES, '... and flushing the log should succeed';
+is scalar @MESSAGES, 2, '... with two log messages';
+is $MESSAGES[0], '---', '... with the first one being our new data';
+like $MESSAGES[1], qr/^\[info\] hi there!$/,
+ '... which should match the format we expect';
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_merge_config_hashes.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_merge_config_hashes.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_merge_config_hashes.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+my @tests = (
+ {
+ given => [ { a => 1 }, { b => 1 } ],
+ expects => { a => 1, b => 1 }
+ },
+ {
+ given => [ { a => 1 }, { a => { b => 1 } } ],
+ expects => { a => { b => 1 } }
+ },
+ {
+ given => [ { a => { b => 1 } }, { a => 1 } ],
+ expects => { a => 1 }
+ },
+ {
+ given => [ { a => 1 }, { a => [ 1 ] } ],
+ expects => { a => [ 1 ] }
+ },
+ {
+ given => [ { a => [ 1 ] }, { a => 1 } ],
+ expects => { a => 1 }
+ },
+ {
+ given => [ { a => { b => 1 } }, { a => { b => 2 } } ],
+ expects => { a => { b => 2 } }
+ },
+ {
+ given => [ { a => { b => 1 } }, { a => { c => 1 } } ],
+ expects => { a => { b => 1, c => 1 } }
+ },
+);
+
+plan tests => scalar @tests + 1;
+
+use_ok('Catalyst');
+
+for my $test ( @ tests ) {
+ is_deeply( Catalyst->merge_config_hashes( @{ $test->{ given } } ), $test->{ expects } );
+}
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_mvc.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_mvc.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_mvc.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,92 @@
+use Test::More tests => 27;
+use strict;
+use warnings;
+
+use_ok('Catalyst');
+
+my @complist =
+ map { "MyApp::$_"; }
+ qw/C::Controller M::Model V::View Controller::C Model::M View::V Controller::Model::Dummy::Model Model::Dummy::Model/;
+
+my $thingie={};
+bless $thingie,'MyApp::Model::Test::Object';
+push @complist,$thingie;
+{
+
+ package MyApp;
+
+ use base qw/Catalyst/;
+
+ __PACKAGE__->components( { map { ( ref($_)||$_ , $_ ) } @complist } );
+}
+
+is( MyApp->view('View'), 'MyApp::V::View', 'V::View ok' );
+
+is( MyApp->controller('Controller'),
+ 'MyApp::C::Controller', 'C::Controller ok' );
+
+is( MyApp->model('Model'), 'MyApp::M::Model', 'M::Model ok' );
+
+is( MyApp->model('Dummy::Model'), 'MyApp::Model::Dummy::Model', 'Model::Dummy::Model ok' );
+
+isa_ok( MyApp->model('Test::Object'), 'MyApp::Model::Test::Object', 'Test::Object ok' );
+
+is( MyApp->controller('Model::Dummy::Model'), 'MyApp::Controller::Model::Dummy::Model', 'Controller::Model::Dummy::Model ok' );
+
+is( MyApp->view('V'), 'MyApp::View::V', 'View::V ok' );
+
+is( MyApp->controller('C'), 'MyApp::Controller::C', 'Controller::C ok' );
+
+is( MyApp->model('M'), 'MyApp::Model::M', 'Model::M ok' );
+
+is_deeply( [ sort MyApp->views ],
+ [ qw/V View/ ],
+ 'views ok' );
+
+is_deeply( [ sort MyApp->controllers ],
+ [ qw/C Controller Model::Dummy::Model/ ],
+ 'controllers ok');
+
+is_deeply( [ sort MyApp->models ],
+ [ qw/Dummy::Model M Model Test::Object/ ],
+ 'models ok');
+
+is (MyApp->view , 'MyApp::V::View', 'view() with no defaults ok');
+
+is ( bless ({stash=>{current_view=>'V'}}, 'MyApp')->view , 'MyApp::View::V', 'current_view ok');
+
+my $view = bless {} , 'MyApp::View::V';
+is ( bless ({stash=>{current_view_instance=> $view }}, 'MyApp')->view , $view, 'current_view_instance ok');
+
+is ( bless ({stash=>{current_view_instance=> $view, current_view=>'MyApp::V::View' }}, 'MyApp')->view , $view,
+ 'current_view_instance precedes current_view ok');
+
+is (MyApp->model , 'MyApp::M::Model', 'model() with no defaults ok');
+
+is ( bless ({stash=>{current_model=>'M'}}, 'MyApp')->model , 'MyApp::Model::M', 'current_model ok');
+
+my $model = bless {} , 'MyApp::Model::M';
+is ( bless ({stash=>{current_model_instance=> $model }}, 'MyApp')->model , $model, 'current_model_instance ok');
+
+is ( bless ({stash=>{current_model_instance=> $model, current_model=>'MyApp::M::Model' }}, 'MyApp')->model , $model,
+ 'current_model_instance precedes current_model ok');
+
+MyApp->config->{default_view} = 'V';
+is ( bless ({stash=>{}}, 'MyApp')->view , 'MyApp::View::V', 'default_view ok');
+is ( MyApp->view , 'MyApp::View::V', 'default_view in class method ok');
+
+MyApp->config->{default_model} = 'M';
+is ( bless ({stash=>{}}, 'MyApp')->model , 'MyApp::Model::M', 'default_model ok');
+is ( MyApp->model , 'MyApp::Model::M', 'default_model in class method ok');
+
+#checking @args passed to ACCEPT_CONTEXT
+my $args;
+{
+ no warnings;
+ *MyApp::Model::M::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
+ *MyApp::View::V::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
+}
+MyApp->model('M', qw/foo bar/);
+is_deeply($args, [qw/foo bar/], '$c->model args passed to ACCEPT_CONTEXT ok');
+MyApp->view('V', qw/baz moo/);
+is_deeply($args, [qw/baz moo/], '$c->view args passed to ACCEPT_CONTEXT ok');
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_path_to.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_path_to.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_path_to.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,39 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+my %non_unix = (
+ MacOS => 1,
+ MSWin32 => 1,
+ os2 => 1,
+ VMS => 1,
+ epoc => 1,
+ NetWare => 1,
+ dos => 1,
+ cygwin => 1
+);
+
+my $os = $non_unix{$^O} ? $^O : 'Unix';
+
+if( $os ne 'Unix' ) {
+ plan skip_all => 'tests require Unix';
+}
+else {
+ plan tests => 3;
+}
+
+use_ok('Catalyst');
+
+my $context = 'Catalyst';
+
+my $config = Catalyst->config;
+
+$config->{home} = '/home/sri/my-app/';
+
+is( Catalyst::path_to( $context, 'foo' ), '/home/sri/my-app/foo', 'Unix path' );
+
+$config->{home} = '/Users/sri/myapp/';
+
+is( Catalyst::path_to( $context, 'foo', 'bar' ),
+ '/Users/sri/myapp/foo/bar', 'deep Unix path' );
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_plugin.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_plugin.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_plugin.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 22;
+
+use lib 't/lib';
+
+{
+
+ package Faux::Plugin;
+
+ sub new { bless {}, shift }
+ my $count = 1;
+ sub count { $count++ }
+}
+
+use Catalyst::Test qw/PluginTestApp/;
+
+ok( get("/compile_time_plugins"), "get ok" );
+ok( get("/run_time_plugins"), "get ok" );
+
+use_ok 'TestApp';
+my @expected = qw(
+ Catalyst::Plugin::Test::Errors
+ Catalyst::Plugin::Test::Headers
+ Catalyst::Plugin::Test::Inline
+ Catalyst::Plugin::Test::Plugin
+ TestApp::Plugin::FullyQualified
+);
+
+# Faux::Plugin is no longer reported
+is_deeply [ TestApp->registered_plugins ], \@expected,
+ 'registered_plugins() should only report the plugins for the current class';
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,105 @@
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use URI;
+
+use_ok('Catalyst');
+
+my $request = Catalyst::Request->new( {
+ base => URI->new('http://127.0.0.1/foo')
+ } );
+
+my $context = Catalyst->new( {
+ request => $request,
+ namespace => 'yada',
+ } );
+
+is(
+ Catalyst::uri_for( $context, '/bar/baz' )->as_string,
+ 'http://127.0.0.1/foo/bar/baz',
+ 'URI for absolute path'
+);
+
+is(
+ Catalyst::uri_for( $context, 'bar/baz' )->as_string,
+ 'http://127.0.0.1/foo/yada/bar/baz',
+ 'URI for relative path'
+);
+
+is(
+ Catalyst::uri_for( $context, '', 'arg1', 'arg2' )->as_string,
+ 'http://127.0.0.1/foo/yada/arg1/arg2',
+ 'URI for undef action with args'
+);
+
+
+is( Catalyst::uri_for( $context, '../quux' )->as_string,
+ 'http://127.0.0.1/foo/quux', 'URI for relative dot path' );
+
+is(
+ Catalyst::uri_for( $context, 'quux', { param1 => 'value1' } )->as_string,
+ 'http://127.0.0.1/foo/yada/quux?param1=value1',
+ 'URI for undef action with query params'
+);
+
+is (Catalyst::uri_for( $context, '/bar/wibble?' )->as_string,
+ 'http://127.0.0.1/foo/bar/wibble%3F', 'Question Mark gets encoded'
+);
+
+is( Catalyst::uri_for( $context, qw/bar wibble?/, 'with space' )->as_string,
+ 'http://127.0.0.1/foo/yada/bar/wibble%3F/with%20space', 'Space gets encoded'
+);
+
+
+# test with utf-8
+is(
+ Catalyst::uri_for( $context, 'quux', { param1 => "\x{2620}" } )->as_string,
+ 'http://127.0.0.1/foo/yada/quux?param1=%E2%98%A0',
+ 'URI for undef action with query params in unicode'
+);
+is(
+ Catalyst::uri_for( $context, 'quux', { 'param:1' => "foo" } )->as_string,
+ 'http://127.0.0.1/foo/yada/quux?param%3A1=foo',
+ 'URI for undef action with query params in unicode'
+);
+
+# test with object
+is(
+ Catalyst::uri_for( $context, 'quux', { param1 => $request->base } )->as_string,
+ 'http://127.0.0.1/foo/yada/quux?param1=http%3A%2F%2F127.0.0.1%2Ffoo',
+ 'URI for undef action with query param as object'
+);
+
+$request->base( URI->new('http://localhost:3000/') );
+$request->match( 'orderentry/contract' );
+is(
+ Catalyst::uri_for( $context, '/Orderentry/saveContract' )->as_string,
+ 'http://localhost:3000/Orderentry/saveContract',
+ 'URI for absolute path'
+);
+
+{
+ $request->base( URI->new('http://127.0.0.1/') );
+
+ $context->namespace('');
+
+ is( Catalyst::uri_for( $context, '/bar/baz' )->as_string,
+ 'http://127.0.0.1/bar/baz', 'URI with no base or match' );
+
+ # test "0" as the path
+ is( Catalyst::uri_for( $context, qw/0 foo/ )->as_string,
+ 'http://127.0.0.1/0/foo', '0 as path is ok'
+ );
+
+}
+
+# test with undef -- no warnings should be thrown
+{
+ my $warnings = 0;
+ local $SIG{__WARN__} = sub { $warnings++ };
+
+ Catalyst::uri_for( $context, '/bar/baz', { foo => undef } )->as_string,
+ is( $warnings, 0, "no warnings emitted" );
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for_action.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for_action.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for_action.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,171 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More;
+
+plan tests => 28;
+
+use_ok('TestApp');
+
+my $dispatcher = TestApp->dispatcher;
+
+#
+# Private Action
+#
+my $private_action = $dispatcher->get_action_by_path(
+ '/class_forward_test_method'
+ );
+
+ok(!defined($dispatcher->uri_for_action($private_action)),
+ "Private action returns undef for URI");
+
+#
+# Path Action
+#
+my $path_action = $dispatcher->get_action_by_path(
+ '/action/testrelative/relative'
+ );
+
+is($dispatcher->uri_for_action($path_action), "/action/relative/relative",
+ "Public path action returns correct URI");
+
+ok(!defined($dispatcher->uri_for_action($path_action, [ 'foo' ])),
+ "no URI returned for Path action when snippets are given");
+
+#
+# Regex Action
+#
+my $regex_action = $dispatcher->get_action_by_path(
+ '/action/regexp/one'
+ );
+
+ok(!defined($dispatcher->uri_for_action($regex_action)),
+ "Regex action without captures returns undef");
+
+ok(!defined($dispatcher->uri_for_action($regex_action, [ 1, 2, 3 ])),
+ "Regex action with too many captures returns undef");
+
+is($dispatcher->uri_for_action($regex_action, [ 'foo', 123 ]),
+ "/action/regexp/foo/123",
+ "Regex action interpolates captures correctly");
+
+#
+# Index Action
+#
+my $index_action = $dispatcher->get_action_by_path(
+ '/action/index/index'
+ );
+
+ok(!defined($dispatcher->uri_for_action($index_action, [ 'foo' ])),
+ "no URI returned for index action when snippets are given");
+
+is($dispatcher->uri_for_action($index_action),
+ "/action/index",
+ "index action returns correct path");
+
+#
+# Chained Action
+#
+my $chained_action = $dispatcher->get_action_by_path(
+ '/action/chained/endpoint',
+ );
+
+ok(!defined($dispatcher->uri_for_action($chained_action)),
+ "Chained action without captures returns undef");
+
+ok(!defined($dispatcher->uri_for_action($chained_action, [ 1, 2 ])),
+ "Chained action with too many captures returns undef");
+
+is($dispatcher->uri_for_action($chained_action, [ 1 ]),
+ "/chained/foo/1/end",
+ "Chained action with correct captures returns correct path");
+
+#
+# Tests with Context
+#
+my $request = Catalyst::Request->new( {
+ base => URI->new('http://127.0.0.1/foo')
+ } );
+
+my $context = TestApp->new( {
+ request => $request,
+ namespace => 'yada',
+ } );
+
+is($context->uri_for($path_action),
+ "http://127.0.0.1/foo/action/relative/relative",
+ "uri_for correct for path action");
+
+is($context->uri_for($path_action, qw/one two/, { q => 1 }),
+ "http://127.0.0.1/foo/action/relative/relative/one/two?q=1",
+ "uri_for correct for path action with args and query");
+
+ok(!defined($context->uri_for($path_action, [ 'blah' ])),
+ "no URI returned by uri_for for Path action with snippets");
+
+is($context->uri_for($regex_action, [ 'foo', 123 ], qw/bar baz/, { q => 1 }),
+ "http://127.0.0.1/foo/action/regexp/foo/123/bar/baz?q=1",
+ "uri_for correct for regex with captures, args and query");
+
+is($context->uri_for($chained_action, [ 1 ], 2, { q => 1 }),
+ "http://127.0.0.1/foo/chained/foo/1/end/2?q=1",
+ "uri_for correct for chained with captures, args and query");
+
+#
+# More Chained with Context Tests
+#
+{
+ sub __action { $dispatcher->get_action_by_path( @_ ) }
+
+ is( $context->uri_for( __action( '/action/chained/endpoint2' ), [1,2], (3,4), { x => 5 } ),
+ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/4?x=5',
+ 'uri_for correct for chained with multiple captures and args' );
+
+ is( $context->uri_for( __action( '/action/chained/three_end' ), [1,2,3], (4,5,6) ),
+ 'http://127.0.0.1/foo/chained/one/1/two/2/3/three/4/5/6',
+ 'uri_for correct for chained with multiple capturing actions' );
+
+ my $action_needs_two = __action( '/action/chained/endpoint2' );
+
+ ok( ! defined( $context->uri_for($action_needs_two, [1], (2,3)) ),
+ 'uri_for returns undef for not enough captures' );
+
+ is( $context->uri_for($action_needs_two, [1,2], (2,3)),
+ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/2/3',
+ 'uri_for returns correct uri for correct captures' );
+
+ ok( ! defined( $context->uri_for($action_needs_two, [1,2,3], (2,3)) ),
+ 'uri_for returns undef for too many captures' );
+
+ is( $context->uri_for($action_needs_two, [1,2], (3)),
+ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3',
+ 'uri_for returns uri with lesser args than specified on action' );
+
+ is( $context->uri_for($action_needs_two, [1,2], (3,4,5)),
+ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/4/5',
+ 'uri_for returns uri with more args than specified on action' );
+
+ is( $context->uri_for($action_needs_two, [1,''], (3,4)),
+ 'http://127.0.0.1/foo/chained/foo2/1//end2/3/4',
+ 'uri_for returns uri with empty capture on undef capture' );
+
+ is( $context->uri_for($action_needs_two, [1,2], ('',3)),
+ 'http://127.0.0.1/foo/chained/foo2/1/2/end2//3',
+ 'uri_for returns uri with empty arg on undef argument' );
+
+ is( $context->uri_for($action_needs_two, [1,2], (3,'')),
+ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/',
+ 'uri_for returns uri with empty arg on undef last argument' );
+
+ my $complex_chained = __action( '/action/chained/empty_chain_f' );
+ is( $context->uri_for( $complex_chained, [23], (13), {q => 3} ),
+ 'http://127.0.0.1/foo/chained/empty/23/13?q=3',
+ 'uri_for returns correct uri for chain with many empty path parts' );
+}
+
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for_multibytechar.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for_multibytechar.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_core_uri_for_multibytechar.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+use FindBin;
+use File::Spec;
+use lib File::Spec->catfile($FindBin::Bin, 'lib');
+
+use Test::More tests => 5;
+
+use_ok('TestApp');
+
+my $base = 'http://127.0.0.1';
+
+my $request = Catalyst::Request->new({
+ base => URI->new($base),
+ uri => URI->new("$base/"),
+});
+
+my $context = TestApp->new({
+ request => $request,
+});
+
+
+my $uri_with_multibyte = URI->new($base);
+$uri_with_multibyte->path('/');
+$uri_with_multibyte->query_form(
+ name => '村瀬大輔',
+);
+
+# multibyte with utf8 bytes
+is($context->uri_for('/', { name => '村瀬大輔' }), $uri_with_multibyte, 'uri_for with utf8 bytes query');
+is($context->req->uri_with({ name => '村瀬大輔' }), $uri_with_multibyte, 'uri_with with utf8 bytes query');
+
+# multibyte with utf8 string
+is($context->uri_for('/', { name => "\x{6751}\x{702c}\x{5927}\x{8f14}" }), $uri_with_multibyte, 'uri_for with utf8 string query');
+is($context->req->uri_with({ name => "\x{6751}\x{702c}\x{5927}\x{8f14}" }), $uri_with_multibyte, 'uri_with with utf8 string query');
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_load_catalyst_test.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_load_catalyst_test.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_load_catalyst_test.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,16 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+plan tests => 3;
+
+use_ok('Catalyst::Test');
+
+eval "get('http://localhost')";
+isnt( $@, "", "get returns an error message with no app specified");
+
+eval "request('http://localhost')";
+isnt( $@, "", "request returns an error message with no app specified");
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_stats.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_stats.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_stats.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,155 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use Time::HiRes qw/gettimeofday/;
+use Tree::Simple;
+
+my @fudge_t = ( 0, 0 );
+BEGIN {
+ no warnings;
+ *Time::HiRes::gettimeofday = sub () { return @fudge_t };
+}
+
+BEGIN { use_ok("Catalyst::Stats") };
+
+{
+ my $stats = Catalyst::Stats->new;
+ is (ref($stats), "Catalyst::Stats", "new");
+
+ my @expected; # level, string, time
+
+ $fudge_t[0] = 1;
+ ok($stats->profile("single comment arg"), "profile");
+ push(@expected, [ 0, "- single comment arg", 1, 0 ]);
+
+ $fudge_t[0] = 3;
+ $stats->profile(comment => "hash comment arg");
+ push(@expected, [ 0, "- hash comment arg", 2, 0 ]);
+
+ $fudge_t[0] = 10;
+ $stats->profile(begin => "block", comment => "start block");
+ push(@expected, [ 0, "block - start block", 4, 1 ]);
+
+
+ $fudge_t[0] = 11;
+ $stats->profile("inside block");
+ push(@expected, [ 1, "- inside block", 1, 0 ]);
+
+ $fudge_t[1] = 100000;
+ my $uid = $stats->profile(begin => "nested block", uid => "boo");
+ push(@expected, [ 1, "nested block", 0.7, 1 ]);
+ is ($uid, "boo", "set UID");
+
+ $stats->enable(0);
+ $fudge_t[1] = 150000;
+ $stats->profile("this shouldn't appear");
+ $stats->enable(1);
+
+ $fudge_t[1] = 200000;
+ $stats->profile(begin => "double nested block 1");
+ push(@expected, [ 2, "double nested block 1", 0.2, 1 ]);
+
+ $stats->profile(comment => "attach to uid", parent => $uid);
+
+ $fudge_t[1] = 250000;
+ $stats->profile(begin => "badly nested block 1");
+ push(@expected, [ 3, "badly nested block 1", 0.35, 1 ]);
+
+ $fudge_t[1] = 300000;
+ $stats->profile(comment => "interleave 1");
+ push(@expected, [ 4, "- interleave 1", 0.05, 0 ]);
+
+ $fudge_t[1] = 400000; # end double nested block time
+ $stats->profile(end => "double nested block 1");
+
+ $fudge_t[1] = 500000;
+ $stats->profile(comment => "interleave 2");
+ push(@expected, [ 4, "- interleave 2", 0.2, 0 ]);
+
+ $fudge_t[1] = 600000; # end badly nested block time
+ $stats->profile(end => "badly nested block 1");
+
+ $fudge_t[1] = 800000; # end nested block time
+ $stats->profile(end => "nested block");
+
+ $fudge_t[0] = 14; # end block time
+ $fudge_t[1] = 0;
+ $stats->profile(end => "block", comment => "end block");
+
+ push(@expected, [ 2, "- attach to uid", 0.1, 0 ]);
+
+
+ my @report = $stats->report;
+ is_deeply(\@report, \@expected, "report");
+
+ is ($stats->elapsed, 14, "elapsed");
+}
+
+# COMPATABILITY METHODS
+
+# accept
+{
+ my $stats = Catalyst::Stats->new;
+ my $root = $stats->{tree};
+ my $uid = $root->getUID;
+
+ my $visitor = Tree::Simple::Visitor::FindByUID->new;
+ $visitor->includeTrunk(1); # needed for this test
+ $visitor->searchForUID($uid);
+ $stats->accept($visitor);
+ is( $visitor->getResult, $root, '[COMPAT] accept()' );
+
+}
+
+# addChild
+{
+ my $stats = Catalyst::Stats->new;
+ my $node = Tree::Simple->new(
+ {
+ action => 'test',
+ elapsed => '10s',
+ comment => "",
+ }
+ );
+
+ $stats->addChild( $node );
+
+ my $actual = $stats->{ tree }->{ _children }->[ 0 ];
+ is( $actual, $node, '[COMPAT] addChild()' );
+ is( $actual->getNodeValue->{ elapsed }, 10, '[COMPAT] addChild(), data munged' );
+}
+
+# setNodeValue
+{
+ my $stats = Catalyst::Stats->new;
+ my $stat = {
+ action => 'test',
+ elapsed => '10s',
+ comment => "",
+ };
+
+ $stats->setNodeValue( $stat );
+
+ is_deeply( $stats->{tree}->getNodeValue, { action => 'test', elapsed => 10, comment => '' } , '[COMPAT] setNodeValue(), data munged' );
+}
+
+# getNodeValue
+{
+ my $stats = Catalyst::Stats->new;
+ my $expected = $stats->{tree}->getNodeValue->{t};
+ is_deeply( $stats->getNodeValue, $expected, '[COMPAT] getNodeValue()' );
+}
+
+# traverse
+{
+ my $stats = Catalyst::Stats->new;
+ $stats->{tree}->addChild( Tree::Simple->new( { foo => 'bar' } ) );
+ my @value;
+ $stats->traverse( sub { push @value, shift->getNodeValue->{ foo }; } );
+
+ is_deeply( \@value, [ 'bar' ], '[COMPAT] traverse()' );
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_env_value.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_env_value.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_env_value.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,44 @@
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+BEGIN { use_ok("Catalyst::Utils") }
+
+##############################################################################
+### No env vars defined
+##############################################################################
+{
+ ok( !Catalyst::Utils::env_value( 'MyApp', 'Key' ),
+ 'No env values defined returns false'
+ );
+}
+
+##############################################################################
+### App env var defined
+##############################################################################
+{
+ $ENV{'MYAPP2_KEY'} = 'Env value 2';
+ is( Catalyst::Utils::env_value( 'MyApp2', 'Key' ),
+ 'Env value 2', 'Got the right value from the application var' );
+}
+
+##############################################################################
+### Catalyst env var defined
+##############################################################################
+{
+ $ENV{'CATALYST_KEY'} = 'Env value 3';
+ is( Catalyst::Utils::env_value( 'MyApp3', 'Key' ),
+ 'Env value 3', 'Got the right value from the catalyst var' );
+}
+
+##############################################################################
+### Catalyst and Application env vars defined
+##############################################################################
+{
+ $ENV{'CATALYST_KEY'} = 'Env value bad';
+ $ENV{'MYAPP4_KEY'} = 'Env value 4';
+ is( Catalyst::Utils::env_value( 'MyApp4', 'Key' ),
+ 'Env value 4', 'Got the right value from the application var' );
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_load_class.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_load_class.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_load_class.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,64 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+
+use lib "t/lib";
+
+BEGIN { use_ok("Catalyst::Utils") };
+
+{
+ package This::Module::Is::Not::In::Inc::But::Does::Exist;
+ sub moose {};
+}
+
+my $warnings = 0;
+$SIG{__WARN__} = sub { $warnings++ };
+
+ok( !Class::Inspector->loaded("TestApp::View::Dump"), "component not yet loaded" );
+
+Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump");
+
+ok( Class::Inspector->loaded("TestApp::View::Dump"), "loaded ok" );
+is( $warnings, 0, "no warnings emitted" );
+
+$warnings = 0;
+
+Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump");
+is( $warnings, 0, "calling again doesn't reaload" );
+
+ok( !Class::Inspector->loaded("TestApp::View::Dump::Request"), "component not yet loaded" );
+
+Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump::Request");
+ok( Class::Inspector->loaded("TestApp::View::Dump::Request"), "loaded ok" );
+
+is( $warnings, 0, "calling again doesn't reaload" );
+
+undef $@;
+eval { Catalyst::Utils::ensure_class_loaded("This::Module::Is::Probably::Not::There") };
+ok( $@, "doesn't defatalize" );
+like( $@, qr/There\.pm.*\@INC/, "error looks right" );
+
+undef $@;
+eval { Catalyst::Utils::ensure_class_loaded("__PACKAGE__") };
+ok( $@, "doesn't defatalize" );
+like( $@, qr/__PACKAGE__\.pm.*\@INC/, "errors sanely on __PACKAGE__.pm" );
+
+$@ = "foo";
+Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump::Response");
+is( $@, "foo", '$@ is untouched' );
+
+undef $@;
+eval { Catalyst::Utils::ensure_class_loaded("This::Module::Is::Not::In::Inc::But::Does::Exist") };
+ok( !$@, "no error when loading non existent .pm that *does* have a symbol table entry" );
+
+undef $@;
+eval { Catalyst::Utils::ensure_class_loaded('Silly::File::.#Name') };
+like($@, qr/Malformed class Name/, 'errored when attempting to load a file beginning with a .');
+
+undef $@;
+eval { Catalyst::Utils::ensure_class_loaded('Silly::File::Name.pm') };
+like($@, qr/Malformed class Name/, 'errored sanely when given a classname ending in .pm');
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_prefix.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_prefix.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_prefix.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+
+use lib "t/lib";
+
+BEGIN { use_ok("Catalyst::Utils") };
+
+is( Catalyst::Utils::class2prefix('MyApp::V::Foo::Bar'), 'foo/bar', 'class2prefix works with M/V/C' );
+
+is( Catalyst::Utils::class2prefix('MyApp::Controller::Foo::Bar'), 'foo/bar', 'class2prefix works with Model/View/Controller' );
+
+is( Catalyst::Utils::class2prefix('MyApp::Controller::Foo::View::Bar'), 'foo/view/bar', 'class2prefix works with tricky components' );
+
+is( Catalyst::Utils::appprefix('MyApp::Foo'), 'myapp_foo', 'appprefix works' );
+
+is( Catalyst::Utils::class2appclass('MyApp::Foo::Controller::Bar::View::Baz'), 'MyApp::Foo', 'class2appclass works' );
+
+is( Catalyst::Utils::class2classprefix('MyApp::Foo::Controller::Bar::View::Baz'), 'MyApp::Foo::Controller', 'class2classprefix works' );
+
+is( Catalyst::Utils::class2classsuffix('MyApp::Foo::Controller::Bar::View::Baz'), 'Controller::Bar::View::Baz', 'class2classsuffix works' );
+
+is( Catalyst::Utils::class2env('MyApp::Foo'), 'MYAPP_FOO', 'class2env works' );
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_request.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_request.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_request.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,27 @@
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+use_ok('Catalyst::Utils');
+
+{
+ my $url = "/dump";
+ ok(
+ my $request = Catalyst::Utils::request($url),
+ "Request: simple get without protocol nor host"
+ );
+ like( $request->uri, qr|^http://localhost/|,
+ " has default protocol and host" );
+}
+
+{
+ my $url = "/dump?url=http://www.somewhere.com/";
+ ok(
+ my $request = Catalyst::Utils::request($url),
+ "Same with param containing a url"
+ );
+ like( $request->uri, qr|^http://localhost/|,
+ " has default protocol and host" );
+}
+
Added: Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_subdir.t
===================================================================
--- Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_subdir.t (rev 0)
+++ Catalyst-Runtime/5.70/tags/5.7015/t/unit_utils_subdir.t 2008-10-15 21:03:20 UTC (rev 8539)
@@ -0,0 +1,32 @@
+use Test::More tests=>7;
+
+use strict;
+use warnings;
+
+# simulates an entire testapp rooted at t/something
+# except without bothering creating it since its
+# only the -e check on the Makefile.PL that matters
+
+BEGIN { use_ok 'Catalyst::Utils' }
+use FindBin;
+
+{
+ $INC{'TestApp.pm'} = "$FindBin::Bin/something/script/foo/../../lib/TestApp.pm";
+ my $home = Catalyst::Utils::home('TestApp');
+ like($home, qr{t[\/\\]something}, "has path TestApp/t/something");
+ unlike($home, qr{[\/\\]script[\/\\]foo}, "doesn't have path /script/foo");
+}
+
+{
+ $INC{'TestApp.pm'} = "$FindBin::Bin/something/script/foo/bar/../../../lib/TestApp.pm";
+ my $home = Catalyst::Utils::home('TestApp');
+ like($home, qr{t[\/\\]something}, "has path TestApp/t/something");
+ unlike($home, qr{[\/\\]script[\/\\]foo[\/\\]bar}, "doesn't have path /script/foo/bar");
+}
+
+{
+ $INC{'TestApp.pm'} = "$FindBin::Bin/something/script/../lib/TestApp.pm";
+ my $home = Catalyst::Utils::home('TestApp');
+ like($home, qr{t[\/\\]something}, "has path TestApp/t/something");
+ unlike($home, qr{[\/\\]script[\/\\]foo}, "doesn't have path /script/foo");
+}
More information about the Catalyst-commits
mailing list